OpenSRF/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
   8 use overload ( '""' => \&toString );
   9
  10 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
  11
  12 package JSON::bool::true;
  13 sub new { return bless {} => __PACKAGE__ }
  14 use overload ( '""' => \&toString );
  15 use overload ( 'bool' => sub { 1 } );
  16 use overload ( '0+' => sub { 1 } );
  17
  18 sub toString { 'true' }
  19
  20 package JSON::bool::false;
  21 sub new { return bless {} => __PACKAGE__ }
  22 use overload ( '""' => \&toString );
  23 use overload ( 'bool' => sub { 0 } );
  24 use overload ( '0+' => sub { 0 } );
  25
  26 sub toString { 'false' }
  27
  28 package JSON;
  29 use vars qw/%_class_map/;
  30
  31 sub register_class_hint {
  32         my $class = shift;
  33         my %args = @_;
  34
  35         $_class_map{hints}{$args{hint}} = \%args;
  36         $_class_map{classes}{$args{name}} = \%args;
  37 }
  38
  39 sub _JSON_regex {
  40         my $string = shift;
  41
  42         $string =~ s/^\s* (
  43                            {                            | # start object
  44                            \[                           | # start array
  45                            -?\d+\.?\d*                  | # number literal
  46                            "(?:(?:\\[\"])|[^\"])*"      | # string literal
  47                            (?:\/\*.+?\*\/)              | # C comment
  48                            true                         | # bool true
  49                            false                        | # bool false
  50                            null                         | # undef()
  51                            :                            | # object key-value sep
  52                            ,                            | # list sep
  53                            \]                           | # array end
  54                            }                              # object end
  55                         )
  56                  \s*//sox;
  57         return ($string,$1);
  58 }
  59
  60 sub _json_hint_to_class {
  61         my $type = shift;
  62         my $hint = shift;
  63
  64         return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
  65
  66         $type = 'hash' if ($type eq '}');
  67         $type = 'array' if ($type eq ']');
  68
  69         JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
  70
  71         return $hint;
  72 }
  73
  74 sub JSON2perl {
  75         my $class = shift;
  76         local $_ = shift;
  77
  78         s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
  79         s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
  80         s/(?<!\\)\%/\\\%/gmo; # fixup % for later
  81
  82         # Convert JSON Unicode...
  83         s/\\u(\d{4})/chr(hex($1))/esog;
  84
  85         # handle class blessings
  86         s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
  87         s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
  88
  89         my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
  90         # Grab strings...
  91         my @strings = /$re/sog;
  92
  93         # Replace with code...
  94         #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
  95         s/$re/ eval shift(\@strings) /sog;
  96
  97         # Perlify hash notation
  98         s/:/ => /sog;
  99
 100         # Do numbers...
 101 #       s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
 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         my $ret;
 109         return eval '$ret = '.$_;
 110 }
 111
 112 sub old_JSON2perl {
 113         my ($class, $json) = @_;
 114
 115         if (!defined($json)) {
 116                 return undef;
 117         }
 118
 119         $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
 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, $strict) = @_;
 176
 177         my $output = '';
 178         if (!defined($perl)) {
 179                 $output = '' if $strict;
 180                 $output = 'null' unless $strict;
 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, $strict);
 188                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
 189                         my @array =  @$perl;
 190                         $output .= perl2JSON(undef,\@array, $strict);
 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                         my $outkey = $key;
 198                         $output .= ',' if ($c);
 199
 200                         $outkey =~ s{\\}{\\\\}sgo;
 201                         $outkey =~ s/"/\\"/sgo;
 202                         $outkey =~ s/\t/\\t/sgo;
 203                         $outkey =~ s/\f/\\f/sgo;
 204                         $outkey =~ s/\r/\\r/sgo;
 205                         $outkey =~ s/\n/\\n/sgo;
 206                         $outkey =~ s/(\pM)/sprintf('\u%0.4x',ord($1))/sgoe;
 207
 208                         $output .= '"'.$outkey.'":'. perl2JSON(undef,$$perl{$key}, $strict);
 209                         $c++;
 210                 }
 211                 $output .= '}';
 212         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
 213                 $output .= '[';
 214                 my $c = 0;
 215                 for my $part (@$perl) {
 216                         $output .= ',' if ($c);
 217
 218                         $output .= perl2JSON(undef,$part, $strict);
 219                         $c++;
 220                 }
 221                 $output .= ']';
 222         } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
 223                 my $type = $2;
 224                 my $name = $1;
 225                 JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
 226                 $output .= perl2JSON(undef,$perl, $strict);
 227         } else {
 228                 $perl =~ s{\\}{\\\\}sgo;
 229                 $perl =~ s/"/\\"/sgo;
 230                 $perl =~ s/\t/\\t/sgo;
 231                 $perl =~ s/\f/\\f/sgo;
 232                 $perl =~ s/\r/\\r/sgo;
 233                 $perl =~ s/\n/\\n/sgo;
 234                 $perl =~ s/(\pM)/sprintf('\u%0.4x',ord($1))/sgoe;
 235                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
 236                         $output = $perl;
 237                 } else {
 238                         $output = '"'.$perl.'"';
 239                 }
 240         }
 241
 242         return $output;
 243 }
 244
 245 my $depth = 0;
 246 sub perl2prettyJSON {
 247         my ($class, $perl, $nospace) = @_;
 248         $perl ||= $class;
 249
 250         my $output = '';
 251         if (!defined($perl)) {
 252                 $output = "   "x$depth unless($nospace);
 253                 $output .= 'null';
 254         } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
 255                 $output = "   "x$depth unless($nospace);
 256                 $output .= $perl;
 257         } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
 258                 $depth++;
 259                 $output .= "\n";
 260                 $output .= "   "x$depth;
 261                 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
 262                 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
 263                         my %hash =  %$perl;
 264                         $output .= perl2prettyJSON(\%hash,undef,1);
 265                 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
 266                         my @array =  @$perl;
 267                         $output .= perl2prettyJSON(\@array,undef,1);
 268                 }
 269                 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
 270                 $depth--;
 271         } elsif (ref($perl) and ref($perl) =~ /HASH/) {
 272                 $output .= "   "x$depth unless ($nospace);
 273                 $output .= "{\n";
 274                 my $c = 0;
 275                 $depth++;
 276                 for my $key (sort keys %$perl) {
 277                         $output .= ",\n" if ($c);
 278
 279                         $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
 280                         $c++;
 281                 }
 282                 $depth--;
 283                 $output .= "\n";
 284                 $output .= "   "x$depth;
 285                 $output .= '}';
 286         } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
 287                 $output .= "   "x$depth unless ($nospace);
 288                 $output .= "[\n";
 289                 my $c = 0;
 290                 $depth++;
 291                 for my $part (@$perl) {
 292                         $output .= ",\n" if ($c);
 293
 294                         $output .= perl2prettyJSON($part);
 295                         $c++;
 296                 }
 297                 $depth--;
 298                 $output .= "\n";
 299                 $output .= "   "x$depth;
 300                 $output .= "]";
 301         } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
 302                 my $type = $2;
 303                 my $name = $1;
 304                 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
 305                 $output .= perl2prettyJSON(undef,$perl);
 306         } else {
 307                 $perl =~ s/\\/\\\\/sgo;
 308                 $perl =~ s/"/\\"/sgo;
 309                 $perl =~ s/\t/\\t/sgo;
 310                 $perl =~ s/\f/\\f/sgo;
 311                 $perl =~ s/\r/\\r/sgo;
 312                 $perl =~ s/\n/\\n/sgo;
 313                 $perl =~ s/(\pM)/sprintf('\u%0.4x',ord($1))/sgoe;
 314                 $output .= "   "x$depth unless($nospace);
 315                 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
 316                         $output = $perl;
 317                 } else {
 318                         $output = '"'.$perl.'"';
 319                 }
 320                 $output .= '"'.$perl.'"';
 321         }
 322
 323         return $output;
 324 }
 325
 326 1;