POD/docs cleanup
[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.
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 ref $obj->{$k} eq 'JSON::XS::Boolean';
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 (ref $obj->[$i] eq 'JSON::XS::Boolean');
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 unless $ref;
209     return $obj if $ref eq 'JSON::XS::Boolean';
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 = $pkg->lookup_hint($ref) if $pkg->lookup_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;