4 my $x = shift || $class;
5 return bless \$x => __PACKAGE__;
7 use overload ( '""' => \&toString );
8 use overload ( '0+' => sub { $_[0]->toString } );
9 use overload ( '+' => sub { int($_[0]) + int($_[1]) } );
10 use overload ( '-' => sub { int($_[0]) - int($_[1]) } );
11 use overload ( '*' => sub { int($_[0]) * int($_[1]) } );
12 use overload ( '/' => sub { int($_[0]) / int($_[1]) } );
13 use overload ( '%' => sub { int($_[0]) % int($_[1]) } );
14 use overload ( '**' => sub { int($_[0]) ** int($_[1]) } );
15 use overload ( 'neg' => sub { neg(int($_[0])) } );
17 sub toString { defined($_[1]) ? ${$_[1]} : ${$_[0]} }
19 package JSON::bool::true;
20 sub new { return bless {} => __PACKAGE__ }
21 use overload ( '""' => \&toString );
22 use overload ( 'bool' => sub { 1 } );
23 use overload ( '0+' => sub { 1 } );
25 sub toString { 'true' }
27 package JSON::bool::false;
28 sub new { return bless {} => __PACKAGE__ }
29 use overload ( '""' => \&toString );
30 use overload ( 'bool' => sub { 0 } );
31 use overload ( '0+' => sub { 0 } );
33 sub toString { 'false' }
36 use vars qw/%_class_map/;
38 sub register_class_hint {
42 $_class_map{$args{hint}} = \%args;
43 $_class_map{$args{name}} = \%args;
47 my ($class, $json) = @_;
49 if (!defined($json)) {
53 #$json =~ s/\/\/.+$//gmo; # remove C++ comments
54 $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
55 $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
58 my $casting_depth = 0;
61 while ($json =~ s/^\s* (
64 -?\d+\.?\d* | # number literal
65 "(?:(?:\\[\"])|[^\"])*" | # string literal
66 (?:\/\*.+?\*\/) | # C comment
70 : | # object key-value sep
78 if ($element eq 'null') {
79 $output .= ' undef() ';
81 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
83 if (exists $_class_map{$hint}) {
84 $casts[$casting_depth] = $hint;
88 } elsif ($element =~ /^\/\*/) {
90 } elsif ($element =~ /^\d/) {
91 $output .= "do { JSON::number::new($element) }";
93 } elsif ($element eq '{' or $element eq '[') {
95 } elsif ($element eq '}' or $element eq ']') {
97 my $hint = $casts[$casting_depth];
98 $casts[$casting_depth] = undef;
99 if (defined $hint and exists $_class_map{$hint}) {
100 $output .= $element . ',"'. $_class_map{$hint}{name} . '")';
103 } elsif ($element eq ':') {
106 } elsif ($element eq 'true') {
107 $output .= 'bless( {}, "JSON::bool::true")';
109 } elsif ($element eq 'false') {
110 $output .= 'bless( {}, "JSON::bool::false")';
121 my ($class, $perl) = @_;
124 if (!defined($perl)) {
126 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
128 } elsif ( ref($perl) && exists($_class_map{ref($perl)}) ) {
129 $output .= '/*--S '.$_class_map{ref($perl)}{hint}.'--*/';
130 if (lc($_class_map{ref($perl)}{type}) eq 'hash') {
132 $output .= perl2JSON(undef,\%hash);
133 } elsif (lc($_class_map{ref($perl)}{type}) eq 'array') {
135 $output .= perl2JSON(undef,\@array);
137 $output .= '/*--E '.$_class_map{ref($perl)}{hint}.'--*/';
138 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
141 for my $key (sort keys %$perl) {
142 $output .= ',' if ($c);
144 $output .= perl2JSON(undef,$key).':'.perl2JSON(undef,$$perl{$key});
148 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
151 for my $part (@$perl) {
152 $output .= ',' if ($c);
154 $output .= perl2JSON(undef,$part);
159 $perl =~ s/\\/\\\\/sgo;
160 $perl =~ s/"/\\"/sgo;
161 $perl =~ s/\t/\\t/sgo;
162 $perl =~ s/\f/\\f/sgo;
163 $perl =~ s/\r/\\r/sgo;
164 $perl =~ s/\n/\\n/sgo;
165 $output = '"'.$perl.'"';
172 sub perl2prettyJSON {
173 my ($class, $perl, $nospace) = @_;
177 if (!defined($perl)) {
179 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
181 } elsif ( ref($perl) && exists($_class_map{ref($perl)}) ) {
184 $output .= " "x$depth;
185 $output .= '/*--S '.$_class_map{ref($perl)}{hint}."--*/ ";
186 if (lc($_class_map{ref($perl)}{type}) eq 'hash') {
188 $output .= perl2prettyJSON(\%hash,undef,1);
189 } elsif (lc($_class_map{ref($perl)}{type}) eq 'array') {
191 $output .= perl2prettyJSON(\@array,undef,1);
193 #$output .= " "x$depth;
194 $output .= ' /*--E '.$_class_map{ref($perl)}{hint}.'--*/';
196 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
198 $output .= " "x$depth unless ($nospace);
202 for my $key (sort keys %$perl) {
203 $output .= ",\n" if ($c);
205 $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
210 $output .= " "x$depth;
213 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
215 $output .= " "x$depth unless ($nospace);
219 for my $part (@$perl) {
220 $output .= ",\n" if ($c);
222 $output .= perl2prettyJSON($part);
227 $output .= " "x$depth;
231 $perl =~ s/\\/\\\\/sgo;
232 $perl =~ s/"/\\"/sgo;
233 $perl =~ s/\t/\\t/sgo;
234 $perl =~ s/\f/\\f/sgo;
235 $perl =~ s/\r/\\r/sgo;
236 $perl =~ s/\n/\\n/sgo;
237 $output .= " "x$depth unless($nospace);
238 $output .= '"'.$perl.'"';