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 Intermediate routine called by L</JSON2Perl>.
 101
 102 =cut
 103
 104 sub rawJSON2perl {
 105     my ($pkg, $json) = @_;
 106     return undef unless (defined $json and $json =~ /\S/o);
 107     return $parser->decode($json);
 108 }
 109
 110
 111 =head2 rawPerl2JSON
 112
 113 Intermediate routine used by L</Perl2JSON>.
 114
 115 =cut
 116
 117 sub rawPerl2JSON {
 118     # FIXME is there a reason this doesn't return undef with no
 119     # content as rawJSON2perl does?
 120     my ($pkg, $perl) = @_;
 121     return $parser->encode($perl);
 122 }
 123
 124
 125 =head2 JSONObject2Perl
 126
 127 Intermediate routine called by L</rawJSON2perl>.
 128
 129 =cut
 130
 131 sub JSONObject2Perl {
 132     my ($pkg, $obj) = @_;
 133
 134     # if $obj is a hash
 135     if ( ref $obj eq 'HASH' ) {
 136         # and if it has the "I'm a class!" marker
 137         if ( defined $obj->{$JSON_CLASS_KEY} ) {
 138             # vivify the payload
 139             my $vivobj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY});
 140             return undef unless defined $vivobj;
 141
 142             # and bless it back into an object
 143             my $class = $obj->{$JSON_CLASS_KEY};
 144             $class =~ s/^\s+//; # FIXME pretty sure these lines could condense to 's/\s+//g'
 145             $class =~ s/\s+$//;
 146             $class = $pkg->lookup_class($class) || $class;
 147             return bless(\$vivobj, $class) unless ref $vivobj;
 148             return bless($vivobj, $class);
 149         }
 150
 151         # is a hash, but no class marker; simply revivify innards
 152         for my $k (keys %$obj) {
 153             $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k})
 154               unless ref $obj->{$k} eq 'JSON::XS::Boolean';
 155         }
 156     } elsif ( ref $obj eq 'ARRAY' ) {
 157         # not a hash; an array. revivify.
 158         for my $i (0..scalar(@$obj) - 1) {
 159             $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i])
 160               unless (ref $obj->[$i] eq 'JSON::XS::Boolean');
 161               # FIXME? This does nothing except leave any Booleans in
 162               # place, without recursively calling this sub on
 163               # them. I'm not sure if that's what's supposed to
 164               # happen, or if they're supposed to be thrown out of the
 165               # array
 166         }
 167     }
 168
 169     # return vivified non-class hashes, all arrays, and anything that
 170     # isn't a hash or array ref
 171     return $obj;
 172 }
 173
 174
 175 =head2 perl2JSONObject
 176
 177 =cut
 178
 179 sub perl2JSONObject {
 180     my ($pkg, $obj) = @_;
 181     my $ref = ref $obj;
 182
 183     return $obj unless $ref;
 184     return $obj if $ref eq 'JSON::XS::Boolean';
 185
 186     my $jsonobj;
 187
 188     if(UNIVERSAL::isa($obj, 'HASH')) {
 189         $jsonobj = {};
 190         $jsonobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
 191     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 192         $jsonobj = [];
 193         $jsonobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 194     }
 195
 196     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 197         $ref = $pkg->lookup_hint($ref) if $pkg->lookup_hint($ref);
 198         $jsonobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $jsonobj};
 199     }
 200
 201     return $jsonobj;
 202 }
 203
 204
 205 =head2 lookup_class
 206
 207 =cut
 208
 209 sub lookup_class {
 210     # FIXME when there are tests, see if these two routines can be
 211     # rewritten as one, or at least made to do lookup in the structure
 212     # they're named after. best case: flatten _class_map, since hints
 213     # and classes are identical
 214     my ($pkg, $hint) = @_;
 215     return undef unless $hint;
 216     return $_class_map{hints}{$hint}{name}
 217 }
 218
 219
 220 =head2 lookup_hint
 221
 222 =cut
 223
 224 sub lookup_hint {
 225     my ($pkg, $class) = @_;
 226     return undef unless $class;
 227     return $_class_map{classes}{$class}{hint}
 228 }
 229
 230 =head2 true
 231
 232 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
 233 its documentation, "are JSON atoms become JSON::XS::true and
 234 JSON::XS::false, respectively. They are overloaded to act almost
 235 exactly like the numbers 1 and 0"
 236
 237 =cut
 238
 239 sub true { return $parser->true }
 240
 241 =head2 false
 242
 243 See L</true>
 244
 245 =cut
 246
 247 sub false { return $parser->false }
 248
 249 1;