shuffling around, adding POD stubs
[OpenSRF.git] / src / perl / lib / OpenSRF / Utils / JSON.pm
1 package OpenSRF::Utils::JSON;
2 use JSON::XS;
3
4 my $parser = JSON::XS->new;
5 $parser->ascii(1);        # output \u escaped strings for any char with a value over 127
6 $parser->allow_nonref(1); # allows non-reference values to equate to themselves (see perldoc)
7
8 my %_class_map = ();
9 my $JSON_CLASS_KEY = '__c';
10 my $JSON_PAYLOAD_KEY = '__p';
11
12
13 =head1 NAME
14
15 OpenSRF::Utils::JSON - Bucket-o-Routines for JSON
16
17 =head1 SYNOPSIS
18
19 C<O::U::JSON> is a functional-style package which exports nothing. All
20 calls to routines must use the fully-qualified name, and expect an
21 invocant, as in
22
23     OpenSRF::Utils::JSON->JSON2perl($string);
24
25 Most routines are straightforward data<->JSON transformation wrappers
26 around L<JSON::XS>, but some (like L</register_class_hint>) provide
27 OpenSRF functionality.
28
29 =head1 ROUTINES
30
31 =head2 register_class_hint
32
33 =cut
34
35 sub register_class_hint {
36     my $class = shift;
37     my %args = @_;
38     $_class_map{hints}{$args{hint}} = \%args;
39     $_class_map{classes}{$args{name}} = \%args;
40 }
41
42 =head2 lookup_class
43
44 =cut
45
46 sub lookup_class {
47     my $self = shift;
48     my $hint = shift;
49     return $_class_map{hints}{$hint}{name}
50 }
51
52 =head2 lookup_hint
53
54 =cut
55
56 sub lookup_hint {
57     my $self = shift;
58     my $class = shift;
59     return $_class_map{classes}{$class}{hint}
60 }
61
62 =head2 JSON2perl
63
64 =cut
65
66 sub JSON2perl {
67     my( $class, $string ) = @_;
68     my $perl = $class->rawJSON2perl($string);
69     return $class->JSONObject2Perl($perl);
70 }
71
72 =head2 perl2JSON
73
74 =cut
75
76 sub perl2JSON {
77     my( $class, $obj ) = @_;
78     my $json = $class->perl2JSONObject($obj);
79     return $class->rawPerl2JSON($json);
80 }
81
82 =head2 rawJSON2perl
83
84 =cut
85
86 sub rawJSON2perl {
87     my $class = shift;
88     my $json = shift;
89     return undef unless defined $json and $json !~ /^\s*$/o;
90     return $parser->decode($json);
91 }
92
93 =head2 rawPerl2JSON
94
95 =cut
96
97 sub rawPerl2JSON {
98     my ($class, $perl) = @_;
99     return $parser->encode($perl);
100 }
101
102 =head2 JSONObject2Perl
103
104 =cut
105
106 sub JSONObject2Perl {
107     my $class = shift;
108     my $obj = shift;
109     my $ref = ref($obj);
110     if( $ref eq 'HASH' ) {
111         if( defined($obj->{$JSON_CLASS_KEY})) {
112             my $cls = $obj->{$JSON_CLASS_KEY};
113             $cls =~ s/^\s+//o;
114             $cls =~ s/\s+$//o;
115             if( $obj = $class->JSONObject2Perl($obj->{$JSON_PAYLOAD_KEY}) ) {
116                 $cls = $class->lookup_class($cls) || $cls;
117                 return bless(\$obj, $cls) unless ref($obj);
118                 return bless($obj, $cls);
119             }
120             return undef;
121         }
122         for my $k (keys %$obj) {
123             $obj->{$k} = $class->JSONObject2Perl($obj->{$k})
124               unless ref($obj->{$k}) eq 'JSON::XS::Boolean';
125         }
126     } elsif( $ref eq 'ARRAY' ) {
127         for my $i (0..scalar(@$obj) - 1) {
128             $obj->[$i] = $class->JSONObject2Perl($obj->[$i])
129               unless ref($obj->[$i]) eq 'JSON::XS::Boolean';
130         }
131     }
132     return $obj;
133 }
134
135 =head2 perl2JSONObject
136
137 =cut
138
139 sub perl2JSONObject {
140     my $class = shift;
141     my $obj = shift;
142     my $ref = ref($obj);
143
144     return $obj unless $ref;
145
146     return $obj if $ref eq 'JSON::XS::Boolean';
147     my $newobj;
148
149     if(UNIVERSAL::isa($obj, 'HASH')) {
150         $newobj = {};
151         $newobj->{$_} = $class->perl2JSONObject($obj->{$_}) for (keys %$obj);
152     } elsif(UNIVERSAL::isa($obj, 'ARRAY')) {
153         $newobj = [];
154         $newobj->[$_] = $class->perl2JSONObject($obj->[$_]) for(0..scalar(@$obj) - 1);
155     }
156
157     if($ref ne 'HASH' and $ref ne 'ARRAY') {
158         $ref = $class->lookup_hint($ref) || $ref;
159         $newobj = {$JSON_CLASS_KEY => $ref, $JSON_PAYLOAD_KEY => $newobj};
160     }
161
162     return $newobj;
163 }
164
165 =head2 true
166
167 =cut
168
169 sub true {
170     return $parser->true();
171 }
172
173 =head2 false
174
175 =cut
176
177 sub false {
178     return $parser->false();
179 }
180
181 sub _json_hint_to_class {
182     my $type = shift;
183     my $hint = shift;
184
185     return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
186
187     $type = 'hash' if ($type eq '}');
188     $type = 'array' if ($type eq ']');
189
190         OpenSRF::Utils::JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
191
192     return $hint;
193 }
194
195 1;