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
  17 =head1 NAME
  18
  19 OpenSRF::Utils::JSON - Serialize/Vivify objects
  20
  21 =head1 SYNOPSIS
  22
  23 C<O::U::JSON> is a functional-style package which exports nothing. All
  24 calls to routines must use the fully-qualified name, and expect an
  25 invocant, as in
  26
  27     OpenSRF::Utils::JSON->JSON2perl($string);
  28
  29 The routines which are called by existing external code all deal with
  30 the serialization/stringification of objects and their revivification.
  31
  32
  33
  34 =head1 ROUTINES
  35
  36 =head2 register_class_hint
  37
  38 This routine is used by objects which wish to serialize themselves
  39 with the L</perl2JSON> routine. It has two required arguments, C<name>
  40 and C<hint>.
  41
  42     O::U::J->register_class_hint( hint => 'osrfException',
  43                                   name => 'OpenSRF::DomainObject::oilsException');
  44
  45 Where C<hint> can be any unique string (but canonically is the name
  46 from the IDL which matches the object being operated on), and C<name>
  47 is the language-specific classname which objects will be revivified
  48 as.
  49
  50 =cut
  51
  52 sub register_class_hint {
  53     # FIXME hint can't be a dupe?
  54     # FIXME fail unless we have hint and name?
  55     # FIXME validate hint against IDL?
  56     my ($pkg, %args) = @_;
  57     # FIXME maybe not just store a reference to %args; the lookup
  58     # functions are really confusing at first glance as a side effect
  59     # of this
  60     $_class_map{hints}{$args{hint}} = \%args;
  61     $_class_map{classes}{$args{name}} = \%args;
  62 }
  63
  64
  65 =head2 JSON2perl
  66
  67 Given a JSON-encoded string, returns a vivified Perl object built from
  68 that string.
  69
  70 =cut
  71
  72 sub JSON2perl {
  73     # FIXME $string is not checked for any criteria, even existance
  74     my( $pkg, $string ) = @_;
  75     my $perl = $pkg->rawJSON2perl($string);
  76     return $pkg->JSONObject2Perl($perl);
  77 }
  78
  79
  80 =head2 perl2JSON
  81
  82 Given a Perl object, returns a JSON stringified representation of that
  83 object.  Callers should not expect that the JSON string has hash keys
  84 sorted in any particular order.
  85
  86 =cut
  87
  88 sub perl2JSON {
  89     my( $pkg, $obj ) = @_;
  90     # FIXME no validation of any sort
  91     my $json = $pkg->perl2JSONObject($obj);
  92     return $pkg->rawPerl2JSON($json);
  93 }
  94
  95
  96
  97 =head1 INTERNAL ROUTINES
  98
  99 =head2 rawJSON2perl
 100
 101 Performs actual JSON -> data transformation, before
 102 L</JSONObject2Perl> is called.
 103
 104 =cut
 105
 106 sub rawJSON2perl {
 107     my ($pkg, $json) = @_;
 108     return undef unless (defined $json and $json =~ /\S/o);
 109     return $parser->decode($json);
 110 }
 111
 112
 113 =head2 rawPerl2JSON
 114
 115 Performs actual data -> JSON transformation, after L</perl2JSONObject>
 116 has been called.
 117
 118 =cut
 119
 120 sub rawPerl2JSON {
 121     # FIXME is there a reason this doesn't return undef with no
 122     # content as rawJSON2perl does?
 123     my ($pkg, $perl) = @_;
 124     return $parser->encode($perl);
 125 }
 126
 127
 128 =head2 JSONObject2Perl
 129
 130 Routine called by L</JSON2perl> after L</rawJSON2perl> is called.
 131
 132 At this stage, the JSON string will have been vivified as data. This
 133 routine's job is to turn it back into an OpenSRF system object of some
 134 sort, if possible.
 135
 136 If it's not possible, the original data (structure), or one very much
 137 like it will be returned.
 138
 139 =cut
 140
 141 sub JSONObject2Perl {
 142     my ($pkg, $obj) = @_;
 143
 144     # if $obj is a hash
 145     if ( ref $obj eq 'HASH' ) {
 146         # and if it has the "I'm a class!" marker
 147         if ( defined $obj->{$JSON_CLASS_KEY} ) {
 148             # vivify the payload
 149             my $vivobj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY});
 150             return undef unless defined $vivobj;
 151
 152             # and bless it back into an object
 153             my $class = $obj->{$JSON_CLASS_KEY};
 154             $class =~ s/^\s+//; # FIXME pretty sure these lines could condense to 's/\s+//g'
 155             $class =~ s/\s+$//;
 156             $class = $pkg->lookup_class($class) if $pkg->lookup_class($class);
 157             return bless(\$vivobj, $class) unless ref $vivobj;
 158             return bless($vivobj, $class);
 159         }
 160
 161         # is a hash, but no class marker; simply revivify innards
 162         for my $k (keys %$obj) {
 163             $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k})
 164               unless JSON::XS::is_bool $obj->{$k};
 165         }
 166     } elsif ( ref $obj eq 'ARRAY' ) {
 167         # not a hash; an array. revivify.
 168         for my $i (0..scalar(@$obj) - 1) {
 169             $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i])
 170               unless JSON::XS::is_bool $obj->[$i];
 171               # FIXME? This does nothing except leave any Booleans in
 172               # place, without recursively calling this sub on
 173               # them. I'm not sure if that's what's supposed to
 174               # happen, or if they're supposed to be thrown out of the
 175               # array
 176         }
 177     }
 178
 179     # return vivified non-class hashes, all arrays, and anything that
 180     # isn't a hash or array ref
 181     return $obj;
 182 }
 183
 184
 185 =head2 perl2JSONObject
 186
 187 Routine called by L</perl2JSON> before L</rawPerl2JSON> is called.
 188
 189 For OpenSRF system objects which have had hints about their classes
 190 stowed via L</register_class_hint>, this routine acts as a wrapper,
 191 encapsulating the incoming object in metadata about itself. It is not
 192 unlike the process of encoding IP datagrams.
 193
 194 The only metadata encoded at the moment is the class hint, which is
 195 used to reinflate the data as an object of the appropriate type in the
 196 L</JSONObject2perl> routine.
 197
 198 Other forms of data more-or-less come out as they went in, although
 199 C<CODE> or C<SCALAR> references will return what looks like an OpenSRF
 200 packet, but with a class hint of their reference type and an C<undef>
 201 payload.
 202
 203 =cut
 204
 205 sub perl2JSONObject {
 206     my ($pkg, $obj) = @_;
 207     my $ref = ref $obj;
 208
 209     return $obj if !$ref or JSON::XS::is_bool $obj;
 210
 211     my $jsonobj;
 212
 213     if(UNIVERSAL::isa($obj, 'HASH')) {
 214         $jsonobj = {};
 215         for my $k (keys %$obj) {
 216             next if (
 217                 $ref ne 'HASH'
 218                 and exists $_class_map{classes}{$ref}{strip}
 219                 and grep { $k eq $_ } @{$_class_map{classes}{$ref}{strip}}
 220             );
 221             $jsonobj->{$k} = $pkg->perl2JSONObject($obj->{$k});
 222         }
 223     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 224         $jsonobj = [];
 225         $jsonobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 226     }
 227
 228     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 229         $ref = $_class_map{classes}{$ref}{hint} || $ref;
 230         $jsonobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $jsonobj};
 231     }
 232
 233     return $jsonobj;
 234 }
 235
 236
 237 =head2 lookup_class
 238
 239 Given a class hint, returns the classname matching it. Returns undef
 240 on failure.
 241
 242 =cut
 243
 244 sub lookup_class {
 245     # FIXME when there are tests, see if these two routines can be
 246     # rewritten as one, or at least made to do lookup in the structure
 247     # they're named after. best case: flatten _class_map, since hints
 248     # and classes are identical
 249     my ($pkg, $hint) = @_;
 250     return undef unless $hint;
 251     return $_class_map{hints}{$hint}{name}
 252 }
 253
 254
 255 =head2 lookup_hint
 256
 257 Given a classname, returns the class hint matching it. Returns undef
 258 on failure.
 259
 260 =cut
 261
 262 sub lookup_hint {
 263     my ($pkg, $class) = @_;
 264     return undef unless $class;
 265     return $_class_map{classes}{$class}{hint}
 266 }
 267
 268 =head2 true
 269
 270 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
 271 its documentation, "are JSON atoms become JSON::XS::true and
 272 JSON::XS::false, respectively. They are overloaded to act almost
 273 exactly like the numbers 1 and 0"
 274
 275 =cut
 276
 277 sub true { return $parser->true }
 278
 279 =head2 false
 280
 281 See L</true>
 282
 283 =cut
 284
 285 sub false { return $parser->false }
 286
 287 1;