File Coverage

File:blib/lib/OpenSRF/Utils/JSON.pm
Coverage:100.0%

linestmtbrancondsubpodtimecode
1package OpenSRF::Utils::JSON;
2
3
10
10
10
10
56
42
75
use warnings;
4
10
10
10
10
68
35
63
use strict;
5
10
10
10
10
94
45
108
use JSON::XS;
6
7our $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
11our %_class_map = ();
12our $JSON_CLASS_KEY = '__c'; # points to the classname of encoded objects
13our $JSON_PAYLOAD_KEY = '__p'; # same, for payload
14
15
16
17 - 50
=head1 NAME

OpenSRF::Utils::JSON - Serialize/Vivify objects

=head1 SYNOPSIS

C<O::U::JSON> is a functional-style package which exports nothing. All
calls to routines must use the fully-qualified name, and expect an
invocant, as in

    OpenSRF::Utils::JSON->JSON2perl($string);

The routines which are called by existing external code all deal with
the serialization/stringification of objects and their revivification.



=head1 ROUTINES

=head2 register_class_hint

This routine is used by objects which wish to serialize themselves
with the L</perl2JSON> routine. It has two required arguments, C<name>
and C<hint>.

    O::U::J->register_class_hint( hint => 'osrfException',
                                  name => 'OpenSRF::DomainObject::oilsException');

Where C<hint> can be any unique string (but canonically is the name
from the IDL which matches the object being operated on), and C<name>
is the language-specific classname which objects will be revivified
as.

=cut
51
52sub 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
218
218
1
1311
    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
218
1194
    $_class_map{hints}{$args{hint}} = \%args;
61
218
1283
    $_class_map{classes}{$args{name}} = \%args;
62}
63
64
65 - 70
=head2 JSON2perl

Given a JSON-encoded string, returns a vivified Perl object built from
that string.

=cut
71
72sub JSON2perl {
73    # FIXME $string is not checked for any criteria, even existance
74
1
1
1
16
    my( $pkg, $string ) = @_;
75
1
7
    my $perl = $pkg->rawJSON2perl($string);
76
1
5
    return $pkg->JSONObject2Perl($perl);
77}
78
79
80 - 85
=head2 perl2JSON

Given a Perl object, returns a JSON stringified representation of that
object.

=cut
86
87sub perl2JSON {
88
1
1
1
15
    my( $pkg, $obj ) = @_;
89    # FIXME no validation of any sort
90
1
6
    my $json = $pkg->perl2JSONObject($obj);
91
1
6
    return $pkg->rawPerl2JSON($json);
92}
93
94
95
96 - 103
=head1 INTERNAL ROUTINES

=head2 rawJSON2perl

Performs actual JSON -> data transformation, before
L</JSONObject2Perl> is called.

=cut
104
105sub rawJSON2perl {
106
4
4
1
20
    my ($pkg, $json) = @_;
107
4
100
100
42
    return undef unless (defined $json and $json =~ /\S/o);
108
2
58
    return $parser->decode($json);
109}
110
111
112 - 117
=head2 rawPerl2JSON

Performs actual data -> JSON transformation, after L</perl2JSONObject>
has been called.

=cut
118
119sub rawPerl2JSON {
120    # FIXME is there a reason this doesn't return undef with no
121    # content as rawJSON2perl does?
122
4
4
1
20
    my ($pkg, $perl) = @_;
123
4
70
    return $parser->encode($perl);
124}
125
126
127 - 138
=head2 JSONObject2Perl

Routine called by L</JSON2perl> after L</rawJSON2perl> is called.

At this stage, the JSON string will have been vivified as data. This
routine's job is to turn it back into an OpenSRF system object of some
sort, if possible.

If it's not possible, the original data (structure), or one very much
like it will be returned.

