src/perl/lib/OpenSRF/Utils/JSON.pm

   1 package OpenSRF::Utils::JSON;
   2
   3 use warnings;
   4 use strict;
   5 use JSON::XS;
   6
   7 our $parser = JSON::XS->new;
   8 $parser->ascii(1);        # output \u escaped strings for any char with a value over 127
   9 $parser->allow_nonref(1); # allows non-reference values to equate to themselves (see perldoc)
  10
  11 our %_class_map = ();
  12 our $JSON_CLASS_KEY = '__c';   # points to the classname of encoded objects
  13 our $JSON_PAYLOAD_KEY = '__p'; # same, for payload
  14
  15
  16 =head1 NAME
  17
  18 OpenSRF::Utils::JSON - Serialize/Vivify objects
  19
  20 =head1 SYNOPSIS
  21
  22 C<O::U::JSON> is a functional-style package which exports nothing. All
  23 calls to routines must use the fully-qualified name, and expect an
  24 invocant, as in
  25
  26     OpenSRF::Utils::JSON->JSON2perl($string);
  27
  28 The routines which are called by existing external code all deal with
  29 the serialization/stringification of objects and their revivification.
  30
  31 =head1 ROUTINES
  32
  33 =head2 register_class_hint
  34
  35 This routine is used by objects which wish to serialize themselves
  36 with the L</perl2JSON> routine. It has two required arguments, C<name>
  37 and C<hint>.
  38
  39     OpenSRF::Util::JSON->register_class_hint( hint => 'osrfException',
  40                                               name => 'OpenSRF::DomainObject::oilsException');
  41
  42 Where C<hint> can be any unique string (but canonically is the name
  43 from the IDL which matches the object being operated on), and C<name>
  44 is the language-specific classname which objects will be revivified
  45 as.
  46
  47 =cut
  48
  49 sub register_class_hint {
  50     # FIXME hint can't be a dupe
  51     # FIXME fail unless we have hint and name
  52     my ($pkg, %args) = @_;
  53     $_class_map{hints}{$args{hint}} = \%args;
  54     $_class_map{classes}{$args{name}} = \%args;
  55 }
  56
  57
  58 =head2 JSON2perl
  59
  60 =cut
  61
  62 sub JSON2perl {
  63     my( $pkg, $string ) = @_;
  64     my $perl = $pkg->rawJSON2perl($string);
  65     return $pkg->JSONObject2Perl($perl);
  66 }
  67
  68
  69 =head2 perl2JSON
  70
  71 =cut
  72
  73 sub perl2JSON {
  74     my( $pkg, $obj ) = @_;
  75     my $json = $pkg->perl2JSONObject($obj);
  76     return $pkg->rawPerl2JSON($json);
  77 }
  78
  79
  80 =head2 JSONObject2Perl
  81
  82 =cut
  83
  84 sub JSONObject2Perl {
  85     my ($pkg, $obj) = @_;
  86     my $ref = ref $obj;
  87     if( $ref eq 'HASH' ) {
  88         if( defined($obj->{$JSON_CLASS_KEY})) {
  89             my $class = $obj->{$JSON_CLASS_KEY};
  90             $class =~ s/^\s+//o;
  91             $class =~ s/\s+$//o;
  92             if( $obj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
  93                 $class = $pkg->lookup_class($class) || $class;
  94                 return bless(\$obj, $class) unless ref($obj);
  95                 return bless($obj, $class);
  96             }
  97             return undef;
  98         }
  99         for my $k (keys %$obj) {
 100             $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k})
 101               unless ref($obj->{$k}) eq 'JSON::XS::Boolean';
 102         }
 103     } elsif( $ref eq 'ARRAY' ) {
 104         for my $i (0..scalar(@$obj) - 1) {
 105             $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i])
 106               unless ref($obj->[$i]) eq 'JSON::XS::Boolean';
 107         }
 108     }
 109     return $obj;
 110 }
 111
 112
 113 =head2 perl2JSONObject
 114
 115 =cut
 116
 117 sub perl2JSONObject {
 118     my ($pkg, $obj) = @_;
 119     my $ref = ref($obj);
 120
 121     return $obj unless $ref;
 122
 123     return $obj if $ref eq 'JSON::XS::Boolean';
 124     my $newobj;
 125
 126     if(UNIVERSAL::isa($obj, 'HASH')) {
 127         $newobj = {};
 128         $newobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
 129     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 130         $newobj = [];
 131         $newobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 132     }
 133
 134     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 135         $ref = $pkg->lookup_hint($ref) || $ref;
 136         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
 137     }
 138
 139     return $newobj;
 140 }
 141
 142
 143 =head2 rawJSON2perl
 144
 145 Internal routine used by L</JSON2Perl>. Wrapper around
 146 L<JSON::XS::decode>.
 147
 148 =cut
 149
 150 sub rawJSON2perl {
 151     my ($pkg, $json) = @_;
 152     return undef unless defined $json and $json !~ /^\s*$/o;
 153     return $parser->decode($json);
 154 }
 155
 156
 157 =head2 rawPerl2JSON
 158
 159 Internal routine used by L</Perl2JSON>. Wrapper around
 160 L<JSON::XS::encode>.
 161
 162 =cut
 163
 164 sub rawPerl2JSON {
 165     my ($pkg, $perl) = @_;
 166     return $parser->encode($perl);
 167 }
 168
 169
 170 =head2 lookup_class
 171
 172 =cut
 173
 174 sub lookup_class {
 175     # FIXME when there are tests, see if these two routines can be
 176     # rewritten as one, or at least made to do lookup in the structure
 177     # they're named after. best case: flatten _class_map, since hints
 178     # and classes are identical
 179     my ($pkg, $hint) = @_;
 180     return $_class_map{hints}{$hint}{name}
 181 }
 182
 183
 184 =head2 lookup_hint
 185
 186 =cut
 187
 188 sub lookup_hint {
 189     my ($pkg, $class) = @_;
 190     return $_class_map{classes}{$class}{hint}
 191 }
 192
 193 =head2 true
 194
 195 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
 196 its documentation, "are JSON atoms become JSON::XS::true and
 197 JSON::XS::false, respectively. They are overloaded to act almost
 198 exactly like the numbers 1 and 0"
 199
 200 =cut
 201
 202 sub true { return $parser->true }
 203
 204 =head2 false
 205
 206 See L</true>
 207
 208 =cut
 209
 210 sub false { return $parser->false }
 211
 212 1;