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