cleaning up the pretty printer
[working/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 _json_hint_to_class {
63         my $type = shift;
64         my $hint = shift;
65
66         return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
67         
68         $type = 'hash' if ($type eq '}');
69         $type = 'array' if ($type eq ']');
70
71         JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
72
73         return $hint;
74 }
75
76 sub JSON2perl {
77         my $class = shift;
78         local $_ = shift;
79
80         s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
81         s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
82         s/(?<!\\)\%/\\\%/gmo; # fixup % for later
83
84         # Convert JSON Unicode...
85         s/\\u([0-9a-fA-F]{4})/chr(hex($1))/esog;
86
87         # handle class blessings
88         s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
89         s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
90
91         my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
92         # Grab strings...
93         my @strings = /$re/sog;
94
95         # Replace with code...
96         #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
97         s/$re/ eval shift(\@strings) /sog;
98
99         # Perlify hash notation
100         s/:/ => /sog;
101
102         # Do numbers...
103         #s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
104
105         # Change javascript stuff to perl...
106         s/null/ undef /sog;
107         s/true/ bless( {}, "JSON::bool::true") /sog;
108         s/false/ bless( {}, "JSON::bool::false") /sog;
109
110         my $ret;
111         return eval '$ret = '.$_;
112 }
113
114 sub old_JSON2perl {
115         my ($class, $json) = @_;
116
117         if (!defined($json)) {
118                 return undef;
119         }
120
121         $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
122         $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
123         $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
124
125         my @casts;
126         my $casting_depth = 0;
127         my $current_cast;
128         my $element;
129         my $output = '';
130         while (($json,$element) = _JSON_regex($json)) {
131
132                 last unless ($element);
133
134                 if ($element eq 'null') {
135                         $output .= ' undef() ';
136                         next;
137                 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
138                         my $hint = $1;
139                         if (exists $_class_map{hints}{$hint}) {
140                                 $casts[$casting_depth] = $hint;
141                                 $output .= ' bless(';
142                         }
143                         next;
144                 } elsif ($element =~ /^\/\*/) {
145                         next;
146                 } elsif ($element =~ /^\d/) {
147                         $output .= "do { JSON::number::new($element) }";
148                         next;
149                 } elsif ($element eq '{' or $element eq '[') {
150                         $casting_depth++;
151                 } elsif ($element eq '}' or $element eq ']') {
152                         $casting_depth--;
153                         my $hint = $casts[$casting_depth];
154                         $casts[$casting_depth] = undef;
155                         if (defined $hint and exists $_class_map{hints}{$hint}) {
156                                 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
157                                 next;
158                         }
159                 } elsif ($element eq ':') {
160                         $output .= ' => ';
161                         next;
162                 } elsif ($element eq 'true') {
163                         $output .= 'bless( {}, "JSON::bool::true")';
164                         next;
165                 } elsif ($element eq 'false') {
166                         $output .= 'bless( {}, "JSON::bool::false")';
167                         next;
168                 }
169                 
170                 $output .= $element;
171         }
172
173         return eval $output;
174 }
175
176 sub perl2JSON {
177         my ($class, $perl, $strict) = @_;
178
179         my $output = '';
180         if (!defined($perl)) {
181                 $output = '' if $strict;
182                 $output = 'null' unless $strict;
183         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
184                 $output .= $perl;
185         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
186                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
187                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
188                         my %hash =  %$perl;
189                         $output .= perl2JSON(undef,\%hash, $strict);
190                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
191                         my @array =  @$perl;
192                         $output .= perl2JSON(undef,\@array, $strict);
193                 }
194                 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
195         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
196                 $output .= '{';
197                 my $c = 0;
198                 for my $key (sort keys %$perl) {
199                         my $outkey = NFD($key);
200                         $output .= ',' if ($c); 
201
202                         $outkey = NFD($outkey);
203                         $outkey =~ s{\\}{\\\\}sgo;
204                         $outkey =~ s/"/\\"/sgo;
205                         $outkey =~ s/\t/\\t/sgo;
206                         $outkey =~ s/\f/\\f/sgo;
207                         $outkey =~ s/\r/\\r/sgo;
208                         $outkey =~ s/\n/\\n/sgo;
209                         $outkey =~ s/(\PM\pM+)/sprintf('\u%0.4x',ord(NFC($1)))/sgoe;
210
211                         $output .= '"'.$outkey.'":'. perl2JSON(undef,$$perl{$key}, $strict);
212                         $c++;
213                 }
214                 $output .= '}';
215         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
216                 $output .= '[';
217                 my $c = 0;
218                 for my $part (@$perl) {
219                         $output .= ',' if ($c); 
220                         
221                         $output .= perl2JSON(undef,$part, $strict);
222                         $c++;
223                 }
224                 $output .= ']';
225         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
226                 $output .= perl2JSON(undef,$perl->(), $strict);
227         } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
228                 my $type = $2;
229                 my $name = $1;
230                 JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
231                 $output .= perl2JSON(undef,$perl, $strict);
232         } else {
233                 $perl = NFD($perl);
234                 $perl =~ s{\\}{\\\\}sgo;
235                 $perl =~ s/"/\\"/sgo;
236                 $perl =~ s/\t/\\t/sgo;
237                 $perl =~ s/\f/\\f/sgo;
238                 $perl =~ s/\r/\\r/sgo;
239                 $perl =~ s/\n/\\n/sgo;
240                 $perl =~ s/(\PM\pM+)/sprintf('\u%0.4x',ord(NFC($1)))/sgoe;
241                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
242                         $output = $perl;
243                 } else {
244                         $output = '"'.$perl.'"';
245                 }
246         }
247
248         return $output;
249 }
250
251 my $depth = 0;
252 sub perl2prettyJSON {
253         my ($class, $perl, $nospace) = @_;
254         $perl ||= $class;
255
256         my $output = '';
257         if (!defined($perl)) {
258                 $output = "   "x$depth unless($nospace);
259                 $output .= 'null';
260         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
261                 $output = "   "x$depth unless($nospace);
262                 $output .= $perl;
263         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
264                 $depth++;
265                 $output .= "\n";
266                 $output .= "   "x$depth;
267                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
268                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
269                         my %hash =  %$perl;
270                         $output .= perl2prettyJSON(\%hash,undef,1);
271                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
272                         my @array =  @$perl;
273                         $output .= perl2prettyJSON(\@array,undef,1);
274                 }
275                 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
276                 $depth--;
277         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
278                 $output .= "   "x$depth unless ($nospace);
279                 $output .= "{\n";
280                 my $c = 0;
281                 $depth++;
282                 for my $key (sort keys %$perl) {
283                         $output .= ",\n" if ($c); 
284                         $output .= "   "x$depth;
285                         $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
286                         $c++;
287                 }
288                 $depth--;
289                 $output .= "\n";
290                 $output .= "   "x$depth;
291                 $output .= '}';
292         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
293                 $output .= "   "x$depth unless ($nospace);
294                 $output .= "[\n";
295                 my $c = 0;
296                 $depth++;
297                 for my $part (@$perl) {
298                         $output .= ",\n" if ($c); 
299                         $output .= "   "x$depth;
300                         $output .= perl2prettyJSON($part);
301                         $c++;
302                 }
303                 $depth--;
304                 $output .= "\n";
305                 $output .= "   "x$depth;
306                 $output .= "]";
307         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
308                 $output .= perl2prettyJSON(undef,$perl->(), $nospace);
309         } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
310                 my $type = $2;
311                 my $name = $1;
312                 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
313                 $output .= perl2prettyJSON(undef,$perl);
314         } else {
315                 $perl = NFD($perl);
316                 $perl =~ s/\\/\\\\/sgo;
317                 $perl =~ s/"/\\"/sgo;
318                 $perl =~ s/\t/\\t/sgo;
319                 $perl =~ s/\f/\\f/sgo;
320                 $perl =~ s/\r/\\r/sgo;
321                 $perl =~ s/\n/\\n/sgo;
322                 $perl =~ s/(\PM\pM+)/sprintf('\u%0.4x',ord(NFC($1)))/sgoe;
323                 $output .= "   "x$depth unless($nospace);
324                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
325                         $output = $perl;
326                 } else {
327                         $output = '"'.$perl.'"';
328                 }
329         }
330
331         return $output;
332 }
333
334 1;