Initial revision
[OpenSRF.git] / 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;