src/perlmods/JSON.pm

   1 package JSON::number;
   2 sub new {
   3         my $class = shift;
   4         my $x = shift || $class;
   5         return bless \$x => __PACKAGE__;
   6 }
   7 use overload ( '""' => \&toString );
   8 use overload ( '0+' => sub { $_[0]->toString } );
   9 use overload ( '+' => sub { int($_[0]) + int($_[1]) } );
  10 use overload ( '-' => sub { int($_[0]) - int($_[1]) } );
  11 use overload ( '*' => sub { int($_[0]) * int($_[1]) } );
  12 use overload ( '/' => sub { int($_[0]) / int($_[1]) } );
  13 use overload ( '%' => sub { int($_[0]) % int($_[1]) } );
  14 use overload ( '**' => sub { int($_[0]) ** int($_[1]) } );
  15 use overload ( 'neg' => sub { -int($_[0]) } );
  16 use overload ( '==' => sub { int($_[0]->toString) == int($_[1])} );
  17
  18 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
  19
  20 package JSON::bool::true;
  21 sub new { return bless {} => __PACKAGE__ }
  22 use overload ( '""' => \&toString );
  23 use overload ( 'bool' => sub { 1 } );
  24 use overload ( '0+' => sub { 1 } );
  25
  26 sub toString { 'true' }
  27
  28 package JSON::bool::false;
  29 sub new { return bless {} => __PACKAGE__ }
  30 use overload ( '""' => \&toString );
  31 use overload ( 'bool' => sub { 0 } );
  32 use overload ( '0+' => sub { 0 } );
  33
  34 sub toString { 'false' }
  35
  36 package JSON;
  37 use vars qw/%_class_map/;
  38
  39 sub register_class_hint {
  40         my $class = shift;
  41         my %args = @_;
  42
  43         $_class_map{hints}{$args{hint}} = \%args;
  44         $_class_map{classes}{$args{name}} = \%args;
  45 }
  46
  47 sub _JSON_regex {
  48         my $string = shift;
  49
  50         $string =~ s/^\s* (
  51                            {                            | # start object
  52                            \[                           | # start array
  53                            -?\d+\.?\d*                  | # number literal
  54                            "(?:(?:\\[\"])|[^\"])*"      | # string literal
  55                            (?:\/\*.+?\*\/)              | # C comment
  56                            true                         | # bool true
  57                            false                        | # bool false
  58                            null                         | # undef()
  59                            :                            | # object key-value sep
  60                            ,                            | # list sep
  61                            \]                           | # array end
  62                            }                              # object end
  63                         )
  64                  \s*//sox;
  65         return ($string,$1);
  66 }
  67
  68 sub _json_hint_to_class {
  69         my $type = shift;
  70         my $hint = shift;
  71
  72         return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
  73
  74         $type = 'hash' if ($type eq '}');
  75         $type = 'array' if ($type eq ']');
  76
  77         JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
  78
  79         return $hint;
  80 }
  81
  82 sub JSON2perl {
  83         my $class = shift;
  84         local $_ = shift;
  85
  86         s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
  87         s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
  88         s/(?<!\\)\%/\\\%/gmo; # fixup % for later
  89
  90         # Convert JSON Unicode...
  91         s/\\u(\d{4})/chr(hex($1))/esog;
  92
  93         # handle class blessings
  94         s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
  95         s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
  96
  97         my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
  98         # Grab strings...
  99         my @strings = /$re/sog;
 100
 101         # Replace with code...
 102         #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
 103         s/$re/ eval shift(\@strings) /sog;
 104
 105         # Perlify hash notation
 106         s/:/ => /sog;
 107
 108         # Do numbers...
 109         s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
 110
 111         # Change javascript stuff to perl...
 112         s/null/ undef /sog;
 113         s/true/ bless( {}, "JSON::bool::true") /sog;
 114         s/false/ bless( {}, "JSON::bool::false") /sog;
 115
 116         my $ret;
 117         return eval '$ret = '.$_;
 118 }
 119
 120 sub old_JSON2perl {
 121         my ($class, $json) = @_;
 122
 123         if (!defined($json)) {
 124                 return undef;
 125         }
 126
 127         $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
 128         $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
 129         $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
 130
 131         my @casts;
 132         my $casting_depth = 0;
 133         my $current_cast;
 134         my $element;
 135         my $output = '';
 136         while (($json,$element) = _JSON_regex($json)) {
 137
 138                 last unless ($element);
 139
 140                 if ($element eq 'null') {
 141                         $output .= ' undef() ';
 142                         next;
 143                 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
 144                         my $hint = $1;
 145                         if (exists $_class_map{hints}{$hint}) {
 146                                 $casts[$casting_depth] = $hint;
 147                                 $output .= ' bless(';
 148                         }
 149                         next;
 150                 } elsif ($element =~ /^\/\*/) {
 151                         next;
 152                 } elsif ($element =~ /^\d/) {
 153                         $output .= "do { JSON::number::new($element) }";
 154                         next;
 155                 } elsif ($element eq '{' or $element eq '[') {
 156                         $casting_depth++;
 157                 } elsif ($element eq '}' or $element eq ']') {
 158                         $casting_depth--;
 159                         my $hint = $casts[$casting_depth];
 160                         $casts[$casting_depth] = undef;
 161                         if (defined $hint and exists $_class_map{hints}{$hint}) {
 162                                 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
 163                                 next;
 164                         }
 165                 } elsif ($element eq ':') {
 166                         $output .= ' => ';
 167                         next;
 168                 } elsif ($element eq 'true') {
 169                         $output .= 'bless( {}, "JSON::bool::true")';
 170                         next;
 171                 } elsif ($element eq 'false') {
 172                         $output .= 'bless( {}, "JSON::bool::false")';
 173                         next;
 174                 }
 175
 176                 $output .= $element;
 177         }
 178
 179         return eval $output;
 180 }
 181
 182 sub perl2JSON {
 183         my ($class, $perl) = @_;
 184
 185         my $output = '';
 186         if (!defined($perl)) {
 187                 $output = 'null';
 188         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
 189                 $output .= $perl;
 190         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
 191                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
 192                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
 193                         my %hash =  %$perl;
 194                         $output .= perl2JSON(undef,\%hash);
 195                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
 196                         my @array =  @$perl;
 197                         $output .= perl2JSON(undef,\@array);
 198                 }
 199                 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
 200         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
 201                 $output .= '{';
 202                 my $c = 0;
 203                 for my $key (sort keys %$perl) {
 204                         $output .= ',' if ($c);
 205
 206                         $output .= perl2JSON(undef,$key).':'.perl2JSON(undef,$$perl{$key});
 207                         $c++;
 208                 }
 209                 $output .= '}';
 210         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
 211                 $output .= '[';
 212                 my $c = 0;
 213                 for my $part (@$perl) {
 214                         $output .= ',' if ($c);
 215
 216                         $output .= perl2JSON(undef,$part);
 217                         $c++;
 218                 }
 219                 $output .= ']';
 220         } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
 221                 my $type = $2;
 222                 my $name = $1;
 223                 JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
 224                 $output .= perl2JSON(undef,$perl);
 225         } else {
 226                 $perl =~ s{\\}{\\\\}sgo;
 227                 $perl =~ s/"/\\"/sgo;
 228                 $perl =~ s/\t/\\t/sgo;
 229                 $perl =~ s/\f/\\f/sgo;
 230                 $perl =~ s/\r/\\r/sgo;
 231                 $perl =~ s/\n/\\n/sgo;
 232                 $perl =~ s/(\pM)/sprintf('\u%0.4x',ord($1))/sgoe;
 233                 $output = '"'.$perl.'"';
 234         }
 235
 236         return $output;
 237 }
 238
 239 my $depth = 0;
 240 sub perl2prettyJSON {
 241         my ($class, $perl, $nospace) = @_;
 242         $perl ||= $class;
 243
 244         my $output = '';
 245         if (!defined($perl)) {
 246                 $output = "   "x$depth unless($nospace);
 247                 $output .= 'null';
 248         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
 249                 $output = "   "x$depth unless($nospace);
 250                 $output .= $perl;
 251         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
 252                 $depth++;
 253                 $output .= "\n";
 254                 $output .= "   "x$depth;
 255                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
 256                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
 257                         my %hash =  %$perl;
 258                         $output .= perl2prettyJSON(\%hash,undef,1);
 259                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
 260                         my @array =  @$perl;
 261                         $output .= perl2prettyJSON(\@array,undef,1);
 262                 }
 263                 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
 264                 $depth--;
 265         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
 266                 $output .= "   "x$depth unless ($nospace);
 267                 $output .= "{\n";
 268                 my $c = 0;
 269                 $depth++;
 270                 for my $key (sort keys %$perl) {
 271                         $output .= ",\n" if ($c);
 272
 273                         $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
 274                         $c++;
 275                 }
 276                 $depth--;
 277                 $output .= "\n";
 278                 $output .= "   "x$depth;
 279                 $output .= '}';
 280         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
 281                 $output .= "   "x$depth unless ($nospace);
 282                 $output .= "[\n";
 283                 my $c = 0;
 284                 $depth++;
 285                 for my $part (@$perl) {
 286                         $output .= ",\n" if ($c);
 287
 288                         $output .= perl2prettyJSON($part);
 289                         $c++;
 290                 }
 291                 $depth--;
 292                 $output .= "\n";
 293                 $output .= "   "x$depth;
 294                 $output .= "]";
 295         } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
 296                 my $type = $2;
 297                 my $name = $1;
 298                 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
 299                 $output .= perl2prettyJSON(undef,$perl);
 300         } else {
 301                 $perl =~ s/\\/\\\\/sgo;
 302                 $perl =~ s/"/\\"/sgo;
 303                 $perl =~ s/\t/\\t/sgo;
 304                 $perl =~ s/\f/\\f/sgo;
 305                 $perl =~ s/\r/\\r/sgo;
 306                 $perl =~ s/\n/\\n/sgo;
 307                 $perl =~ s/(\pM)/sprintf('\u%0.4x',ord($1))/sgoe;
 308                 $output .= "   "x$depth unless($nospace);
 309                 $output .= '"'.$perl.'"';
 310         }
 311
 312         return $output;
 313 }
 314
 315 1;