src/perlmods/JSON.pm

   1
   2 package JSON::number;
   3 sub new {
   4         my $class = shift;
   5         my $x = shift || $class;
   6         return bless \$x => __PACKAGE__;
   7 }
   8
   9 use overload ( '""' => \&toString );
  10
  11 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
  12
  13 package JSON::bool::true;
  14 sub new { return bless {} => __PACKAGE__ }
  15 use overload ( '""' => \&toString );
  16 use overload ( 'bool' => sub { 1 } );
  17 use overload ( '0+' => sub { 1 } );
  18
  19 sub toString { 'true' }
  20
  21 package JSON::bool::false;
  22 sub new { return bless {} => __PACKAGE__ }
  23 use overload ( '""' => \&toString );
  24 use overload ( 'bool' => sub { 0 } );
  25 use overload ( '0+' => sub { 0 } );
  26
  27 sub toString { 'false' }
  28
  29 package JSON;
  30 use Unicode::Normalize;
  31 use vars qw/%_class_map/;
  32
  33 sub register_class_hint {
  34         my $class = shift;
  35         my %args = @_;
  36
  37         $_class_map{hints}{$args{hint}} = \%args;
  38         $_class_map{classes}{$args{name}} = \%args;
  39 }
  40
  41 sub _JSON_regex {
  42         my $string = shift;
  43
  44         $string =~ s/^\s* (
  45                            {                            | # start object
  46                            \[                           | # start array
  47                            -?\d+\.?\d*                  | # number literal
  48                            "(?:(?:\\[\"])|[^\"])*"      | # string literal
  49                            (?:\/\*.+?\*\/)              | # C comment
  50                            true                         | # bool true
  51                            false                        | # bool false
  52                            null                         | # undef()
  53                            :                            | # object key-value sep
  54                            ,                            | # list sep
  55                            \]                           | # array end
  56                            }                              # object end
  57                         )
  58                  \s*//sox;
  59         return ($string,$1);
  60 }
  61
  62 sub lookup_class {
  63         my $self = shift;
  64         my $hint = shift;
  65         return $_class_map{hints}{$hint}{name}
  66 }
  67
  68 sub lookup_hint {
  69         my $self = shift;
  70         my $class = shift;
  71         return $_class_map{classes}{$class}{hint}
  72 }
  73
  74 sub _json_hint_to_class {
  75         my $type = shift;
  76         my $hint = shift;
  77
  78         return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
  79
  80         $type = 'hash' if ($type eq '}');
  81         $type = 'array' if ($type eq ']');
  82
  83         JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
  84
  85         return $hint;
  86 }
  87
  88 sub JSON2perl {
  89         my $class = shift;
  90         local $_ = shift;
  91
  92         s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
  93         s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
  94         s/(?<!\\)\%/\\\%/gmo; # fixup % for later
  95
  96         # Convert JSON Unicode...
  97         s/\\u([0-9a-fA-F]{4})/chr(hex($1))/esog;
  98
  99         # handle class blessings
 100         s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
 101         s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
 102
 103         my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
 104         # Grab strings...
 105         my @strings = /$re/sog;
 106
 107         # Replace with code...
 108         #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
 109         s/$re/ eval shift(\@strings) /sog;
 110
 111         # Perlify hash notation
 112         s/:/ => /sog;
 113
 114         # Do numbers...
 115         #s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
 116
 117         # Change javascript stuff to perl...
 118         s/null/ undef /sog;
 119         s/true/ bless( {}, "JSON::bool::true") /sog;
 120         s/false/ bless( {}, "JSON::bool::false") /sog;
 121
 122         my $ret;
 123         return eval '$ret = '.$_;
 124 }
 125
 126 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 { 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( {}, "JSON::bool::true")';
 658                         next;
 659                 } elsif ($element eq 'false') {
 660                         $output .= 'bless( {}, "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) =~ /^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                 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) =~ /^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;