WIP
[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 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;