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