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