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.
  84
  85 =cut
  86
  87 sub perl2JSON {
  88     my( $pkg, $obj ) = @_;
  89     # FIXME no validation of any sort
  90     my $json = $pkg->perl2JSONObject($obj);
  91     return $pkg->rawPerl2JSON($json);
  92 }
  93
  94
  95
  96 =head1 INTERNAL ROUTINES
  97
  98 =head2 rawJSON2perl
  99
 100 Performs actual JSON -> data transformation, before
 101 L</JSONObject2Perl> is called.
 102
 103 =cut
 104
 105 sub rawJSON2perl {
 106     my ($pkg, $json) = @_;
 107     return undef unless (defined $json and $json =~ /\S/o);
 108     return $parser->decode($json);
 109 }
 110
 111
 112 =head2 rawPerl2JSON
 113
 114 Performs actual data -> JSON transformation, after L</perl2JSONObject>
 115 has been called.
 116
 117 =cut
 118
 119 sub rawPerl2JSON {
 120     # FIXME is there a reason this doesn't return undef with no
 121     # content as rawJSON2perl does?
 122     my ($pkg, $perl) = @_;
 123     return $parser->encode($perl);
 124 }
 125
 126
 127 =head2 JSONObject2Perl
 128
 129 Routine called by L</JSON2perl> after L</rawJSON2perl> is called.
 130
 131 At this stage, the JSON string will have been vivified as data. This
 132 routine's job is to turn it back into an OpenSRF system object of some
 133 sort, if possible.
 134
 135 If it's not possible, the original data (structure), or one very much
 136 like it will be returned.
 137
 138 =cut
 139
 140 sub JSONObject2Perl {
 141     my ($pkg, $obj) = @_;
 142
 143     # if $obj is a hash
 144     if ( ref $obj eq 'HASH' ) {
 145         # and if it has the "I'm a class!" marker
 146         if ( defined $obj->{$JSON_CLASS_KEY} ) {
 147             # vivify the payload
 148             my $vivobj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY});
 149             return undef unless defined $vivobj;
 150
 151             # and bless it back into an object
 152             my $class = $obj->{$JSON_CLASS_KEY};
 153             $class =~ s/^\s+//; # FIXME pretty sure these lines could condense to 's/\s+//g'
 154             $class =~ s/\s+$//;
 155             $class = $pkg->lookup_class($class) if $pkg->lookup_class($class);
 156             return bless(\$vivobj, $class) unless ref $vivobj;
 157             return bless($vivobj, $class);
 158         }
 159
 160         # is a hash, but no class marker; simply revivify innards
 161         for my $k (keys %$obj) {
 162             $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k})
 163               unless JSON::XS::is_bool $obj->{$k};
 164         }
 165     } elsif ( ref $obj eq 'ARRAY' ) {
 166         # not a hash; an array. revivify.
 167         for my $i (0..scalar(@$obj) - 1) {
 168             $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i])
 169               unless JSON::XS::is_bool $obj->[$i];
 170               # FIXME? This does nothing except leave any Booleans in
 171               # place, without recursively calling this sub on
 172               # them. I'm not sure if that's what's supposed to
 173               # happen, or if they're supposed to be thrown out of the
 174               # array
 175         }
 176     }
 177
 178     # return vivified non-class hashes, all arrays, and anything that
 179     # isn't a hash or array ref
 180     return $obj;
 181 }
 182
 183
 184 =head2 perl2JSONObject
 185
 186 Routine called by L</perl2JSON> before L</rawPerl2JSON> is called.
 187
 188 For OpenSRF system objects which have had hints about their classes
 189 stowed via L</register_class_hint>, this routine acts as a wrapper,
 190 encapsulating the incoming object in metadata about itself. It is not
 191 unlike the process of encoding IP datagrams.
 192
 193 The only metadata encoded at the moment is the class hint, which is
 194 used to reinflate the data as an object of the appropriate type in the
 195 L</JSONObject2perl> routine.
 196
 197 Other forms of data more-or-less come out as they went in, although
 198 C<CODE> or C<SCALAR> references will return what looks like an OpenSRF
 199 packet, but with a class hint of their reference type and an C<undef>
 200 payload.
 201
 202 =cut
 203
 204 sub perl2JSONObject {
 205     my ($pkg, $obj) = @_;
 206     my $ref = ref $obj;
 207
 208     return $obj if !$ref or JSON::XS::is_bool $obj;
 209
 210     my $jsonobj;
 211
 212     if(UNIVERSAL::isa($obj, 'HASH')) {
 213         $jsonobj = {};
 214         $jsonobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
 215     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 216         $jsonobj = [];
 217         $jsonobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 218     }
 219
 220     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 221         $ref = $_class_map{classes}{$ref}{hint} || $ref;
 222         $jsonobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $jsonobj};
 223     }
 224
 225     return $jsonobj;
 226 }
 227
 228
 229 =head2 lookup_class
 230
 231 Given a class hint, returns the classname matching it. Returns undef
 232 on failure.
 233
 234 =cut
 235
 236 sub lookup_class {
 237     # FIXME when there are tests, see if these two routines can be
 238     # rewritten as one, or at least made to do lookup in the structure
 239     # they're named after. best case: flatten _class_map, since hints
 240     # and classes are identical
 241     my ($pkg, $hint) = @_;
 242     return undef unless $hint;
 243     return $_class_map{hints}{$hint}{name}
 244 }
 245
 246
 247 =head2 lookup_hint
 248
 249 Given a classname, returns the class hint matching it. Returns undef
 250 on failure.
 251
 252 =cut
 253
 254 sub lookup_hint {
 255     my ($pkg, $class) = @_;
 256     return undef unless $class;
 257     return $_class_map{classes}{$class}{hint}
 258 }
 259
 260 =head2 true
 261
 262 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
 263 its documentation, "are JSON atoms become JSON::XS::true and
 264 JSON::XS::false, respectively. They are overloaded to act almost
 265 exactly like the numbers 1 and 0"
 266
 267 =cut
 268
 269 sub true { return $parser->true }
 270
 271 =head2 false
 272
 273 See L</true>
 274
 275 =cut
 276
 277 sub false { return $parser->false }
 278
 279 1;