package OpenSRF::Utils::JSON; use warnings; use strict; use JSON::XS; our $parser = JSON::XS->new; $parser->ascii(1); # output \u escaped strings for any char with a value over 127 $parser->allow_nonref(1); # allows non-reference values to equate to themselves (see perldoc) our %_class_map = (); our $JSON_CLASS_KEY = '__c'; # points to the classname of encoded objects our $JSON_PAYLOAD_KEY = '__p'; # same, for payload =head1 NAME OpenSRF::Utils::JSON - Serialize/Vivify objects =head1 SYNOPSIS C is a functional-style package which exports nothing. All calls to routines must use the fully-qualified name, and expect an invocant, as in OpenSRF::Utils::JSON->JSON2perl($string); The routines which are called by existing external code all deal with the serialization/stringification of objects and their revivification. =head1 ROUTINES =head2 register_class_hint This routine is used by objects which wish to serialize themselves with the L routine. It has two required arguments, C and C. OpenSRF::Util::JSON->register_class_hint( hint => 'osrfException', name => 'OpenSRF::DomainObject::oilsException'); Where C can be any unique string (but canonically is the name from the IDL which matches the object being operated on), and C is the language-specific classname which objects will be revivified as. =cut sub register_class_hint { # FIXME hint can't be a dupe # FIXME fail unless we have hint and name my ($pkg, %args) = @_; $_class_map{hints}{$args{hint}} = \%args; $_class_map{classes}{$args{name}} = \%args; } =head2 JSON2perl =cut sub JSON2perl { my( $pkg, $string ) = @_; my $perl = $pkg->rawJSON2perl($string); return $pkg->JSONObject2Perl($perl); } =head2 perl2JSON =cut sub perl2JSON { my( $pkg, $obj ) = @_; my $json = $pkg->perl2JSONObject($obj); return $pkg->rawPerl2JSON($json); } =head2 JSONObject2Perl =cut sub JSONObject2Perl { my ($pkg, $obj) = @_; my $ref = ref $obj; if( $ref eq 'HASH' ) { if( defined($obj->{$JSON_CLASS_KEY})) { my $class = $obj->{$JSON_CLASS_KEY}; $class =~ s/^\s+//o; $class =~ s/\s+$//o; if( $obj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) { $class = $pkg->lookup_class($class) || $class; return bless(\$obj, $class) unless ref($obj); return bless($obj, $class); } return undef; } for my $k (keys %$obj) { $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k}) unless ref($obj->{$k}) eq 'JSON::XS::Boolean'; } } elsif( $ref eq 'ARRAY' ) { for my $i (0..scalar(@$obj) - 1) { $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i]) unless ref($obj->[$i]) eq 'JSON::XS::Boolean'; } } return $obj; } =head2 perl2JSONObject =cut sub perl2JSONObject { my ($pkg, $obj) = @_; my $ref = ref($obj); return $obj unless $ref; return $obj if $ref eq 'JSON::XS::Boolean'; my $newobj; if(UNIVERSAL::isa($obj, 'HASH')) { $newobj = {}; $newobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj); } elsif(UNIVERSAL::isa($obj, 'ARRAY')) { $newobj = []; $newobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1); } if($ref ne 'HASH' and $ref ne 'ARRAY') { $ref = $pkg->lookup_hint($ref) || $ref; $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj}; } return $newobj; } =head2 rawJSON2perl Internal routine used by L. Wrapper around L. =cut sub rawJSON2perl { my ($pkg, $json) = @_; return undef unless defined $json and $json !~ /^\s*$/o; return $parser->decode($json); } =head2 rawPerl2JSON Internal routine used by L. Wrapper around L. =cut sub rawPerl2JSON { my ($pkg, $perl) = @_; return $parser->encode($perl); } =head2 lookup_class =cut sub lookup_class { # FIXME when there are tests, see if these two routines can be # rewritten as one, or at least made to do lookup in the structure # they're named after. best case: flatten _class_map, since hints # and classes are identical my ($pkg, $hint) = @_; return $_class_map{hints}{$hint}{name} } =head2 lookup_hint =cut sub lookup_hint { my ($pkg, $class) = @_; return $_class_map{classes}{$class}{hint} } =head2 true Wrapper for JSON::XS::true. J::X::true and J::X::false, according to its documentation, "are JSON atoms become JSON::XS::true and JSON::XS::false, respectively. They are overloaded to act almost exactly like the numbers 1 and 0" =cut sub true { return $parser->true } =head2 false See L =cut sub false { return $parser->false } 1;