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 =head1 NAME
17
18 OpenSRF::Utils::JSON - Serialize/Vivify objects
19
20 =head1 SYNOPSIS
21
22 C<O::U::JSON> is a functional-style package which exports nothing. All
23 calls to routines must use the fully-qualified name, and expect an
24 invocant, as in
25
26     OpenSRF::Utils::JSON->JSON2perl($string);
27
28 The routines which are called by existing external code all deal with
29 the serialization/stringification of objects and their revivification.
30
31 =head1 ROUTINES
32
33 =head2 register_class_hint
34
35 This routine is used by objects which wish to serialize themselves
36 with the L</perl2JSON> routine. It has two required arguments, C<name>
37 and C<hint>.
38
39     OpenSRF::Util::JSON->register_class_hint( hint => 'osrfException',
40                                               name => 'OpenSRF::DomainObject::oilsException');
41
42 Where C<hint> can be any unique string (but canonically is the name
43 from the IDL which matches the object being operated on), and C<name>
44 is the language-specific classname which objects will be revivified
45 as.
46
47 =cut
48
49 sub register_class_hint {
50     # FIXME hint can't be a dupe
51     # FIXME fail unless we have hint and name
52     my ($pkg, %args) = @_;
53     $_class_map{hints}{$args{hint}} = \%args;
54     $_class_map{classes}{$args{name}} = \%args;
55 }
56
57
58 =head2 JSON2perl
59
60 =cut
61
62 sub JSON2perl {
63     my( $pkg, $string ) = @_;
64     my $perl = $pkg->rawJSON2perl($string);
65     return $pkg->JSONObject2Perl($perl);
66 }
67
68
69 =head2 perl2JSON
70
71 =cut
72
73 sub perl2JSON {
74     my( $pkg, $obj ) = @_;
75     my $json = $pkg->perl2JSONObject($obj);
76     return $pkg->rawPerl2JSON($json);
77 }
78
79
80 =head2 JSONObject2Perl
81
82 =cut
83
84 sub JSONObject2Perl {
85     my ($pkg, $obj) = @_;
86     my $ref = ref $obj;
87     if( $ref eq 'HASH' ) {
88         if( defined($obj->{$JSON_CLASS_KEY})) {
89             my $class = $obj->{$JSON_CLASS_KEY};
90             $class =~ s/^\s+//o;
91             $class =~ s/\s+$//o;
92             if( $obj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
93                 $class = $pkg->lookup_class($class) || $class;
94                 return bless(\$obj, $class) unless ref($obj);
95                 return bless($obj, $class);
96             }
97             return undef;
98         }
99         for my $k (keys %$obj) {
100             $obj->{$k} = $pkg->JSONObject2Perl($obj->{$k})
101               unless ref($obj->{$k}) eq 'JSON::XS::Boolean';
102         }
103     } elsif( $ref eq 'ARRAY' ) {
104         for my $i (0..scalar(@$obj) - 1) {
105             $obj->[$i] = $pkg->JSONObject2Perl($obj->[$i])
106               unless ref($obj->[$i]) eq 'JSON::XS::Boolean';
107         }
108     }
109     return $obj;
110 }
111
112
113 =head2 perl2JSONObject
114
115 =cut
116
117 sub perl2JSONObject {
118     my ($pkg, $obj) = @_;
119     my $ref = ref($obj);
120
121     return $obj unless $ref;
122
123     return $obj if $ref eq 'JSON::XS::Boolean';
124     my $newobj;
125
126     if(UNIVERSAL::isa($obj, 'HASH')) {
127         $newobj = {};
128         $newobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
129     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
130         $newobj = [];
131         $newobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
132     }
133
134     if($ref ne 'HASH' and $ref ne 'ARRAY') {
135         $ref = $pkg->lookup_hint($ref) || $ref;
136         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
137     }
138
139     return $newobj;
140 }
141
142
143 =head2 rawJSON2perl
144
145 Internal routine used by L</JSON2Perl>. Wrapper around
146 L<JSON::XS::decode>.
147
148 =cut
149
150 sub rawJSON2perl {
151     my ($pkg, $json) = @_;
152     return undef unless defined $json and $json !~ /^\s*$/o;
153     return $parser->decode($json);
154 }
155
156
157 =head2 rawPerl2JSON
158
159 Internal routine used by L</Perl2JSON>. Wrapper around
160 L<JSON::XS::encode>.
161
162 =cut
163
164 sub rawPerl2JSON {
165     my ($pkg, $perl) = @_;
166     return $parser->encode($perl);
167 }
168
169
170 =head2 lookup_class
171
172 =cut
173
174 sub lookup_class {
175     # FIXME when there are tests, see if these two routines can be
176     # rewritten as one, or at least made to do lookup in the structure
177     # they're named after. best case: flatten _class_map, since hints
178     # and classes are identical
179     my ($pkg, $hint) = @_;
180     return $_class_map{hints}{$hint}{name}
181 }
182
183
184 =head2 lookup_hint
185
186 =cut
187
188 sub lookup_hint {
189     my ($pkg, $class) = @_;
190     return $_class_map{classes}{$class}{hint}
191 }
192
193 =head2 true
194
195 Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
196 its documentation, "are JSON atoms become JSON::XS::true and
197 JSON::XS::false, respectively. They are overloaded to act almost
198 exactly like the numbers 1 and 0"
199
200 =cut
201
202 sub true { return $parser->true }
203
204 =head2 false
205
206 See L</true>
207
208 =cut
209
210 sub false { return $parser->false }
211
212 1;