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