more test
[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 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;