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     my ($pkg, %args) = @_;
  56     # FIXME why is the same thing shoved into two places? One mapping
  57     # would suffice if class and hint were always returned together...
  58     $_class_map{hints}{$args{hint}} = \%args;
  59     $_class_map{classes}{$args{name}} = \%args;
  60 }
  61
  62
  63 =head2 JSON2perl
  64
  65 Given a JSON-encoded string, returns a vivified Perl object built from
  66 that string.
  67
  68 =cut
  69
  70 sub JSON2perl {
  71     # FIXME $string is not checked for any criteria, even existance
  72     my( $pkg, $string ) = @_;
  73     my $perl = $pkg->rawJSON2perl($string);
  74     return $pkg->JSONObject2Perl($perl);
  75 }
  76
  77
  78 =head2 perl2JSON
  79
  80 Given a Perl object, returns a JSON stringified representation of that
  81 object.
  82
  83 =cut
  84
  85 sub perl2JSON {
  86     my( $pkg, $obj ) = @_;
  87     # FIXME no validation of any sort
  88     my $json = $pkg->perl2JSONObject($obj);
  89     return $pkg->rawPerl2JSON($json);
  90 }
  91
  92
  93
  94 =head1 INTERNAL ROUTINES
  95
  96 =head2 rawJSON2perl
  97
  98 Intermediate routine called by L</JSON2Perl>.
  99
 100 =cut
 101
 102 sub rawJSON2perl {
 103     my ($pkg, $json) = @_;
 104     # FIXME change regex conditional to '=~ /\S/'
 105     return undef unless (defined $json and $json !~ /^\s*$/o);
 106     return $parser->decode($json);
 107 }
 108
 109
 110 =head2 JSONObject2Perl
 111
 112 Final routine in the object re-vivification chain, called by L</rawJSON2perl>.
 113
 114 =cut
 115
 116 sub JSONObject2Perl {
 117     my ($pkg, $obj) = @_;
 118
 119     # if $obj is a hash
 120     if ( ref $obj eq 'HASH' ) {
 121         # and if it has the "I'm a class!" marker
 122         if ( defined $obj->{$JSON_CLASS_KEY} ) {
 123             # vivify the payload
 124             my $vivobj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY});
 125             return undef unless defined $vivobj;
 126
 127             # and bless it back into an object
 128             my $class = $obj->{$JSON_CLASS_KEY};
 129             $class =~ s/^\s+//; # FIXME pretty sure these lines could condense to 's/\s+//g'
 130             $class =~ s/\s+$//;
 131             $class = $pkg->lookup_class($class) || $class;
 132             return bless(\$vivobj, $class) unless ref $vivobj;
 133             return bless($vivobj, $class);
 134         }
 135
 136         # is a hash, but no class marker; simply revivify innards
 137         for my $k (keys %$obj) {
 138             $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k})
 139               unless ref $obj->{$k} eq 'JSON::XS::Boolean';
 140         }
 141     } elsif ( ref $obj eq 'ARRAY' ) {
 142         # not a hash; an array. revivify.
 143         for my $i (0..scalar(@$obj) - 1) {
 144             $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i])
 145               unless ref $obj->[$i] eq 'JSON::XS::Boolean';
 146         }
 147     }
 148
 149     # return vivified non-class hashes, all arrays, and anything that
 150     # isn't a hash or array ref
 151     return $obj;
 152 }
 153
 154
 155 =head2 rawPerl2JSON
 156
 157 Intermediate routine used by L</Perl2JSON>.
 158
 159 =cut
 160
 161 sub rawPerl2JSON {
 162     # FIXME no validation of any sort
 163     my ($pkg, $perl) = @_;
 164     return $parser->encode($perl);
 165 }
 166
 167
 168 =head2 perl2JSONObject
 169
 170 =cut
 171
 172 sub perl2JSONObject {
 173     my ($pkg, $obj) = @_;
 174     my $ref = ref $obj;
 175
 176     return $obj unless $ref;
 177
 178     return $obj if $ref eq 'JSON::XS::Boolean';
 179     my $newobj;
 180
 181     if(UNIVERSAL::isa($obj, 'HASH')) {
 182         $newobj = {};
 183         $newobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
 184     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 185         $newobj = [];
 186         $newobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 187     }
 188
 189     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 190         $ref = $pkg->lookup_hint($ref) || $ref;
 191         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
 192     }
 193
 194     return $newobj;
 195 }
 196
 197
 198 =head2 lookup_class
 199
 200 =cut
 201
 202 sub lookup_class {
 203     # FIXME when there are tests, see if these two routines can be
 204     # rewritten as one, or at least made to do lookup in the structure
 205     # they're named after. best case: flatten _class_map, since hints
 206     # and classes are identical
 207     my ($pkg, $hint) = @_;
 208     return $_class_map{hints}{$hint}{name}
 209 }
 210
 211
 212 =head2 lookup_hint
 213
 214 =cut
 215
 216 sub lookup_hint {
 217     my ($pkg, $class) = @_;
 218     return $_class_map{classes}{$class}{hint}
 219 }
 220
 221 =head2 true
 222
 223 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
 224 its documentation, "are JSON atoms become JSON::XS::true and
 225 JSON::XS::false, respectively. They are overloaded to act almost
 226 exactly like the numbers 1 and 0"
 227
 228 =cut
 229
 230 sub true { return $parser->true }
 231
 232 =head2 false
 233
 234 See L</true>
 235
 236 =cut
 237
 238 sub false { return $parser->false }
 239
 240 1;