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;