OpenSRF/src/perlmods/JSON.pm

   1
   2 package JSON::number;
   3 sub new {
   4         my $class = shift;
   5         my $x = shift || $class;
   6         return bless \$x => __PACKAGE__;
   7 }
   8
   9 use overload ( '""' => \&toString );
  10
  11 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
  12
  13 package JSON::bool::true;
  14 sub new { return bless {} => __PACKAGE__ }
  15 use overload ( '""' => \&toString );
  16 use overload ( 'bool' => sub { 1 } );
  17 use overload ( '0+' => sub { 1 } );
  18
  19 sub toString { 'true' }
  20
  21 package JSON::bool::false;
  22 sub new { return bless {} => __PACKAGE__ }
  23 use overload ( '""' => \&toString );
  24 use overload ( 'bool' => sub { 0 } );
  25 use overload ( '0+' => sub { 0 } );
  26
  27 sub toString { 'false' }
  28
  29 package JSON;
  30 use Unicode::Normalize;
  31 use vars qw/%_class_map/;
  32
  33 sub register_class_hint {
  34         my $class = shift;
  35         my %args = @_;
  36
  37         $_class_map{hints}{$args{hint}} = \%args;
  38         $_class_map{classes}{$args{name}} = \%args;
  39 }
  40
  41 sub _JSON_regex {
  42         my $string = shift;
  43
  44         $string =~ s/^\s* (
  45                            {                            | # start object
  46                            \[                           | # start array
  47                            -?\d+\.?\d*                  | # number literal
  48                            "(?:(?:\\[\"])|[^\"])*"      | # string literal
  49                            (?:\/\*.+?\*\/)              | # C comment
  50                            true                         | # bool true
  51                            false                        | # bool false
  52                            null                         | # undef()
  53                            :                            | # object key-value sep
  54                            ,                            | # list sep
  55                            \]                           | # array end
  56                            }                              # object end
  57                         )
  58                  \s*//sox;
  59         return ($string,$1);
  60 }
  61
  62 sub 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 sub old_JSON2perl {
 127         my ($class, $json) = @_;
 128
 129         if (!defined($json)) {
 130                 return undef;
 131         }
 132
 133         $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
 134         $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
 135         $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
 136
 137         my @casts;
 138         my $casting_depth = 0;
 139         my $current_cast;
 140         my $element;
 141         my $output = '';
 142         while (($json,$element) = _JSON_regex($json)) {
 143
 144                 last unless ($element);
 145
 146                 if ($element eq 'null') {
 147                         $output .= ' undef() ';
 148                         next;
 149                 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
 150                         my $hint = $1;
 151                         if (exists $_class_map{hints}{$hint}) {
 152                                 $casts[$casting_depth] = $hint;
 153                                 $output .= ' bless(';
 154                         }
 155                         next;
 156                 } elsif ($element =~ /^\/\*/) {
 157                         next;
 158                 } elsif ($element =~ /^\d/) {
 159                         $output .= "do { JSON::number::new($element) }";
 160                         next;
 161                 } elsif ($element eq '{' or $element eq '[') {
 162                         $casting_depth++;
 163                 } elsif ($element eq '}' or $element eq ']') {
 164                         $casting_depth--;
 165                         my $hint = $casts[$casting_depth];
 166                         $casts[$casting_depth] = undef;
 167                         if (defined $hint and exists $_class_map{hints}{$hint}) {
 168                                 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
 169                                 next;
 170                         }
 171                 } elsif ($element eq ':') {
 172                         $output .= ' => ';
 173                         next;
 174                 } elsif ($element eq 'true') {
 175                         $output .= 'bless( {}, "JSON::bool::true")';
 176                         next;
 177                 } elsif ($element eq 'false') {
 178                         $output .= 'bless( {}, "JSON::bool::false")';
 179                         next;
 180                 }
 181
 182                 $output .= $element;
 183         }
 184
 185         return eval $output;
 186 }
 187
 188 sub perl2JSON {
 189         my ($class, $perl, $strict) = @_;
 190
 191         my $output = '';
 192         if (!defined($perl)) {
 193                 $output = '' if $strict;
 194                 $output = 'null' unless $strict;
 195         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
 196                 $output .= $perl;
 197         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
 198                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
 199                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
 200                         my %hash =  %$perl;
 201                         $output .= perl2JSON(undef,\%hash, $strict);
 202                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
 203                         my @array =  @$perl;
 204                         $output .= perl2JSON(undef,\@array, $strict);
 205                 }
 206                 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
 207         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
 208                 $output .= '{';
 209                 my $c = 0;
 210                 for my $key (sort keys %$perl) {
 211                         my $outkey = NFC($key);
 212                         $output .= ',' if ($c);
 213
 214                         $outkey =~ s{\\}{\\\\}sgo;
 215                         $outkey =~ s/"/\\"/sgo;
 216                         $outkey =~ s/\t/\\t/sgo;
 217                         $outkey =~ s/\f/\\f/sgo;
 218                         $outkey =~ s/\r/\\r/sgo;
 219                         $outkey =~ s/\n/\\n/sgo;
 220                         $outkey =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
 221
 222                         $output .= '"'.$outkey.'":'. perl2JSON(undef,$$perl{$key}, $strict);
 223                         $c++;
 224                 }
 225                 $output .= '}';
 226         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
 227                 $output .= '[';
 228                 my $c = 0;
 229                 for my $part (@$perl) {
 230                         $output .= ',' if ($c);
 231
 232                         $output .= perl2JSON(undef,$part, $strict);
 233                         $c++;
 234                 }
 235                 $output .= ']';
 236         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
 237                 $output .= perl2JSON(undef,$perl->(), $strict);
 238         } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
 239                 my $type = $2;
 240                 my $name = $1;
 241                 JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
 242                 $output .= perl2JSON(undef,$perl, $strict);
 243         } else {
 244                 $perl = NFC($perl);
 245                 $perl =~ s{\\}{\\\\}sgo;
 246                 $perl =~ s/"/\\"/sgo;
 247                 $perl =~ s/\t/\\t/sgo;
 248                 $perl =~ s/\f/\\f/sgo;
 249                 $perl =~ s/\r/\\r/sgo;
 250                 $perl =~ s/\n/\\n/sgo;
 251                 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
 252                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
 253                         $output = $perl;
 254                 } else {
 255                         $output = '"'.$perl.'"';
 256                 }
 257         }
 258
 259         return $output;
 260 }
 261
 262 my $depth = 0;
 263 sub perl2prettyJSON {
 264         my ($class, $perl, $nospace) = @_;
 265         $perl ||= $class;
 266
 267         my $output = '';
 268         if (!defined($perl)) {
 269                 $output = "   "x$depth unless($nospace);
 270                 $output .= 'null';
 271         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
 272                 $output = "   "x$depth unless($nospace);
 273                 $output .= $perl;
 274         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
 275                 $depth++;
 276                 $output .= "\n";
 277                 $output .= "   "x$depth;
 278                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
 279                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
 280                         my %hash =  %$perl;
 281                         $output .= perl2prettyJSON(\%hash,undef,1);
 282                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
 283                         my @array =  @$perl;
 284                         $output .= perl2prettyJSON(\@array,undef,1);
 285                 }
 286                 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
 287                 $depth--;
 288         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
 289                 $output .= "   "x$depth unless ($nospace);
 290                 $output .= "{\n";
 291                 my $c = 0;
 292                 $depth++;
 293                 for my $key (sort keys %$perl) {
 294                         $output .= ",\n" if ($c);
 295                         $output .= "   "x$depth;
 296                         $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
 297                         $c++;
 298                 }
 299                 $depth--;
 300                 $output .= "\n";
 301                 $output .= "   "x$depth;
 302                 $output .= '}';
 303         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
 304                 $output .= "   "x$depth unless ($nospace);
 305                 $output .= "[\n";
 306                 my $c = 0;
 307                 $depth++;
 308                 for my $part (@$perl) {
 309                         $output .= ",\n" if ($c);
 310                         $output .= "   "x$depth;
 311                         $output .= perl2prettyJSON($part);
 312                         $c++;
 313                 }
 314                 $depth--;
 315                 $output .= "\n";
 316                 $output .= "   "x$depth;
 317                 $output .= "]";
 318         } elsif (ref($perl) and ref($perl) =~ /CODE/) {
 319                 $output .= perl2prettyJSON(undef,$perl->(), $nospace);
 320         } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
 321                 my $type = $2;
 322                 my $name = $1;
 323                 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
 324                 $output .= perl2prettyJSON(undef,$perl);
 325         } else {
 326                 $perl = NFC($perl);
 327                 $perl =~ s/\\/\\\\/sgo;
 328                 $perl =~ s/"/\\"/sgo;
 329                 $perl =~ s/\t/\\t/sgo;
 330                 $perl =~ s/\f/\\f/sgo;
 331                 $perl =~ s/\r/\\r/sgo;
 332                 $perl =~ s/\n/\\n/sgo;
 333                 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
 334                 $output .= "   "x$depth unless($nospace);
 335                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
 336                         $output = $perl;
 337                 } else {
 338                         $output = '"'.$perl.'"';
 339                 }
 340         }
 341
 342         return $output;
 343 }
 344
 345 1;