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