5 my $x = shift || $class;
6 return bless \$x => __PACKAGE__;
9 use overload ( '""' => \&toString );
11 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
13 package JSON::bool::true;
14 sub new { return bless {} => __PACKAGE__ }
15 use overload ( '""' => \&toString );
16 use overload ( 'bool' => sub { 1 } );
17 use overload ( '0+' => sub { 1 } );
19 sub toString { 'true' }
21 package JSON::bool::false;
22 sub new { return bless {} => __PACKAGE__ }
23 use overload ( '""' => \&toString );
24 use overload ( 'bool' => sub { 0 } );
25 use overload ( '0+' => sub { 0 } );
27 sub toString { 'false' }
30 use Unicode::Normalize;
31 use vars qw/%_class_map/;
33 sub register_class_hint {
37 $_class_map{hints}{$args{hint}} = \%args;
38 $_class_map{classes}{$args{name}} = \%args;
47 -?\d+\.?\d* | # number literal
48 "(?:(?:\\[\"])|[^\"])*" | # string literal
49 (?:\/\*.+?\*\/) | # C comment
53 : | # object key-value sep
65 return $_class_map{hints}{$hint}{name}
71 return $_class_map{classes}{$class}{hint}
74 sub _json_hint_to_class {
78 return $_class_map{hints}{$hint}{name} if (exists $_class_map{hints}{$hint});
80 $type = 'hash' if ($type eq '}');
81 $type = 'array' if ($type eq ']');
83 JSON->register_class_hint(name => $hint, hint => $hint, type => $type);
92 s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
93 s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
94 s/(?<!\\)\%/\\\%/gmo; # fixup % for later
96 # Convert JSON Unicode...
97 s/\\u([0-9a-fA-F]{4})/chr(hex($1))/esog;
99 # handle class blessings
100 s/\/\*--\s*S\w*?\s+\S+\s*--\*\// bless(/sog;
101 s/(\]|\}|")\s*\/\*--\s*E\w*?\s+(\S+)\s*--\*\//$1 => _json_hint_to_class("$1", "$2")) /sog;
103 my $re = qr/((?<!\\)"(?>(?<=\\)"|[^"])*(?<!\\)")/;
105 my @strings = /$re/sog;
107 # Replace with code...
108 #s/"(?:(?:\\[\"])|[^\"])*"/ do{ \$t = '"'.shift(\@strings).'"'; eval \$t;} /sog;
109 s/$re/ eval shift(\@strings) /sog;
111 # Perlify hash notation
115 #s/\b(-?\d+\.?\d*)\b/ JSON::number::new($1) /sog;
117 # Change javascript stuff to perl...
119 s/true/ bless( {}, "JSON::bool::true") /sog;
120 s/false/ bless( {}, "JSON::bool::false") /sog;
123 return eval '$ret = '.$_;
127 my ($class, $json) = @_;
129 if (!defined($json)) {
133 $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
134 $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
135 $json =~ s/(?<!\\)\%/\\\%/gmo; # fixup % for later
138 my $casting_depth = 0;
142 while (($json,$element) = _JSON_regex($json)) {
144 last unless ($element);
146 if ($element eq 'null') {
147 $output .= ' undef() ';
149 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
151 if (exists $_class_map{hints}{$hint}) {
152 $casts[$casting_depth] = $hint;
153 $output .= ' bless(';
156 } elsif ($element =~ /^\/\*/) {
158 } elsif ($element =~ /^\d/) {
159 $output .= "do { JSON::number::new($element) }";
161 } elsif ($element eq '{' or $element eq '[') {
163 } elsif ($element eq '}' or $element eq ']') {
165 my $hint = $casts[$casting_depth];
166 $casts[$casting_depth] = undef;
167 if (defined $hint and exists $_class_map{hints}{$hint}) {
168 $output .= $element . ',"'. $_class_map{hints}{$hint}{name} . '")';
171 } elsif ($element eq ':') {
174 } elsif ($element eq 'true') {
175 $output .= 'bless( {}, "JSON::bool::true")';
177 } elsif ($element eq 'false') {
178 $output .= 'bless( {}, "JSON::bool::false")';
189 my ($class, $perl, $strict) = @_;
192 if (!defined($perl)) {
193 $output = '' if $strict;
194 $output = 'null' unless $strict;
195 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
197 } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
198 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
199 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
201 $output .= perl2JSON(undef,\%hash, $strict);
202 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
204 $output .= perl2JSON(undef,\@array, $strict);
206 $output .= '/*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
207 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
210 for my $key (sort keys %$perl) {
211 my $outkey = NFC($key);
212 $output .= ',' if ($c);
214 $outkey =~ s{\\}{\\\\}sgo;
215 $outkey =~ s/"/\\"/sgo;
216 $outkey =~ s/\t/\\t/sgo;
217 $outkey =~ s/\f/\\f/sgo;
218 $outkey =~ s/\r/\\r/sgo;
219 $outkey =~ s/\n/\\n/sgo;
220 $outkey =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
222 $output .= '"'.$outkey.'":'. perl2JSON(undef,$$perl{$key}, $strict);
226 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
229 for my $part (@$perl) {
230 $output .= ',' if ($c);
232 $output .= perl2JSON(undef,$part, $strict);
236 } elsif (ref($perl) and ref($perl) =~ /CODE/) {
237 $output .= perl2JSON(undef,$perl->(), $strict);
238 } elsif (ref($perl) and ("$perl" =~ /^([^=]+)=(\w+)/o)) {
241 JSON->register_class_hint(name => $name, hint => $name, type => lc($type));
242 $output .= perl2JSON(undef,$perl, $strict);
245 $perl =~ s{\\}{\\\\}sgo;
246 $perl =~ s/"/\\"/sgo;
247 $perl =~ s/\t/\\t/sgo;
248 $perl =~ s/\f/\\f/sgo;
249 $perl =~ s/\r/\\r/sgo;
250 $perl =~ s/\n/\\n/sgo;
251 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
252 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
255 $output = '"'.$perl.'"';
263 sub perl2prettyJSON {
264 my ($class, $perl, $nospace) = @_;
268 if (!defined($perl)) {
269 $output = " "x$depth unless($nospace);
271 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
272 $output = " "x$depth unless($nospace);
274 } elsif ( ref($perl) && exists($_class_map{classes}{ref($perl)}) ) {
277 $output .= " "x$depth;
278 $output .= '/*--S '.$_class_map{classes}{ref($perl)}{hint}."--*/ ";
279 if (lc($_class_map{classes}{ref($perl)}{type}) eq 'hash') {
281 $output .= perl2prettyJSON(\%hash,undef,1);
282 } elsif (lc($_class_map{classes}{ref($perl)}{type}) eq 'array') {
284 $output .= perl2prettyJSON(\@array,undef,1);
286 $output .= ' /*--E '.$_class_map{classes}{ref($perl)}{hint}.'--*/';
288 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
289 $output .= " "x$depth unless ($nospace);
293 for my $key (sort keys %$perl) {
294 $output .= ",\n" if ($c);
295 $output .= " "x$depth;
296 $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
301 $output .= " "x$depth;
303 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
304 $output .= " "x$depth unless ($nospace);
308 for my $part (@$perl) {
309 $output .= ",\n" if ($c);
310 $output .= " "x$depth;
311 $output .= perl2prettyJSON($part);
316 $output .= " "x$depth;
318 } elsif (ref($perl) and ref($perl) =~ /CODE/) {
319 $output .= perl2prettyJSON(undef,$perl->(), $nospace);
320 } elsif (ref($perl) and "$perl" =~ /^([^=]+)=(\w{4,5})\(0x/) {
323 register_class_hint(undef, name => $name, hint => $name, type => lc($type));
324 $output .= perl2prettyJSON(undef,$perl);
327 $perl =~ s/\\/\\\\/sgo;
328 $perl =~ s/"/\\"/sgo;
329 $perl =~ s/\t/\\t/sgo;
330 $perl =~ s/\f/\\f/sgo;
331 $perl =~ s/\r/\\r/sgo;
332 $perl =~ s/\n/\\n/sgo;
333 $perl =~ s/([\x{0080}-\x{fffd}])/sprintf('\u%0.4x',ord($1))/sgoe;
334 $output .= " "x$depth unless($nospace);
335 if (length($perl) < 10 and $perl =~ /^(?:\+|-)?\d*\.?\d+$/o and $perl !~ /^(?:\+|-)?0\d+/o ) {
338 $output = '"'.$perl.'"';