2 package OpenSRF::Utils::JSON::number;
5 my $x = shift || $class;
6 return bless \$x => __PACKAGE__;
9 use overload ( '""' => \&toString );
11 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
13 package OpenSRF::Utils::JSON::bool::true;
14 sub new { return bless {} => __PACKAGE__ }
15 use overload ( '""' => \&toString );
16 use overload ( 'bool' => sub { 1 } );
17 use overload ( '0+' => sub { 1 } );
19 sub toString { 'true' }
21 package OpenSRF::Utils::JSON::bool::false;
22 sub new { return bless {} => __PACKAGE__ }
23 use overload ( '""' => \&toString );
24 use overload ( 'bool' => sub { 0 } );
25 use overload ( '0+' => sub { 0 } );
27 sub toString { 'false' }
29 package OpenSRF::Utils::JSON;
30 use Unicode::Normalize;
31 use vars qw/%_class_map/;
33 sub register_class_hint {
37 $_class_map{hints}{$args{hint}} = \%args;
38 $_class_map{classes}{$args{name}} = \%args;
47 -?\d+\.?\d* | # number literal
48 "(?:(?:\\[\"])|[^\"])*" | # string literal
49 (?:\/\*.+?\*\/) | # C comment
53 : | # object key-value sep
65 return $_class_map{hints}{$hint}{name}
71 return $_class_map{classes}{$class}{hint}
74 sub _json_hint_to_class {
78 return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
80 $type = 'hash' if ($type eq '}');
81 $type = 'array' if ($type eq ']');
83 OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
92 s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
93 s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
94 s/(?<!\\)\%/\\\%/gmo; # fixup % for later
96 # Convert JSON Unicode...
97 s/\\u([0-9a-fA-F]{4})/chr(hex($1))/esog;
99 # handle class blessings
100 s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
101 s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
103 my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
105 my @strings = /$re/sog;
107 # Replace with code...
108 #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
109 s/$re/ eval shift(\@strings) /sog;
111 # Perlify hash notation
115 #s/\b(-?\d+\.?\d*)\b/ OpenSRF::Utils::JSON::number::new($1) /sog;
117 # Change javascript stuff to perl...
119 s/true/ bless( {}, "OpenSRF::Utils::JSON::bool::true") /sog;
120 s/false/ bless( {}, "OpenSRF::Utils::JSON::bool::false") /sog;
123 return eval '$ret = '.$_;
131 $data = [ split //, $data ];
135 return _json_parse_data($data);
140 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
143 sub _json_parse_data {
150 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
154 my $c = $$data[$_json_index];
158 $class = _json_parse_comment($data);
160 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
161 $c = $$data[$_json_index];
171 my $c = $$data[$_json_index];
181 } elsif ($c eq '"') {
188 } elsif ($c eq 't') {
195 } elsif ($c eq 'b') {
202 } elsif ($c eq 'f') {
209 } elsif ($c eq 'r') {
216 } elsif ($c eq 'n') {
223 } elsif ($c eq 'u') {
226 $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3])));
237 #warn "string is $val";
242 #$out = _json_parse_string($data);
243 } elsif ($c eq '[') {
250 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
252 if ($$data[$_json_index] eq ']') {
259 if ($$data[$_json_index] ne ',') {
260 #warn "_json_parse_array: bad data, leaving array parser";
264 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
267 my $item = _json_parse_data($data);
273 #$out = _json_parse_array($data);
274 } elsif ($c eq '{') {
281 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
283 if ($$data[$_json_index] eq '}') {
290 if ($$data[$_json_index] ne ',') {
291 #warn "_json_parse_object: bad data, leaving object parser";
295 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
299 $key = _json_parse_data($data);
301 #warn "object key is $key";
303 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
305 if ($$data[$_json_index] ne ':') {
306 #warn "_json_parse_object: bad data, leaving object parser";
310 $value = _json_parse_data($data);
312 $out->{$key} = $value;
315 #$out = _json_parse_object($data);
316 } elsif (lc($c) eq 'n') {
317 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') {
320 warn "CRAP! bad null parsing...";
323 #$out = _json_parse_null($data);
324 } elsif (lc($c) eq 't' or lc($c) eq 'f') {
325 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') {
328 } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') {
332 #warn "CRAP! bad bool parsing...";
335 #$out = _json_parse_bool($data);
336 } elsif ($c =~ /\d+/o or $c eq '.' or $c eq '-') {
338 while ($$data[$_json_index] =~ /[-\.0-9]+/io) {
339 $val .= $$data[$_json_index];
343 #$out = _json_parse_number($data);
347 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
348 my $c = $$data[$_json_index];
352 _json_parse_comment($data)
355 bless( $out => lookup_class($class) );
361 sub _json_parse_null {
366 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') {
369 #warn "CRAP! bad null parsing...";
374 sub _json_parse_bool {
381 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') {
384 } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') {
388 #warn "CRAP! bad bool parsing...";
394 sub _json_parse_number {
397 #warn "parse_number";
400 while ($$data[$_json_index] =~ /[-\.0-9]+/io) {
401 $val .= $$data[$_json_index];
408 sub _json_parse_object {
411 #warn "parse_object";
418 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
420 if ($$data[$_json_index] eq '}') {
427 if ($$data[$_json_index] ne ',') {
428 #warn "_json_parse_object: bad data, leaving object parser";
432 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
436 $key = _json_parse_data($data);
438 #warn "object key is $key";
440 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
442 if ($$data[$_json_index] ne ':') {
443 #warn "_json_parse_object: bad data, leaving object parser";
447 $value = _json_parse_data($data);
449 $out->{$key} = $value;
456 sub _json_parse_array {
466 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
468 if ($$data[$_json_index] eq ']') {
475 if ($$data[$_json_index] ne ',') {
476 #warn "_json_parse_array: bad data, leaving array parser";
480 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
483 my $item = _json_parse_data($data);
493 sub _json_parse_string {
496 #warn "parse_string";
503 my $c = $$data[$_json_index];
513 } elsif ($c eq '"') {
520 } elsif ($c eq 't') {
527 } elsif ($c eq 'b') {
534 } elsif ($c eq 'f') {
541 } elsif ($c eq 'r') {
548 } elsif ($c eq 'n') {
555 } elsif ($c eq 'u') {
558 $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3])));
569 #warn "string is $val";
575 sub _json_parse_comment {
578 #warn "parse_comment";
580 if ($$data[$_json_index] eq '/') {
582 while (!($$data[$_json_index] eq "\n")) { $_json_index++ }
589 if (join('',$$data[$_json_index .. $_json_index + 2]) eq '*--') {
591 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
592 if ($$data[$_json_index] eq 'S') {
593 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
594 while ($$data[$_json_index] !~ /[-\s]+/o) {
595 $class .= $$data[$_json_index];
598 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
602 while ($$data[$_json_index] ne '/') { $_json_index++ };
609 my ($class, $json) = @_;
611 if (!defined($json)) {
615 $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
616 $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
617 $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
620 my $casting_depth = 0;
624 while (($json,$element) = _JSON_regex($json)) {
626 last unless ($element);
628 if ($element eq 'null') {
629 $output .= ' undef() ';
631 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
633 if (exists $_class_map{hints}{$hint}) {
634 $casts[$casting_depth] = $hint;
635 $output .= ' bless(';
638 } elsif ($element =~ /^\/\*/) {
640 } elsif ($element =~ /^\d/) {
641 $output .= "do { OpenSRF::Utils::JSON::number::new($element) }";
643 } elsif ($element eq '{' or $element eq '[') {
645 } elsif ($element eq '}' or $element eq ']') {
647 my $hint = $casts[$casting_depth];
648 $casts[$casting_depth] = undef;
649 if (defined $hint and exists $_class_map{hints}{$hint}) {
650 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
653 } elsif ($element eq ':') {
656 } elsif ($element eq 'true') {
657 $output .= 'bless( {}, "OpenSRF::Utils::JSON::bool::true")';
659 } elsif ($element eq 'false') {
660 $output .= 'bless( {}, "OpenSRF::Utils::JSON::bool::false")';
671 my ($class, $perl, $strict) = @_;
674 if (!defined($perl)) {
675 $output = '' if $strict;
676 $output = 'null' unless $strict;
677 } elsif (ref($perl) and ref($perl) =~ /^OpenSRF::Utils::JSON/) {
679 } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
680 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
681 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
683 $output .= perl2JSON(undef,\%hash, $strict);
684 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
686 $output .= perl2JSON(undef,\@array, $strict);
688 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
689 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
692 for my $key (sort keys %$perl) {
693 my $outkey = NFC($key);
694 $output .= ',' if ($c);
696 $outkey =~ s{\\}{\\\\}sgo;
697 $outkey =~ s/"/\\"/sgo;
698 $outkey =~ s/\t/\\t/sgo;
699 $outkey =~ s/\f/\\f/sgo;
700 $outkey =~ s/\r/\\r/sgo;
701 $outkey =~ s/\n/\\n/sgo;
702 $outkey =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
704 $output .= '"'.$outkey.'":'. perl2JSON(undef,$$perl{$key}, $strict);
708 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
711 for my $part (@$perl) {
712 $output .= ',' if ($c);
714 $output .= perl2JSON(undef,$part, $strict);
718 } elsif (ref($perl) and ref($perl) =~ /CODE/) {
719 $output .= perl2JSON(undef,$perl->(), $strict);
720 } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
723 OpenSRF::Utils::JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
724 $output .= perl2JSON(undef,$perl, $strict);
727 $perl =~ s{\\}{\\\\}sgo;
728 $perl =~ s/"/\\"/sgo;
729 $perl =~ s/\t/\\t/sgo;
730 $perl =~ s/\f/\\f/sgo;
731 $perl =~ s/\r/\\r/sgo;
732 $perl =~ s/\n/\\n/sgo;
733 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
734 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
737 $output = '"'.$perl.'"';
745 sub perl2prettyJSON {
746 my ($class, $perl, $nospace) = @_;
750 if (!defined($perl)) {
751 $output = " "x$depth unless($nospace);
753 } elsif (ref($perl) and ref($perl) =~ /^OpenSRF::Utils::JSON/) {
754 $output = " "x$depth unless($nospace);
756 } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
759 $output .= " "x$depth;
760 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
761 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
763 $output .= perl2prettyJSON(\%hash,undef,1);
764 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
766 $output .= perl2prettyJSON(\@array,undef,1);
768 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
770 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
771 $output .= " "x$depth unless ($nospace);
775 for my $key (sort keys %$perl) {
776 $output .= ",\n" if ($c);
777 $output .= " "x$depth;
778 $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
783 $output .= " "x$depth;
785 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
786 $output .= " "x$depth unless ($nospace);
790 for my $part (@$perl) {
791 $output .= ",\n" if ($c);
792 $output .= " "x$depth;
793 $output .= perl2prettyJSON($part);
798 $output .= " "x$depth;
800 } elsif (ref($perl) and ref($perl) =~ /CODE/) {
801 $output .= perl2prettyJSON(undef,$perl->(), $nospace);
802 } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
805 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
806 $output .= perl2prettyJSON(undef,$perl);
809 $perl =~ s/\\/\\\\/sgo;
810 $perl =~ s/"/\\"/sgo;
811 $perl =~ s/\t/\\t/sgo;
812 $perl =~ s/\f/\\f/sgo;
813 $perl =~ s/\r/\\r/sgo;
814 $perl =~ s/\n/\\n/sgo;
815 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
816 $output .= " "x$depth unless($nospace);
817 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
820 $output = '"'.$perl.'"';