src/perlmods/JSON.pm

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