package OpenSRF::Utils::JSON::number; sub new { my $class = shift; my $x = shift || $class; return bless \$x => __PACKAGE__; } use overload ( '""' => \&toString ); sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} } package OpenSRF::Utils::JSON::bool::true; sub new { return bless {} => __PACKAGE__ } use overload ( '""' => \&toString ); use overload ( 'bool' => sub { 1 } ); use overload ( '0+' => sub { 1 } ); sub toString { 'true' } package OpenSRF::Utils::JSON::bool::false; sub new { return bless {} => __PACKAGE__ } use overload ( '""' => \&toString ); use overload ( 'bool' => sub { 0 } ); use overload ( '0+' => sub { 0 } ); sub toString { 'false' } package OpenSRF::Utils::JSON; use Unicode::Normalize; use vars qw/%_class_map/; sub register_class_hint { my $class = shift; my %args = @_; $_class_map{hints}{$args{hint}} = \%args; $_class_map{classes}{$args{name}} = \%args; } sub _JSON_regex { my $string = shift; $string =~ s/^\s* ( { | # start object \[ | # start array -?\d+\.?\d* | # number literal "(?:(?:\\[\"])|[^\"])*" | # string literal (?:\/\*.+?\*\/) | # C comment true | # bool true false | # bool false null | # undef() : | # object key-value sep , | # list sep \] | # array end } # object end ) \s*//sox; return ($string,$1); } sub lookup_class { my $self = shift; my $hint = shift; return $_class_map{hints}{$hint}{name} } sub lookup_hint { my $self = shift; my $class = shift; return $_class_map{classes}{$class}{hint} } sub _json_hint_to_class { my $type = shift; my $hint = shift; return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint}); $type = 'hash' if ($type eq '}'); $type = 'array' if ($type eq ']'); OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type); return $hint; } my $JSON_CLASS_KEY = '__c'; my $JSON_PAYLOAD_KEY = '__p'; sub JSON2perl { my( $class, $string ) = @_; my $perl = $class->rawJSON2perl($string); return $class->JSONObject2Perl($perl); } sub perl2JSON { my( $class, $obj ) = @_; my $json = $class->perl2JSONObject($obj); return $class->rawPerl2JSON($json); } sub JSONObject2Perl { my $class = shift; my $obj = shift; my $ref = ref($obj); if( $ref eq 'HASH' ) { if( defined($obj->{$JSON_CLASS_KEY})) { my $cls = $obj->{$JSON_CLASS_KEY}; $cls =~ s/^\s+//o; $cls =~ s/\s+$//o; if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) { $cls = $class->lookup_class($cls) || $cls; return bless(\$obj, $cls) unless ref($obj); return bless($obj, $cls); } return undef; } $obj->{$_} = $class->JSONObject2Perl($obj->{$_}) for (keys %$obj); } elsif( $ref eq 'ARRAY' ) { $obj->[$_] = $class->JSONObject2Perl($obj->[$_]) for(0..scalar(@$obj) - 1); } return $obj; } sub perl2JSONObject { my $class = shift; my $obj = shift; my $ref = ref($obj); return $obj unless $ref; my $newobj; if( $ref eq 'HASH' ) { $newobj = {}; $newobj->{$_} = $class->perl2JSONObject( $obj->{$_} ) for (keys %$obj); } elsif( $ref eq 'ARRAY' ) { $newobj = []; $newobj->[$_] = $class->perl2JSONObject( $obj->[$_] ) for(0..scalar(@$obj) - 1 ); } elsif( $ref ) { if(UNIVERSAL::isa($obj, 'HASH')) { $newobj = {}; $newobj->{$_} = $class->perl2JSONObject( $obj->{$_} ) for (keys %$obj); bless( $newobj, ref($obj) ); #bless($obj, 'HASH'); # so our parser won't add the hints } elsif(UNIVERSAL::isa($obj, 'ARRAY')) { $newobj = []; $newobj->[$_] = $class->perl2JSONObject( $obj->[$_] ) for(0..scalar(@$obj) - 1); bless( $newobj, ref($obj) ); #bless($obj, 'ARRAY'); # so our parser won't add the hints } $ref = $class->lookup_hint($ref) || $ref; $newobj = { $JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj }; } return $newobj; } sub rawJSON2perl { my $class = shift; local $_ = shift; s/(? _json_hint_to_class("$1", "$2")) /sog; my $re = qr/((?(?<=\\)"|[^"])*(? /sog; # Do numbers... #s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog; # Change javascript stuff to perl... s/null/ undef /sog; s/true/ bless( {}, "JSON::bool::true") /sog; s/false/ bless( {}, "JSON::bool::false") /sog; my $ret; return eval '$ret = '.$_; } my $_json_index; sub ___JSON2perl { my $class = shift; my $data = shift; $data = [ split //, $data ]; $_json_index = 0; return _json_parse_data($data); } sub _eat_WS { my $data = shift; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } } sub _json_parse_data { my $data = shift; my $out; #warn "parse_data"; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } my $class = ''; my $c = $$data[$_json_index]; if ($c eq '/') { $_json_index++; $class = _json_parse_comment($data); while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } $c = $$data[$_json_index]; } if ($c eq '"') { $_json_index++; my $val = ''; my $seen_slash = 0; my $done = 0; while (!$done) { my $c = $$data[$_json_index]; #warn "c is $c"; if ($c eq '\\') { if ($seen_slash) { $val .= '\\'; $seen_slash = 0; } else { $seen_slash = 1; } } elsif ($c eq '"') { if ($seen_slash) { $val .= '"'; $seen_slash = 0; } else { $done = 1; } } elsif ($c eq 't') { if ($seen_slash) { $val .= "\t"; $seen_slash = 0; } else { $val .= 't'; } } elsif ($c eq 'b') { if ($seen_slash) { $val .= "\b"; $seen_slash = 0; } else { $val .= 'b'; } } elsif ($c eq 'f') { if ($seen_slash) { $val .= "\f"; $seen_slash = 0; } else { $val .= 'f'; } } elsif ($c eq 'r') { if ($seen_slash) { $val .= "\r"; $seen_slash = 0; } else { $val .= 'r'; } } elsif ($c eq 'n') { if ($seen_slash) { $val .= "\n"; $seen_slash = 0; } else { $val .= 'n'; } } elsif ($c eq 'u') { if ($seen_slash) { $_json_index++; $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3]))); $_json_index += 3; $seen_slash = 0; } else { $val .= 'u'; } } else { $val .= $c; } $_json_index++; #warn "string is $val"; } $out = $val; #$out = _json_parse_string($data); } elsif ($c eq '[') { $_json_index++; $out = []; my $in_parse = 0; my $done = 0; while(!$done) { while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } if ($$data[$_json_index] eq ']') { $done = 1; $_json_index++; last; } if ($in_parse) { if ($$data[$_json_index] ne ',') { #warn "_json_parse_array: bad data, leaving array parser"; last; } $_json_index++; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } } my $item = _json_parse_data($data); push @$out, $item; $in_parse++; } #$out = _json_parse_array($data); } elsif ($c eq '{') { $_json_index++; $out = {}; my $in_parse = 0; my $done = 0; while(!$done) { while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } if ($$data[$_json_index] eq '}') { $done = 1; $_json_index++; last; } if ($in_parse) { if ($$data[$_json_index] ne ',') { #warn "_json_parse_object: bad data, leaving object parser"; last; } $_json_index++; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } } my ($key,$value); $key = _json_parse_data($data); #warn "object key is $key"; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } if ($$data[$_json_index] ne ':') { #warn "_json_parse_object: bad data, leaving object parser"; last; } $_json_index++; $value = _json_parse_data($data); $out->{$key} = $value; $in_parse++; } #$out = _json_parse_object($data); } elsif (lc($c) eq 'n') { if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') { $_json_index += 4; } else { warn "CRAP! bad null parsing..."; } $out = undef; #$out = _json_parse_null($data); } elsif (lc($c) eq 't' or lc($c) eq 'f') { if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') { $out = 1; $_json_index += 4; } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') { $out = 0; $_json_index += 5; } else { #warn "CRAP! bad bool parsing..."; $out = undef; } #$out = _json_parse_bool($data); } elsif ($c =~ /\d+/o or $c eq '.' or $c eq '-') { my $val; while ($$data[$_json_index] =~ /[-\.0-9]+/io) { $val .= $$data[$_json_index]; $_json_index++; } $out = 0+$val; #$out = _json_parse_number($data); } if ($class) { while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } my $c = $$data[$_json_index]; if ($c eq '/') { $_json_index++; _json_parse_comment($data) } bless( $out => lookup_class($class) ); } $out; } sub _json_parse_null { my $data = shift; #warn "parse_null"; if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') { $_json_index += 4; } else { #warn "CRAP! bad null parsing..."; } return undef; } sub _json_parse_bool { my $data = shift; my $out; #warn "parse_bool"; if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') { $out = 1; $_json_index += 4; } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') { $out = 0; $_json_index += 5; } else { #warn "CRAP! bad bool parsing..."; $out = undef; } return $out; } sub _json_parse_number { my $data = shift; #warn "parse_number"; my $val; while ($$data[$_json_index] =~ /[-\.0-9]+/io) { $val .= $$data[$_json_index]; $_json_index++; } return 0+$val; } sub _json_parse_object { my $data = shift; #warn "parse_object"; my $out = {}; my $in_parse = 0; my $done = 0; while(!$done) { while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } if ($$data[$_json_index] eq '}') { $done = 1; $_json_index++; last; } if ($in_parse) { if ($$data[$_json_index] ne ',') { #warn "_json_parse_object: bad data, leaving object parser"; last; } $_json_index++; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } } my ($key,$value); $key = _json_parse_data($data); #warn "object key is $key"; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } if ($$data[$_json_index] ne ':') { #warn "_json_parse_object: bad data, leaving object parser"; last; } $_json_index++; $value = _json_parse_data($data); $out->{$key} = $value; $in_parse++; } return $out; } sub _json_parse_array { my $data = shift; #warn "parse_array"; my $out = []; my $in_parse = 0; my $done = 0; while(!$done) { while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } if ($$data[$_json_index] eq ']') { $done = 1; $_json_index++; last; } if ($in_parse) { if ($$data[$_json_index] ne ',') { #warn "_json_parse_array: bad data, leaving array parser"; last; } $_json_index++; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } } my $item = _json_parse_data($data); push @$out, $item; $in_parse++; } return $out; } sub _json_parse_string { my $data = shift; #warn "parse_string"; my $val = ''; my $seen_slash = 0; my $done = 0; while (!$done) { my $c = $$data[$_json_index]; #warn "c is $c"; if ($c eq '\\') { if ($seen_slash) { $val .= '\\'; $seen_slash = 0; } else { $seen_slash = 1; } } elsif ($c eq '"') { if ($seen_slash) { $val .= '"'; $seen_slash = 0; } else { $done = 1; } } elsif ($c eq 't') { if ($seen_slash) { $val .= "\t"; $seen_slash = 0; } else { $val .= 't'; } } elsif ($c eq 'b') { if ($seen_slash) { $val .= "\b"; $seen_slash = 0; } else { $val .= 'b'; } } elsif ($c eq 'f') { if ($seen_slash) { $val .= "\f"; $seen_slash = 0; } else { $val .= 'f'; } } elsif ($c eq 'r') { if ($seen_slash) { $val .= "\r"; $seen_slash = 0; } else { $val .= 'r'; } } elsif ($c eq 'n') { if ($seen_slash) { $val .= "\n"; $seen_slash = 0; } else { $val .= 'n'; } } elsif ($c eq 'u') { if ($seen_slash) { $_json_index++; $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3]))); $_json_index += 3; $seen_slash = 0; } else { $val .= 'u'; } } else { $val .= $c; } $_json_index++; #warn "string is $val"; } return $val; } sub _json_parse_comment { my $data = shift; #warn "parse_comment"; if ($$data[$_json_index] eq '/') { $_json_index++; while (!($$data[$_json_index] eq "\n")) { $_json_index++ } $_json_index++; return undef; } my $class = ''; if (join('',$$data[$_json_index .. $_json_index + 2]) eq '*--') { $_json_index += 3; while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } if ($$data[$_json_index] eq 'S') { while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } while ($$data[$_json_index] !~ /[-\s]+/o) { $class .= $$data[$_json_index]; $_json_index++; } while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ } } } while ($$data[$_json_index] ne '/') { $_json_index++ }; $_json_index++; return $class; } sub old_JSON2perl { my ($class, $json) = @_; if (!defined($json)) { return undef; } $json =~ s/(? '; next; } elsif ($element eq 'true') { $output .= 'bless( {}, "JSON::bool::true")'; next; } elsif ($element eq 'false') { $output .= 'bless( {}, "JSON::bool::false")'; next; } $output .= $element; } return eval $output; } sub rawPerl2JSON { my ($class, $perl, $strict) = @_; my $output = ''; if (!defined($perl)) { $output = '' if $strict; $output = 'null' unless $strict; } elsif (ref($perl) and ref($perl) =~ /^JSON/) { $output .= $perl; # } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) { # $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/'; # if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') { # my %hash = %$perl; # $output .= rawPerl2JSON(undef,\%hash, $strict); # } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') { # my @array = @$perl; # $output .= rawPerl2JSON(undef,\@array, $strict); # } # $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/'; # } elsif (ref($perl) and ref($perl) =~ /HASH/) { } elsif (UNIVERSAL::isa($perl, 'HASH')) { $output .= '{'; my $c = 0; for my $key (sort keys %$perl) { my $outkey = NFC($key); $output .= ',' if ($c); $outkey =~ s{\\}{\\\\}sgo; $outkey =~ s/"/\\"/sgo; $outkey =~ s/\t/\\t/sgo; $outkey =~ s/\f/\\f/sgo; $outkey =~ s/\r/\\r/sgo; $outkey =~ s/\n/\\n/sgo; $outkey =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe; $output .= '"'.$outkey.'":'. rawPerl2JSON(undef,$$perl{$key}, $strict); $c++; } $output .= '}'; # } elsif (ref($perl) and ref($perl) =~ /ARRAY/) { } elsif (UNIVERSAL::isa($perl, 'ARRAY')) { $output .= '['; my $c = 0; for my $part (@$perl) { $output .= ',' if ($c); $output .= rawPerl2JSON(undef,$part, $strict); $c++; } $output .= ']'; } elsif (ref($perl) and ref($perl) =~ /CODE/) { $output .= rawPerl2JSON(undef,$perl->(), $strict); } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) { my $type = $2; my $name = $1; OpenSRF::Utils::JSON->register_class_hint(name => $name, hint => $name, type => lc($type)); $output .= rawPerl2JSON(undef,$perl, $strict); } else { $perl = NFC($perl); $perl =~ s{\\}{\\\\}sgo; $perl =~ s/"/\\"/sgo; $perl =~ s/\t/\\t/sgo; $perl =~ s/\f/\\f/sgo; $perl =~ s/\r/\\r/sgo; $perl =~ s/\n/\\n/sgo; $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe; if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) { $output = $perl; } else { $output = '"'.$perl.'"'; } } return $output; } my $depth = 0; sub perl2prettyJSON { my ($class, $perl, $nospace) = @_; $perl ||= $class; my $output = ''; if (!defined($perl)) { $output = " "x$depth unless($nospace); $output .= 'null'; } elsif (ref($perl) and ref($perl) =~ /^JSON/) { $output = " "x$depth unless($nospace); $output .= $perl; } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) { $depth++; $output .= "\n"; $output .= " "x$depth; $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ "; if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') { my %hash = %$perl; $output .= perl2prettyJSON(\%hash,undef,1); } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') { my @array = @$perl; $output .= perl2prettyJSON(\@array,undef,1); } $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/'; $depth--; } elsif (ref($perl) and ref($perl) =~ /HASH/) { $output .= " "x$depth unless ($nospace); $output .= "{\n"; my $c = 0; $depth++; for my $key (sort keys %$perl) { $output .= ",\n" if ($c); $output .= " "x$depth; $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1); $c++; } $depth--; $output .= "\n"; $output .= " "x$depth; $output .= '}'; } elsif (ref($perl) and ref($perl) =~ /ARRAY/) { $output .= " "x$depth unless ($nospace); $output .= "[\n"; my $c = 0; $depth++; for my $part (@$perl) { $output .= ",\n" if ($c); $output .= " "x$depth; $output .= perl2prettyJSON($part); $c++; } $depth--; $output .= "\n"; $output .= " "x$depth; $output .= "]"; } elsif (ref($perl) and ref($perl) =~ /CODE/) { $output .= perl2prettyJSON(undef,$perl->(), $nospace); } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) { my $type = $2; my $name = $1; register_class_hint(undef, name => $name, hint => $name, type => lc($type)); $output .= perl2prettyJSON(undef,$perl); } else { $perl = NFC($perl); $perl =~ s/\\/\\\\/sgo; $perl =~ s/"/\\"/sgo; $perl =~ s/\t/\\t/sgo; $perl =~ s/\f/\\f/sgo; $perl =~ s/\r/\\r/sgo; $perl =~ s/\n/\\n/sgo; $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe; $output .= " "x$depth unless($nospace); if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) { $output = $perl; } else { $output = '"'.$perl.'"'; } } return $output; } 1;