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