Patch from Dan Scott to move JSON to OpenSRF::Utils::JSON:
[OpenSRF.git] / src / perlmods / JSON.pm
1
2 package OpenSRF::Utils::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 OpenSRF::Utils::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 OpenSRF::Utils::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 OpenSRF::Utils::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         OpenSRF::Utils::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/ OpenSRF::Utils::JSON::number::new($1) /sog;
116
117         # Change javascript stuff to perl...
118         s/null/ undef /sog;
119         s/true/ bless( {}, "OpenSRF::Utils::JSON::bool::true") /sog;
120         s/false/ bless( {}, "OpenSRF::Utils::JSON::bool::false") /sog;
121
122         my $ret;
123         return eval '$ret = '.$_;
124 }
125
126 my $_json_index;
127 sub ___JSON2perl {
128         my $class = shift;
129         my $data = shift;
130
131         $data = [ split //, $data ];
132
133         $_json_index = 0;
134
135         return _json_parse_data($data);
136 }
137
138 sub _eat_WS {
139         my $data = shift;
140         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
141 }
142
143 sub _json_parse_data {
144         my $data = shift;
145
146         my $out; 
147
148         #warn "parse_data";
149
150         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
151
152         my $class = '';
153
154         my $c = $$data[$_json_index];
155
156         if ($c eq '/') {
157                 $_json_index++;
158                 $class = _json_parse_comment($data);
159                 
160                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
161                 $c = $$data[$_json_index];
162         }
163
164         if ($c eq '"') {
165                 $_json_index++;
166                 my $val = '';
167
168                 my $seen_slash = 0;
169                 my $done = 0;
170                 while (!$done) {
171                         my $c = $$data[$_json_index];
172                         #warn "c is $c";
173
174                         if ($c eq '\\') {
175                                 if ($seen_slash) {
176                                         $val .= '\\';
177                                         $seen_slash = 0;
178                                 } else {
179                                         $seen_slash = 1;
180                                 }
181                         } elsif ($c eq '"') {
182                                 if ($seen_slash) {
183                                         $val .= '"';
184                                         $seen_slash = 0;
185                                 } else {
186                                         $done = 1;
187                                 }
188                         } elsif ($c eq 't') {
189                                 if ($seen_slash) {
190                                         $val .= "\t";
191                                         $seen_slash = 0;
192                                 } else {
193                                         $val .= 't';
194                                 }
195                         } elsif ($c eq 'b') {
196                                 if ($seen_slash) {
197                                         $val .= "\b";
198                                         $seen_slash = 0;
199                                 } else {
200                                         $val .= 'b';
201                                 }
202                         } elsif ($c eq 'f') {
203                                 if ($seen_slash) {
204                                         $val .= "\f";
205                                         $seen_slash = 0;
206                                 } else {
207                                         $val .= 'f';
208                                 }
209                         } elsif ($c eq 'r') {
210                                 if ($seen_slash) {
211                                         $val .= "\r";
212                                         $seen_slash = 0;
213                                 } else {
214                                         $val .= 'r';
215                                 }
216                         } elsif ($c eq 'n') {
217                                 if ($seen_slash) {
218                                         $val .= "\n";
219                                         $seen_slash = 0;
220                                 } else {
221                                         $val .= 'n';
222                                 }
223                         } elsif ($c eq 'u') {
224                                 if ($seen_slash) {
225                                         $_json_index++;
226                                         $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3])));
227                                         $_json_index += 3;
228                                         $seen_slash = 0;
229                                 } else {
230                                         $val .= 'u';
231                                 }
232                         } else {
233                                 $val .= $c;
234                         }
235                         $_json_index++;
236
237                         #warn "string is $val";
238                 }
239
240                 $out = $val;
241
242                 #$out = _json_parse_string($data);
243         } elsif ($c eq '[') {
244                 $_json_index++;
245                 $out = [];
246
247                 my $in_parse = 0;
248                 my $done = 0;
249                 while(!$done) {
250                         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
251
252                         if ($$data[$_json_index] eq ']') {
253                                 $done = 1;
254                                 $_json_index++;
255                                 last;
256                         }
257
258                         if ($in_parse) {
259                                 if ($$data[$_json_index] ne ',') {
260                                         #warn "_json_parse_array: bad data, leaving array parser";
261                                         last;
262                                 }
263                                 $_json_index++;
264                                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
265                         }
266
267                         my $item = _json_parse_data($data);
268
269                         push @$out, $item;
270                         $in_parse++;
271                 }
272
273                 #$out = _json_parse_array($data);
274         } elsif ($c eq '{') {
275                 $_json_index++;
276                 $out = {};
277
278                 my $in_parse = 0;
279                 my $done = 0;
280                 while(!$done) {
281                         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
282
283                         if ($$data[$_json_index] eq '}') {
284                                 $done = 1;
285                                 $_json_index++;
286                                 last;
287                         }
288
289                         if ($in_parse) {
290                                 if ($$data[$_json_index] ne ',') {
291                                         #warn "_json_parse_object: bad data, leaving object parser";
292                                         last;
293                                 }
294                                 $_json_index++;
295                                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
296                         }
297
298                         my ($key,$value);
299                         $key = _json_parse_data($data);
300
301                         #warn "object key is $key";
302
303                         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
304                 
305                         if ($$data[$_json_index] ne ':') {
306                                 #warn "_json_parse_object: bad data, leaving object parser";
307                                 last;
308                         }
309                         $_json_index++;
310                         $value = _json_parse_data($data);
311
312                         $out->{$key} = $value;
313                         $in_parse++;
314                 }
315                 #$out = _json_parse_object($data);
316         } elsif (lc($c) eq 'n') {
317                 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') {
318                         $_json_index += 4;
319                 } else {
320                         warn "CRAP! bad null parsing...";
321                 }
322                 $out = undef;
323                 #$out = _json_parse_null($data);
324         } elsif (lc($c) eq 't' or lc($c) eq 'f') {
325                 if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') {
326                         $out = 1;
327                         $_json_index += 4;
328                 } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') {
329                         $out = 0;
330                         $_json_index += 5;
331                 } else {
332                         #warn "CRAP! bad bool parsing...";
333                         $out = undef;
334                 }
335                 #$out = _json_parse_bool($data);
336         } elsif ($c =~ /\d+/o or $c eq '.' or $c eq '-') {
337                 my $val;
338                 while ($$data[$_json_index] =~ /[-\.0-9]+/io) {
339                         $val .= $$data[$_json_index];
340                         $_json_index++;
341                 }
342                 $out = 0+$val;
343                 #$out = _json_parse_number($data);
344         }
345
346         if ($class) {
347                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
348                 my $c = $$data[$_json_index];
349
350                 if ($c eq '/') {
351                         $_json_index++;
352                         _json_parse_comment($data)
353                 }
354
355                 bless( $out => lookup_class($class) );
356         }
357
358         $out;
359 }
360
361 sub _json_parse_null {
362         my $data = shift;
363
364         #warn "parse_null";
365
366         if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'null') {
367                 $_json_index += 4;
368         } else {
369                 #warn "CRAP! bad null parsing...";
370         }
371         return undef;
372 }
373
374 sub _json_parse_bool {
375         my $data = shift;
376
377         my $out;
378
379         #warn "parse_bool";
380
381         if (lc(join('',$$data[$_json_index .. $_json_index + 3])) eq 'true') {
382                 $out = 1;
383                 $_json_index += 4;
384         } elsif (lc(join('',$$data[$_json_index .. $_json_index + 4])) eq 'false') {
385                 $out = 0;
386                 $_json_index += 5;
387         } else {
388                 #warn "CRAP! bad bool parsing...";
389                 $out = undef;
390         }
391         return $out;
392 }
393
394 sub _json_parse_number {
395         my $data = shift;
396
397         #warn "parse_number";
398
399         my $val;
400         while ($$data[$_json_index] =~ /[-\.0-9]+/io) {
401                 $val .= $$data[$_json_index];
402                 $_json_index++;
403         }
404
405         return 0+$val;
406 }
407
408 sub _json_parse_object {
409         my $data = shift;
410
411         #warn "parse_object";
412
413         my $out = {};
414
415         my $in_parse = 0;
416         my $done = 0;
417         while(!$done) {
418                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
419
420                 if ($$data[$_json_index] eq '}') {
421                         $done = 1;
422                         $_json_index++;
423                         last;
424                 }
425
426                 if ($in_parse) {
427                         if ($$data[$_json_index] ne ',') {
428                                 #warn "_json_parse_object: bad data, leaving object parser";
429                                 last;
430                         }
431                         $_json_index++;
432                         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
433                 }
434
435                 my ($key,$value);
436                 $key = _json_parse_data($data);
437
438                 #warn "object key is $key";
439
440                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
441                 
442                 if ($$data[$_json_index] ne ':') {
443                         #warn "_json_parse_object: bad data, leaving object parser";
444                         last;
445                 }
446                 $_json_index++;
447                 $value = _json_parse_data($data);
448
449                 $out->{$key} = $value;
450                 $in_parse++;
451         }
452
453         return $out;
454 }
455
456 sub _json_parse_array {
457         my $data = shift;
458
459         #warn "parse_array";
460
461         my $out = [];
462
463         my $in_parse = 0;
464         my $done = 0;
465         while(!$done) {
466                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
467
468                 if ($$data[$_json_index] eq ']') {
469                         $done = 1;
470                         $_json_index++;
471                         last;
472                 }
473
474                 if ($in_parse) {
475                         if ($$data[$_json_index] ne ',') {
476                                 #warn "_json_parse_array: bad data, leaving array parser";
477                                 last;
478                         }
479                         $_json_index++;
480                         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
481                 }
482
483                 my $item = _json_parse_data($data);
484
485                 push @$out, $item;
486                 $in_parse++;
487         }
488
489         return $out;
490 }
491
492
493 sub _json_parse_string {
494         my $data = shift;
495
496         #warn "parse_string";
497
498         my $val = '';
499
500         my $seen_slash = 0;
501         my $done = 0;
502         while (!$done) {
503                 my $c = $$data[$_json_index];
504                 #warn "c is $c";
505
506                 if ($c eq '\\') {
507                         if ($seen_slash) {
508                                 $val .= '\\';
509                                 $seen_slash = 0;
510                         } else {
511                                 $seen_slash = 1;
512                         }
513                 } elsif ($c eq '"') {
514                         if ($seen_slash) {
515                                 $val .= '"';
516                                 $seen_slash = 0;
517                         } else {
518                                 $done = 1;
519                         }
520                 } elsif ($c eq 't') {
521                         if ($seen_slash) {
522                                 $val .= "\t";
523                                 $seen_slash = 0;
524                         } else {
525                                 $val .= 't';
526                         }
527                 } elsif ($c eq 'b') {
528                         if ($seen_slash) {
529                                 $val .= "\b";
530                                 $seen_slash = 0;
531                         } else {
532                                 $val .= 'b';
533                         }
534                 } elsif ($c eq 'f') {
535                         if ($seen_slash) {
536                                 $val .= "\f";
537                                 $seen_slash = 0;
538                         } else {
539                                 $val .= 'f';
540                         }
541                 } elsif ($c eq 'r') {
542                         if ($seen_slash) {
543                                 $val .= "\r";
544                                 $seen_slash = 0;
545                         } else {
546                                 $val .= 'r';
547                         }
548                 } elsif ($c eq 'n') {
549                         if ($seen_slash) {
550                                 $val .= "\n";
551                                 $seen_slash = 0;
552                         } else {
553                                 $val .= 'n';
554                         }
555                 } elsif ($c eq 'u') {
556                         if ($seen_slash) {
557                                 $_json_index++;
558                                 $val .= chr(hex(join('',$$data[$_json_index .. $_json_index + 3])));
559                                 $_json_index += 3;
560                                 $seen_slash = 0;
561                         } else {
562                                 $val .= 'u';
563                         }
564                 } else {
565                         $val .= $c;
566                 }
567                 $_json_index++;
568
569                 #warn "string is $val";
570         }
571
572         return $val;
573 }
574
575 sub _json_parse_comment {
576         my $data = shift;
577
578         #warn "parse_comment";
579
580         if ($$data[$_json_index] eq '/') {
581                 $_json_index++;
582                 while (!($$data[$_json_index] eq "\n")) { $_json_index++ }
583                 $_json_index++;
584                 return undef;
585         }
586
587         my $class = '';
588
589         if (join('',$$data[$_json_index .. $_json_index + 2]) eq '*--') {
590                 $_json_index += 3;
591                 while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
592                 if ($$data[$_json_index] eq 'S') {
593                         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
594                         while ($$data[$_json_index] !~ /[-\s]+/o) {
595                                 $class .= $$data[$_json_index];
596                                 $_json_index++;
597                         }
598                         while ($$data[$_json_index] =~ /\s+/o) { $_json_index++ }
599                 }
600         }
601
602         while ($$data[$_json_index] ne '/') { $_json_index++ };
603         $_json_index++;
604
605         return $class;
606 }
607
608 sub old_JSON2perl {
609         my ($class, $json) = @_;
610
611         if (!defined($json)) {
612                 return undef;
613         }
614
615         $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
616         $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
617         $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
618
619         my @casts;
620         my $casting_depth = 0;
621         my $current_cast;
622         my $element;
623         my $output = '';
624         while (($json,$element) = _JSON_regex($json)) {
625
626                 last unless ($element);
627
628                 if ($element eq 'null') {
629                         $output .= ' undef() ';
630                         next;
631                 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
632                         my $hint = $1;
633                         if (exists $_class_map{hints}{$hint}) {
634                                 $casts[$casting_depth] = $hint;
635                                 $output .= ' bless(';
636                         }
637                         next;
638                 } elsif ($element =~ /^\/\*/) {
639                         next;
640                 } elsif ($element =~ /^\d/) {
641                         $output .= "do { OpenSRF::Utils::JSON::number::new($element) }";
642                         next;
643                 } elsif ($element eq '{' or $element eq '[') {
644                         $casting_depth++;
645                 } elsif ($element eq '}' or $element eq ']') {
646                         $casting_depth--;
647                         my $hint = $casts[$casting_depth];
648                         $casts[$casting_depth] = undef;
649                         if (defined $hint and exists $_class_map{hints}{$hint}) {
650                                 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
651                                 next;
652                         }
653                 } elsif ($element eq ':') {
654                         $output .= ' => ';
655                         next;
656                 } elsif ($element eq 'true') {
657                         $output .= 'bless( {}, "OpenSRF::Utils::JSON::bool::true")';
658                         next;
659                 } elsif ($element eq 'false') {
660                         $output .= 'bless( {}, "OpenSRF::Utils::JSON::bool::false")';
661                         next;
662                 }
663                 
664                 $output .= $element;
665         }
666
667         return eval $output;
668 }
669
670 sub perl2JSON {
671         my ($class, $perl, $strict) = @_;
672
673         my $output = '';
674         if (!defined($perl)) {
675                 $output = '' if $strict;
676                 $output = 'null' unless $strict;
677         } elsif (ref($perl) and ref($perl) =~ /^OpenSRF::Utils::JSON/) {
678                 $output .= $perl;
679         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
680                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
681                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
682                         my %hash =  %$perl;
683                         $output .= perl2JSON(undef,\%hash, $strict);
684                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
685                         my @array =  @$perl;
686                         $output .= perl2JSON(undef,\@array, $strict);
687                 }
688                 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
689         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
690                 $output .= '{';
691                 my $c = 0;
692                 for my $key (sort keys %$perl) {
693                         my $outkey = NFC($key);
694                         $output .= ',' if ($c); 
695
696                         $outkey =~ s{\\}{\\\\}sgo;
697                         $outkey =~ s/"/\\"/sgo;
698                         $outkey =~ s/\t/\\t/sgo;
699                         $outkey =~ s/\f/\\f/sgo;
700                         $outkey =~ s/\r/\\r/sgo;
701                         $outkey =~ s/\n/\\n/sgo;
702                         $outkey =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
703
704                         $output .= '"'.$outkey.'":'. perl2JSON(undef,$$perl{$key}, $strict);
705                         $c++;
706                 }
707                 $output .= '}';
708         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
709                 $output .= '[';
710                 my $c = 0;
711                 for my $part (@$perl) {
712                         $output .= ',' if ($c); 
713                         
714                         $output .= perl2JSON(undef,$part, $strict);
715                         $c++;
716                 }
717                 $output .= ']';
718         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
719                 $output .= perl2JSON(undef,$perl->(), $strict);
720         } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
721                 my $type = $2;
722                 my $name = $1;
723                 OpenSRF::Utils::JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
724                 $output .= perl2JSON(undef,$perl, $strict);
725         } else {
726                 $perl = NFC($perl);
727                 $perl =~ s{\\}{\\\\}sgo;
728                 $perl =~ s/"/\\"/sgo;
729                 $perl =~ s/\t/\\t/sgo;
730                 $perl =~ s/\f/\\f/sgo;
731                 $perl =~ s/\r/\\r/sgo;
732                 $perl =~ s/\n/\\n/sgo;
733                 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
734                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
735                         $output = $perl;
736                 } else {
737                         $output = '"'.$perl.'"';
738                 }
739         }
740
741         return $output;
742 }
743
744 my $depth = 0;
745 sub perl2prettyJSON {
746         my ($class, $perl, $nospace) = @_;
747         $perl ||= $class;
748
749         my $output = '';
750         if (!defined($perl)) {
751                 $output = "   "x$depth unless($nospace);
752                 $output .= 'null';
753         } elsif (ref($perl) and ref($perl) =~ /^OpenSRF::Utils::JSON/) {
754                 $output = "   "x$depth unless($nospace);
755                 $output .= $perl;
756         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
757                 $depth++;
758                 $output .= "\n";
759                 $output .= "   "x$depth;
760                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
761                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
762                         my %hash =  %$perl;
763                         $output .= perl2prettyJSON(\%hash,undef,1);
764                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
765                         my @array =  @$perl;
766                         $output .= perl2prettyJSON(\@array,undef,1);
767                 }
768                 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
769                 $depth--;
770         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
771                 $output .= "   "x$depth unless ($nospace);
772                 $output .= "{\n";
773                 my $c = 0;
774                 $depth++;
775                 for my $key (sort keys %$perl) {
776                         $output .= ",\n" if ($c); 
777                         $output .= "   "x$depth;
778                         $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
779                         $c++;
780                 }
781                 $depth--;
782                 $output .= "\n";
783                 $output .= "   "x$depth;
784                 $output .= '}';
785         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
786                 $output .= "   "x$depth unless ($nospace);
787                 $output .= "[\n";
788                 my $c = 0;
789                 $depth++;
790                 for my $part (@$perl) {
791                         $output .= ",\n" if ($c); 
792                         $output .= "   "x$depth;
793                         $output .= perl2prettyJSON($part);
794                         $c++;
795                 }
796                 $depth--;
797                 $output .= "\n";
798                 $output .= "   "x$depth;
799                 $output .= "]";
800         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
801                 $output .= perl2prettyJSON(undef,$perl->(), $nospace);
802         } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
803                 my $type = $2;
804                 my $name = $1;
805                 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
806                 $output .= perl2prettyJSON(undef,$perl);
807         } else {
808                 $perl = NFC($perl);
809                 $perl =~ s/\\/\\\\/sgo;
810                 $perl =~ s/"/\\"/sgo;
811                 $perl =~ s/\t/\\t/sgo;
812                 $perl =~ s/\f/\\f/sgo;
813                 $perl =~ s/\r/\\r/sgo;
814                 $perl =~ s/\n/\\n/sgo;
815                 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
816                 $output .= "   "x$depth unless($nospace);
817                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
818                         $output = $perl;
819                 } else {
820                         $output = '"'.$perl.'"';
821                 }
822         }
823
824         return $output;
825 }
826
827 1;