=cut
139
140sub JSONObject2Perl {
141
24
24
1
128
    my ($pkg, $obj) = @_;
142
143    # if $obj is a hash
144
24
100
100
124
    if ( ref $obj eq 'HASH' ) {
145        # and if it has the "I'm a class!" marker
146
8
100
40
        if ( defined $obj->{$JSON_CLASS_KEY} ) {
147            # vivify the payload
148
4
24
            my $vivobj = $pkg->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY});
149
4
100
20
            return undef unless defined $vivobj;
150
151            # and bless it back into an object
152
3
14
            my $class = $obj->{$JSON_CLASS_KEY};
153
3
15
            $class =~ s/^\s+//; # FIXME pretty sure these lines could condense to 's/\s+//g'
154
3
13
            $class =~ s/\s+$//;
155
3
100
23
            $class = $pkg->lookup_class($class) if $pkg->lookup_class($class);
156
3
100
34
            return bless(\$vivobj, $class) unless ref $vivobj;
157
2
16
            return bless($vivobj, $class);
158        }
159
160        # is a hash, but no class marker; simply revivify innards
161
4
20
        for my $k (keys %$obj) {
162
5
100
41
            $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
2
12
        for my $i (0..scalar(@$obj) - 1) {
168
5
100
36
            $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
20
129
    return $obj;
181}
182
183
184 - 202
=head2 perl2JSONObject

Routine called by L</perl2JSON> before L</rawPerl2JSON> is called.

For OpenSRF system objects which have had hints about their classes
stowed via L</register_class_hint>, this routine acts as a wrapper,
encapsulating the incoming object in metadata about itself. It is not
unlike the process of encoding IP datagrams.

The only metadata encoded at the moment is the class hint, which is
used to reinflate the data as an object of the appropriate type in the
L</JSONObject2perl> routine.

Other forms of data more-or-less come out as they went in, although
C<CODE> or C<SCALAR> references will return what looks like an OpenSRF
packet, but with a class hint of their reference type and an C<undef>
payload.

=cut
203
204sub perl2JSONObject {
205
15
15
1
86
    my ($pkg, $obj) = @_;
206
15
60
    my $ref = ref $obj;
207
208
15
100
81
    return $obj unless $ref;
209
7
100
36
    return $obj if $ref eq 'JSON::XS::Boolean';
210
211
6
19
    my $jsonobj;
212
213
6
100
100
40
    if(UNIVERSAL::isa($obj, 'HASH')) {
214
3
12
        $jsonobj = {};
215
3
3
9
27
        $jsonobj->{$_} = $pkg->perl2JSONObject($obj->{$_}) for (keys %$obj);
216    } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
217
1
4
        $jsonobj = [];
218
1
1
4
12
        $jsonobj->[$_] = $pkg->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
219    }
220
221
6
100
100
56
    if($ref ne 'HASH' and $ref ne 'ARRAY') {
222
4
100
19
        $ref = $pkg->lookup_hint($ref) if $pkg->lookup_hint($ref);
223
4
27
        $jsonobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $jsonobj};
224    }
225
226
6
35
    return $jsonobj;
227}
228
229
230 - 235
=head2 lookup_class

Given a class hint, returns the classname matching it. Returns undef
on failure.

=cut
236
237sub 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
9
9
1
41
    my ($pkg, $hint) = @_;
243
9
100
42
    return undef unless $hint;
244
7
56
    return $_class_map{hints}{$hint}{name}
245}
246
247
248 - 253
=head2 lookup_hint

Given a classname, returns the class hint matching it. Returns undef
on failure.

=cut
254
255sub lookup_hint {
256
10
10
1
47
    my ($pkg, $class) = @_;
257
10
100
44
    return undef unless $class;
258
8
59
    return $_class_map{classes}{$class}{hint}
259}
260
261 - 268
=head2 true

Wrapper for JSON::XS::true. J::X::true and J::X::false, according to
its documentation, "are JSON atoms become JSON::XS::true and
JSON::XS::false, respectively. They are overloaded to act almost
exactly like the numbers 1 and 0"

=cut
269
270
8
8
1
56
sub true { return $parser->true }
271
272 - 276
=head2 false

See L</true>

=cut
277
278
1
1
1
6
sub false { return $parser->false }
279
2801;