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