641187085df2e85dc061174e5f247887ea841742
[OpenSRF.git] / 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         $jsonobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
216     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
217         $jsonobj = [];
218         $jsonobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
219     }
220
221     if($ref ne 'HASH' and $ref ne 'ARRAY') {
222         $ref = $_class_map{classes}{$ref}{hint} || $ref;
223         $jsonobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $jsonobj};
224     }
225
226     return $jsonobj;
227 }
228
229
230 =head2 lookup_class
231
232 Given a class hint, returns the classname matching it. Returns undef
233 on failure.
234
235 =cut
236
237 sub lookup_class {
238     # FIXME when there are tests, see if these two routines can be
239     # rewritten as one, or at least made to do lookup in the structure
240     # they're named after. best case: flatten _class_map, since hints
241     # and classes are identical
242     my ($pkg, $hint) = @_;
243     return undef unless $hint;
244     return $_class_map{hints}{$hint}{name}
245 }
246
247
248 =head2 lookup_hint
249
250 Given a classname, returns the class hint matching it. Returns undef
251 on failure.
252
253 =cut
254
255 sub lookup_hint {
256     my ($pkg, $class) = @_;
257     return undef unless $class;
258     return $_class_map{classes}{$class}{hint}
259 }
260
261 =head2 true
262
263 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
264 its documentation, "are JSON atoms become JSON::XS::true and
265 JSON::XS::false, respectively. They are overloaded to act almost
266 exactly like the numbers 1 and 0"
267
268 =cut
269
270 sub true { return $parser->true }
271
272 =head2 false
273
274 See L</true>
275
276 =cut
277
278 sub false { return $parser->false }
279
280 1;