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);
89 my $JSON_CLASS_KEY = '__c';
90 my $JSON_PAYLOAD_KEY = '__p';
93 my( $class, $string ) = @_;
94 my $perl = $class->rawJSON2perl($string);
95 return $class->JSONObject2Perl($perl);
99 my( $class, $obj ) = @_;
100 my $json = $class->perl2JSONObject($obj);
101 return $class->rawPerl2JSON($json);
104 sub JSONObject2Perl {
108 if( $ref eq 'HASH' ) {
109 if( defined($obj->{$JSON_CLASS_KEY})) {
110 my $cls = $obj->{$JSON_CLASS_KEY};
113 if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
114 $cls = $class->lookup_class($cls) || $cls;
115 return bless(\$obj, $cls) unless ref($obj);
116 return bless($obj, $cls);
120 $obj->{$_} = $class->JSONObject2Perl($obj->{$_}) for (keys %$obj);
121 } elsif( $ref eq 'ARRAY' ) {
122 $obj->[$_] = $class->JSONObject2Perl($obj->[$_]) for(0..scalar(@$obj) - 1);
127 sub perl2JSONObject {
132 return $obj unless $ref;
135 if( $ref eq 'HASH' ) {
137 $newobj->{$_} = $class->perl2JSONObject( $obj->{$_} ) for (keys %$obj);
138 } elsif( $ref eq 'ARRAY' ) {
140 $newobj->[$_] = $class->perl2JSONObject( $obj->[$_] ) for(0..scalar(@$obj) - 1 );
142 if(UNIVERSAL::isa($obj, 'HASH')) {
144 $newobj->{$_} = $class->perl2JSONObject( $obj->{$_} ) for (keys %$obj);
145 bless( $newobj, ref($obj) );
146 #bless($obj, 'HASH'); # so our parser won't add the hints
147 } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
149 $newobj->[$_] = $class->perl2JSONObject( $obj->[$_] ) for(0..scalar(@$obj) - 1);
150 bless( $newobj, ref($obj) );
151 #bless($obj, 'ARRAY'); # so our parser won't add the hints
153 $ref = $class->lookup_hint($ref) || $ref;
154 $newobj = { $JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj };
164 s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
165 s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
166 s/(?<!\\)\%/\\\%/gmo; # fixup % for later
168 # Convert JSON Unicode...
169 s/\\u([0-9a-fA-F]{4})/chr(hex($1))/esog;
171 # handle class blessings
172 # s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
173 # s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
175 my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
177 my @strings = /$re/sog;
179 # Replace with code...
180 #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
181 s/$re/ eval shift(\@strings) /sog;
183 # Perlify hash notation
187 #s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
189 # Change javascript stuff to perl...
191 s/true/ bless( {}, "JSON::bool::true") /sog;
192 s/false/ bless( {}, "JSON::bool::false") /sog;
195 return eval '$ret = '.$_;
204 $data = [ split //, $data ];
208 return _json_parse_data($data);
213 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
216 sub _json_parse_data {
223 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
227 my $c = $$data[$_json_index];
231 $class = _json_parse_comment($data);
233 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
234 $c = $$data[$_json_index];
244 my $c = $$data[$_json_index];
254 } elsif ($c eq '"') {
261 } elsif ($c eq 't') {
268 } elsif ($c eq 'b') {
275 } elsif ($c eq 'f') {
282 } elsif ($c eq 'r') {
289 } elsif ($c eq 'n') {
296 } elsif ($c eq 'u') {
299 $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3])));
310 #warn "string is $val";
315 #$out = _json_parse_string($data);
316 } elsif ($c eq '[') {
323 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
325 if ($$data[$_json_index] eq ']') {
332 if ($$data[$_json_index] ne ',') {
333 #warn "_json_parse_array: bad data, leaving array parser";
337 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
340 my $item = _json_parse_data($data);
346 #$out = _json_parse_array($data);
347 } elsif ($c eq '{') {
354 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
356 if ($$data[$_json_index] eq '}') {
363 if ($$data[$_json_index] ne ',') {
364 #warn "_json_parse_object: bad data, leaving object parser";
368 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
372 $key = _json_parse_data($data);
374 #warn "object key is $key";
376 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
378 if ($$data[$_json_index] ne ':') {
379 #warn "_json_parse_object: bad data, leaving object parser";
383 $value = _json_parse_data($data);
385 $out->{$key} = $value;
388 #$out = _json_parse_object($data);
389 } elsif (lc($c) eq 'n') {
390 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') {
393 warn "CRAP! bad null parsing...";
396 #$out = _json_parse_null($data);
397 } elsif (lc($c) eq 't' or lc($c) eq 'f') {
398 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') {
401 } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') {
405 #warn "CRAP! bad bool parsing...";
408 #$out = _json_parse_bool($data);
409 } elsif ($c =~ /\d+/o or $c eq '.' or $c eq '-') {
411 while ($$data[$_json_index] =~ /[-\.0-9]+/io) {
412 $val .= $$data[$_json_index];
416 #$out = _json_parse_number($data);
420 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
421 my $c = $$data[$_json_index];
425 _json_parse_comment($data)
428 bless( $out => lookup_class($class) );
434 sub _json_parse_null {
439 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') {
442 #warn "CRAP! bad null parsing...";
447 sub _json_parse_bool {
454 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') {
457 } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') {
461 #warn "CRAP! bad bool parsing...";
467 sub _json_parse_number {
470 #warn "parse_number";
473 while ($$data[$_json_index] =~ /[-\.0-9]+/io) {
474 $val .= $$data[$_json_index];
481 sub _json_parse_object {
484 #warn "parse_object";
491 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
493 if ($$data[$_json_index] eq '}') {
500 if ($$data[$_json_index] ne ',') {
501 #warn "_json_parse_object: bad data, leaving object parser";
505 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
509 $key = _json_parse_data($data);
511 #warn "object key is $key";
513 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
515 if ($$data[$_json_index] ne ':') {
516 #warn "_json_parse_object: bad data, leaving object parser";
520 $value = _json_parse_data($data);
522 $out->{$key} = $value;
529 sub _json_parse_array {
539 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
541 if ($$data[$_json_index] eq ']') {
548 if ($$data[$_json_index] ne ',') {
549 #warn "_json_parse_array: bad data, leaving array parser";
553 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
556 my $item = _json_parse_data($data);
566 sub _json_parse_string {
569 #warn "parse_string";
576 my $c = $$data[$_json_index];
586 } elsif ($c eq '"') {
593 } elsif ($c eq 't') {
600 } elsif ($c eq 'b') {
607 } elsif ($c eq 'f') {
614 } elsif ($c eq 'r') {
621 } elsif ($c eq 'n') {
628 } elsif ($c eq 'u') {
631 $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3])));
642 #warn "string is $val";
648 sub _json_parse_comment {
651 #warn "parse_comment";
653 if ($$data[$_json_index] eq '/') {
655 while (!($$data[$_json_index] eq "\n")) { $_json_index++ }
662 if (join('',$$data[$_json_index .. $_json_index + 2]) eq '*--') {
664 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
665 if ($$data[$_json_index] eq 'S') {
666 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
667 while ($$data[$_json_index] !~ /[-\s]+/o) {
668 $class .= $$data[$_json_index];
671 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
675 while ($$data[$_json_index] ne '/') { $_json_index++ };
682 my ($class, $json) = @_;
684 if (!defined($json)) {
688 $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
689 $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
690 $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
693 my $casting_depth = 0;
697 while (($json,$element) = _JSON_regex($json)) {
699 last unless ($element);
701 if ($element eq 'null') {
702 $output .= ' undef() ';
704 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
706 if (exists $_class_map{hints}{$hint}) {
707 $casts[$casting_depth] = $hint;
708 $output .= ' bless(';
711 } elsif ($element =~ /^\/\*/) {
713 } elsif ($element =~ /^\d/) {
714 $output .= "do { JSON::number::new($element) }";
716 } elsif ($element eq '{' or $element eq '[') {
718 } elsif ($element eq '}' or $element eq ']') {
720 my $hint = $casts[$casting_depth];
721 $casts[$casting_depth] = undef;
722 if (defined $hint and exists $_class_map{hints}{$hint}) {
723 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
726 } elsif ($element eq ':') {
729 } elsif ($element eq 'true') {
730 $output .= 'bless( {}, "JSON::bool::true")';
732 } elsif ($element eq 'false') {
733 $output .= 'bless( {}, "JSON::bool::false")';
745 my ($class, $perl, $strict) = @_;
748 if (!defined($perl)) {
749 $output = '' if $strict;
750 $output = 'null' unless $strict;
751 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
753 # } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
754 # $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
755 # if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
757 # $output .= rawPerl2JSON(undef,\%hash, $strict);
758 # } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
759 # my @array = @$perl;
760 # $output .= rawPerl2JSON(undef,\@array, $strict);
762 # $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
763 # } elsif (ref($perl) and ref($perl) =~ /HASH/) {
764 } elsif (UNIVERSAL::isa($perl, 'HASH')) {
767 for my $key (sort keys %$perl) {
768 my $outkey = NFC($key);
769 $output .= ',' if ($c);
771 $outkey =~ s{\\}{\\\\}sgo;
772 $outkey =~ s/"/\\"/sgo;
773 $outkey =~ s/\t/\\t/sgo;
774 $outkey =~ s/\f/\\f/sgo;
775 $outkey =~ s/\r/\\r/sgo;
776 $outkey =~ s/\n/\\n/sgo;
777 $outkey =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
779 $output .= '"'.$outkey.'":'. rawPerl2JSON(undef,$$perl{$key}, $strict);
783 # } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
784 } elsif (UNIVERSAL::isa($perl, 'ARRAY')) {
787 for my $part (@$perl) {
788 $output .= ',' if ($c);
790 $output .= rawPerl2JSON(undef,$part, $strict);
794 } elsif (ref($perl) and ref($perl) =~ /CODE/) {
795 $output .= rawPerl2JSON(undef,$perl->(), $strict);
796 } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
799 OpenSRF::Utils::JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
800 $output .= rawPerl2JSON(undef,$perl, $strict);
803 $perl =~ s{\\}{\\\\}sgo;
804 $perl =~ s/"/\\"/sgo;
805 $perl =~ s/\t/\\t/sgo;
806 $perl =~ s/\f/\\f/sgo;
807 $perl =~ s/\r/\\r/sgo;
808 $perl =~ s/\n/\\n/sgo;
809 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
810 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
813 $output = '"'.$perl.'"';
821 sub perl2prettyJSON {
822 my ($class, $perl, $nospace) = @_;
826 if (!defined($perl)) {
827 $output = " "x$depth unless($nospace);
829 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
830 $output = " "x$depth unless($nospace);
832 } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
835 $output .= " "x$depth;
836 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
837 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
839 $output .= perl2prettyJSON(\%hash,undef,1);
840 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
842 $output .= perl2prettyJSON(\@array,undef,1);
844 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
846 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
847 $output .= " "x$depth unless ($nospace);
851 for my $key (sort keys %$perl) {
852 $output .= ",\n" if ($c);
853 $output .= " "x$depth;
854 $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
859 $output .= " "x$depth;
861 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
862 $output .= " "x$depth unless ($nospace);
866 for my $part (@$perl) {
867 $output .= ",\n" if ($c);
868 $output .= " "x$depth;
869 $output .= perl2prettyJSON($part);
874 $output .= " "x$depth;
876 } elsif (ref($perl) and ref($perl) =~ /CODE/) {
877 $output .= perl2prettyJSON(undef,$perl->(), $nospace);
878 } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
881 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
882 $output .= perl2prettyJSON(undef,$perl);
885 $perl =~ s/\\/\\\\/sgo;
886 $perl =~ s/"/\\"/sgo;
887 $perl =~ s/\t/\\t/sgo;
888 $perl =~ s/\f/\\f/sgo;
889 $perl =~ s/\r/\\r/sgo;
890 $perl =~ s/\n/\\n/sgo;
891 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
892 $output .= " "x$depth unless($nospace);
893 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
896 $output = '"'.$perl.'"';