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 Final routine in the object re-vivification chain, 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         }
 162     }
 163
 164     # return vivified non-class hashes, all arrays, and anything that
 165     # isn't a hash or array ref
 166     return $obj;
 167 }
 168
 169
 170 =head2 perl2JSONObject
 171
 172 =cut
 173
 174 sub perl2JSONObject {
 175     my ($pkg, $obj) = @_;
 176     my $ref = ref $obj;
 177
 178     return $obj unless $ref;
 179
 180     return $obj if $ref eq 'JSON::XS::Boolean';
 181     my $newobj;
 182
 183     if(UNIVERSAL::isa($obj, 'HASH')) {
 184         $newobj = {};
 185         $newobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
 186     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
 187         $newobj = [];
 188         $newobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
 189     }
 190
 191     if($ref ne 'HASH' and $ref ne 'ARRAY') {
 192         $ref = $pkg->lookup_hint($ref) || $ref;
 193         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
 194     }
 195
 196     return $newobj;
 197 }
 198
 199
 200 =head2 lookup_class
 201
 202 =cut
 203
 204 sub lookup_class {
 205     # FIXME when there are tests, see if these two routines can be
 206     # rewritten as one, or at least made to do lookup in the structure
 207     # they're named after. best case: flatten _class_map, since hints
 208     # and classes are identical
 209     my ($pkg, $hint) = @_;
 210     return undef unless $hint;
 211     return $_class_map{hints}{$hint}{name}
 212 }
 213
 214
 215 =head2 lookup_hint
 216
 217 =cut
 218
 219 sub lookup_hint {
 220     my ($pkg, $class) = @_;
 221     return undef unless $class;
 222     return $_class_map{classes}{$class}{hint}
 223 }
 224
 225 =head2 true
 226
 227 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
 228 its documentation, "are JSON atoms become JSON::XS::true and
 229 JSON::XS::false, respectively. They are overloaded to act almost
 230 exactly like the numbers 1 and 0"
 231
 232 =cut
 233
 234 sub true { return $parser->true }
 235
 236 =head2 false
 237
 238 See L</true>
 239
 240 =cut
 241
 242 sub false { return $parser->false }
 243
 244 1;