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