added lookup_class and lookup_hint methods to support param class instance checking
[Evergreen.git] / OpenSRF / src / perlmods / JSON.pm
1
2 package JSON::number;
3 sub new {
4         my $class = shift;
5         my $x = shift || $class;
6         return bless \$x => __PACKAGE__;
7 }
8
9 use overload ( '""' => \&toString );
10
11 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
12
13 package JSON::bool::true;
14 sub new { return bless {} => __PACKAGE__ }
15 use overload ( '""' => \&toString );
16 use overload ( 'bool' => sub { 1 } );
17 use overload ( '0+' => sub { 1 } );
18
19 sub toString { 'true' }
20
21 package JSON::bool::false;
22 sub new { return bless {} => __PACKAGE__ }
23 use overload ( '""' => \&toString );
24 use overload ( 'bool' => sub { 0 } );
25 use overload ( '0+' => sub { 0 } );
26
27 sub toString { 'false' }
28
29 package JSON;
30 use Unicode::Normalize;
31 use vars qw/%_class_map/;
32
33 sub register_class_hint {
34         my $class = shift;
35         my %args = @_;
36
37         $_class_map{hints}{$args{hint}} = \%args;
38         $_class_map{classes}{$args{name}} = \%args;
39 }
40
41 sub _JSON_regex {
42         my $string = shift;
43
44         $string =~ s/^\s* ( 
45                            {                            | # start object
46                            \[                           | # start array
47                            -?\d+\.?\d*                  | # number literal
48                            "(?:(?:\\[\"])|[^\"])*"      | # string literal
49                            (?:\/\*.+?\*\/)              | # C comment
50                            true                         | # bool true
51                            false                        | # bool false
52                            null                         | # undef()
53                            :                            | # object key-value sep
54                            ,                            | # list sep
55                            \]                           | # array end
56                            }                              # object end
57                         )
58                  \s*//sox;
59         return ($string,$1);
60 }
61
62 sub lookup_class {
63         my $self = shift;
64         my $hint = shift;
65         return $_class_map{hints}{$hint}{name}
66 }
67
68 sub lookup_hint {
69         my $self = shift;
70         my $class = shift;
71         return $_class_map{classes}{$class}{hint}
72 }
73
74 sub _json_hint_to_class {
75         my $type = shift;
76         my $hint = shift;
77
78         return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
79         
80         $type = 'hash' if ($type eq '}');
81         $type = 'array' if ($type eq ']');
82
83         JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
84
85         return $hint;
86 }
87
88 sub JSON2perl {
89         my $class = shift;
90         local $_ = shift;
91
92         s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
93         s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
94         s/(?<!\\)\%/\\\%/gmo; # fixup % for later
95
96         # Convert JSON Unicode...
97         s/\\u([0-9a-fA-F]{4})/chr(hex($1))/esog;
98
99         # handle class blessings
100         s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
101         s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
102
103         my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
104         # Grab strings...
105         my @strings = /$re/sog;
106
107         # Replace with code...
108         #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
109         s/$re/ eval shift(\@strings) /sog;
110
111         # Perlify hash notation
112         s/:/ => /sog;
113
114         # Do numbers...
115         #s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
116
117         # Change javascript stuff to perl...
118         s/null/ undef /sog;
119         s/true/ bless( {}, "JSON::bool::true") /sog;
120         s/false/ bless( {}, "JSON::bool::false") /sog;
121
122         my $ret;
123         return eval '$ret = '.$_;
124 }
125
126 sub old_JSON2perl {
127         my ($class, $json) = @_;
128
129         if (!defined($json)) {
130                 return undef;
131         }
132
133         $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
134         $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
135         $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
136
137         my @casts;
138         my $casting_depth = 0;
139         my $current_cast;
140         my $element;
141         my $output = '';
142         while (($json,$element) = _JSON_regex($json)) {
143
144                 last unless ($element);
145
146                 if ($element eq 'null') {
147                         $output .= ' undef() ';
148                         next;
149                 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
150                         my $hint = $1;
151                         if (exists $_class_map{hints}{$hint}) {
152                                 $casts[$casting_depth] = $hint;
153                                 $output .= ' bless(';
154                         }
155                         next;
156                 } elsif ($element =~ /^\/\*/) {
157                         next;
158                 } elsif ($element =~ /^\d/) {
159                         $output .= "do { JSON::number::new($element) }";
160                         next;
161                 } elsif ($element eq '{' or $element eq '[') {
162                         $casting_depth++;
163                 } elsif ($element eq '}' or $element eq ']') {
164                         $casting_depth--;
165                         my $hint = $casts[$casting_depth];
166                         $casts[$casting_depth] = undef;
167                         if (defined $hint and exists $_class_map{hints}{$hint}) {
168                                 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
169                                 next;
170                         }
171                 } elsif ($element eq ':') {
172                         $output .= ' => ';
173                         next;
174                 } elsif ($element eq 'true') {
175                         $output .= 'bless( {}, "JSON::bool::true")';
176                         next;
177                 } elsif ($element eq 'false') {
178                         $output .= 'bless( {}, "JSON::bool::false")';
179                         next;
180                 }
181                 
182                 $output .= $element;
183         }
184
185         return eval $output;
186 }
187
188 sub perl2JSON {
189         my ($class, $perl, $strict) = @_;
190
191         my $output = '';
192         if (!defined($perl)) {
193                 $output = '' if $strict;
194                 $output = 'null' unless $strict;
195         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
196                 $output .= $perl;
197         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
198                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
199                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
200                         my %hash =  %$perl;
201                         $output .= perl2JSON(undef,\%hash, $strict);
202                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
203                         my @array =  @$perl;
204                         $output .= perl2JSON(undef,\@array, $strict);
205                 }
206                 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
207         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
208                 $output .= '{';
209                 my $c = 0;
210                 for my $key (sort keys %$perl) {
211                         my $outkey = NFC($key);
212                         $output .= ',' if ($c); 
213
214                         $outkey =~ s{\\}{\\\\}sgo;
215                         $outkey =~ s/"/\\"/sgo;
216                         $outkey =~ s/\t/\\t/sgo;
217                         $outkey =~ s/\f/\\f/sgo;
218                         $outkey =~ s/\r/\\r/sgo;
219                         $outkey =~ s/\n/\\n/sgo;
220                         $outkey =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
221
222                         $output .= '"'.$outkey.'":'. perl2JSON(undef,$$perl{$key}, $strict);
223                         $c++;
224                 }
225                 $output .= '}';
226         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
227                 $output .= '[';
228                 my $c = 0;
229                 for my $part (@$perl) {
230                         $output .= ',' if ($c); 
231                         
232                         $output .= perl2JSON(undef,$part, $strict);
233                         $c++;
234                 }
235                 $output .= ']';
236         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
237                 $output .= perl2JSON(undef,$perl->(), $strict);
238         } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
239                 my $type = $2;
240                 my $name = $1;
241                 JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
242                 $output .= perl2JSON(undef,$perl, $strict);
243         } else {
244                 $perl = NFC($perl);
245                 $perl =~ s{\\}{\\\\}sgo;
246                 $perl =~ s/"/\\"/sgo;
247                 $perl =~ s/\t/\\t/sgo;
248                 $perl =~ s/\f/\\f/sgo;
249                 $perl =~ s/\r/\\r/sgo;
250                 $perl =~ s/\n/\\n/sgo;
251                 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
252                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
253                         $output = $perl;
254                 } else {
255                         $output = '"'.$perl.'"';
256                 }
257         }
258
259         return $output;
260 }
261
262 my $depth = 0;
263 sub perl2prettyJSON {
264         my ($class, $perl, $nospace) = @_;
265         $perl ||= $class;
266
267         my $output = '';
268         if (!defined($perl)) {
269                 $output = "   "x$depth unless($nospace);
270                 $output .= 'null';
271         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
272                 $output = "   "x$depth unless($nospace);
273                 $output .= $perl;
274         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
275                 $depth++;
276                 $output .= "\n";
277                 $output .= "   "x$depth;
278                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
279                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
280                         my %hash =  %$perl;
281                         $output .= perl2prettyJSON(\%hash,undef,1);
282                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
283                         my @array =  @$perl;
284                         $output .= perl2prettyJSON(\@array,undef,1);
285                 }
286                 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
287                 $depth--;
288         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
289                 $output .= "   "x$depth unless ($nospace);
290                 $output .= "{\n";
291                 my $c = 0;
292                 $depth++;
293                 for my $key (sort keys %$perl) {
294                         $output .= ",\n" if ($c); 
295                         $output .= "   "x$depth;
296                         $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
297                         $c++;
298                 }
299                 $depth--;
300                 $output .= "\n";
301                 $output .= "   "x$depth;
302                 $output .= '}';
303         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
304                 $output .= "   "x$depth unless ($nospace);
305                 $output .= "[\n";
306                 my $c = 0;
307                 $depth++;
308                 for my $part (@$perl) {
309                         $output .= ",\n" if ($c); 
310                         $output .= "   "x$depth;
311                         $output .= perl2prettyJSON($part);
312                         $c++;
313                 }
314                 $depth--;
315                 $output .= "\n";
316                 $output .= "   "x$depth;
317                 $output .= "]";
318         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
319                 $output .= perl2prettyJSON(undef,$perl->(), $nospace);
320         } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
321                 my $type = $2;
322                 my $name = $1;
323                 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
324                 $output .= perl2prettyJSON(undef,$perl);
325         } else {
326                 $perl = NFC($perl);
327                 $perl =~ s/\\/\\\\/sgo;
328                 $perl =~ s/"/\\"/sgo;
329                 $perl =~ s/\t/\\t/sgo;
330                 $perl =~ s/\f/\\f/sgo;
331                 $perl =~ s/\r/\\r/sgo;
332                 $perl =~ s/\n/\\n/sgo;
333                 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
334                 $output .= "   "x$depth unless($nospace);
335                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
336                         $output = $perl;
337                 } else {
338                         $output = '"'.$perl.'"';
339                 }
340         }
341
342         return $output;
343 }
344
345 1;