4 my $x = shift || $class;
5 return bless \$x => __PACKAGE__;
8 use overload ( '""' => \&toString );
10 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
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 } );
18 sub toString { 'true' }
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 } );
26 sub toString { 'false' }
29 use vars qw/%_class_map/;
31 sub register_class_hint {
35 $_class_map{hints}{$args{hint}} = \%args;
36 $_class_map{classes}{$args{name}} = \%args;
45 -?\d+\.?\d* | # number literal
46 "(?:(?:\\[\"])|[^\"])*" | # string literal
47 (?:\/\*.+?\*\/) | # C comment
51 : | # object key-value sep
60 sub _json_hint_to_class {
64 return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
66 $type = 'hash' if ($type eq '}');
67 $type = 'array' if ($type eq ']');
69 JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
78 s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
79 s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
80 s/(?<!\\)\%/\\\%/gmo; # fixup % for later
82 # Convert JSON Unicode...
83 s/\\u(\d{4})/chr(hex($1))/esog;
85 # handle class blessings
86 s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
87 s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
89 my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
91 my @strings = /$re/sog;
93 # Replace with code...
94 #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
95 s/$re/ eval shift(\@strings) /sog;
97 # Perlify hash notation
101 # s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
103 # Change javascript stuff to perl...
105 s/true/ bless( {}, "JSON::bool::true") /sog;
106 s/false/ bless( {}, "JSON::bool::false") /sog;
109 return eval '$ret = '.$_;
113 my ($class, $json) = @_;
115 if (!defined($json)) {
119 $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
120 $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
121 $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
124 my $casting_depth = 0;
128 while (($json,$element) = _JSON_regex($json)) {
130 last unless ($element);
132 if ($element eq 'null') {
133 $output .= ' undef() ';
135 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
137 if (exists $_class_map{hints}{$hint}) {
138 $casts[$casting_depth] = $hint;
139 $output .= ' bless(';
142 } elsif ($element =~ /^\/\*/) {
144 } elsif ($element =~ /^\d/) {
145 $output .= "do { JSON::number::new($element) }";
147 } elsif ($element eq '{' or $element eq '[') {
149 } elsif ($element eq '}' or $element eq ']') {
151 my $hint = $casts[$casting_depth];
152 $casts[$casting_depth] = undef;
153 if (defined $hint and exists $_class_map{hints}{$hint}) {
154 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
157 } elsif ($element eq ':') {
160 } elsif ($element eq 'true') {
161 $output .= 'bless( {}, "JSON::bool::true")';
163 } elsif ($element eq 'false') {
164 $output .= 'bless( {}, "JSON::bool::false")';
175 my ($class, $perl, $strict) = @_;
178 if (!defined($perl)) {
179 $output = '' if $strict;
180 $output = 'null' unless $strict;
181 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
183 } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
184 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
185 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
187 $output .= perl2JSON(undef,\%hash, $strict);
188 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
190 $output .= perl2JSON(undef,\@array, $strict);
192 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
193 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
196 for my $key (sort keys %$perl) {
197 $output .= ',' if ($c);
199 $output .= perl2JSON(undef,$key, $strict).':'.perl2JSON(undef,$$perl{$key}, $strict);
203 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
206 for my $part (@$perl) {
207 $output .= ',' if ($c);
209 $output .= perl2JSON(undef,$part, $strict);
213 } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
216 JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
217 $output .= perl2JSON(undef,$perl, $strict);
219 $perl =~ s{\\}{\\\\}sgo;
220 $perl =~ s/"/\\"/sgo;
221 $perl =~ s/\t/\\t/sgo;
222 $perl =~ s/\f/\\f/sgo;
223 $perl =~ s/\r/\\r/sgo;
224 $perl =~ s/\n/\\n/sgo;
225 $perl =~ s/(\pM)/sprintf('\u%0.4x',ord($1))/sgoe;
226 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/) {
229 $output = '"'.$perl.'"';
237 sub perl2prettyJSON {
238 my ($class, $perl, $nospace) = @_;
242 if (!defined($perl)) {
243 $output = " "x$depth unless($nospace);
245 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
246 $output = " "x$depth unless($nospace);
248 } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
251 $output .= " "x$depth;
252 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
253 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
255 $output .= perl2prettyJSON(\%hash,undef,1);
256 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
258 $output .= perl2prettyJSON(\@array,undef,1);
260 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
262 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
263 $output .= " "x$depth unless ($nospace);
267 for my $key (sort keys %$perl) {
268 $output .= ",\n" if ($c);
270 $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
275 $output .= " "x$depth;
277 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
278 $output .= " "x$depth unless ($nospace);
282 for my $part (@$perl) {
283 $output .= ",\n" if ($c);
285 $output .= perl2prettyJSON($part);
290 $output .= " "x$depth;
292 } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
295 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
296 $output .= perl2prettyJSON(undef,$perl);
298 $perl =~ s/\\/\\\\/sgo;
299 $perl =~ s/"/\\"/sgo;
300 $perl =~ s/\t/\\t/sgo;
301 $perl =~ s/\f/\\f/sgo;
302 $perl =~ s/\r/\\r/sgo;
303 $perl =~ s/\n/\\n/sgo;
304 $perl =~ s/(\pM)/sprintf('\u%0.4x',ord($1))/sgoe;
305 $output .= " "x$depth unless($nospace);
306 $output .= '"'.$perl.'"';