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