4 my $x = shift || $class;
5 return bless \$x => __PACKAGE__;
7 use overload ( '""' => \&toString );
8 use overload ( '0+' => sub { ${$_[0]} } );
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{$args{hint}} = \%args;
36 $_class_map{$args{name}} = \%args;
40 my ($class, $json) = @_;
43 #$json =~ s/\/\/.+$//gmo; # remove C++ comments
44 $json =~ s/(?<!\\)\$/\\\$/gmo; # fixup $ for later
45 $json =~ s/(?<!\\)\@/\\\@/gmo; # fixup @ for later
48 my $casting_depth = 0;
51 while ($json =~ s/^\s* (
54 -?\d+\.?\d* | # number literal
55 "(?:(?:\\[\"])|[^\"])+" | # string literal
56 (?:\/\*.+?\*\/) | # C comment
60 : | # object key-value sep
68 if ($element eq 'null') {
69 $output .= ' undef() ';
71 } elsif ($element =~ /^\/\*--\s*S\w*?\s+(\w+)\s*--\*\/$/) {
73 if (exists $_class_map{$hint}) {
74 $casts[$casting_depth] = $hint;
78 } elsif ($element =~ /^\/\*/) {
80 } elsif ($element =~ /^\d/) {
81 $output .= "do { JSON::number::new($element) }";
83 } elsif ($element eq '{' or $element eq '[') {
85 } elsif ($element eq '}' or $element eq ']') {
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} . '")';
93 } elsif ($element eq ':') {
96 } elsif ($element eq 'true') {
97 $output .= 'bless( {}, "JSON::bool::true")';
99 } elsif ($element eq 'false') {
100 $output .= 'bless( {}, "JSON::bool::false")';
111 my ($class, $perl) = @_;
115 if (!defined($perl)) {
117 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
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') {
123 $output .= perl2JSON(\%hash);
124 } elsif (lc($_class_map{ref($perl)}{type}) eq 'array') {
126 $output .= perl2JSON(\@array);
128 $output .= '/*--E '.$_class_map{ref($perl)}{hint}.'--*/';
129 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
132 for my $key (sort keys %$perl) {
133 $output .= ',' if ($c);
135 $output .= perl2JSON($key).':'.perl2JSON($$perl{$key});
139 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
142 for my $part (@$perl) {
143 $output .= ',' if ($c);
145 $output .= perl2JSON($part);
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.'"';
163 sub perl2prettyJSON {
164 my ($class, $perl, $nospace) = @_;
168 if (!defined($perl)) {
170 } elsif (ref($perl) and ref($perl) =~ /^JSON/) {
172 } elsif ( ref($perl) && exists($_class_map{ref($perl)}) ) {
175 $output .= " "x$depth;
176 $output .= '/*--S '.$_class_map{ref($perl)}{hint}."--*/ ";
177 if (lc($_class_map{ref($perl)}{type}) eq 'hash') {
179 $output .= perl2prettyJSON(\%hash,undef,1);
180 } elsif (lc($_class_map{ref($perl)}{type}) eq 'array') {
182 $output .= perl2prettyJSON(\@array,undef,1);
184 #$output .= " "x$depth;
185 $output .= ' /*--E '.$_class_map{ref($perl)}{hint}.'--*/';
187 } elsif (ref($perl) and ref($perl) =~ /HASH/) {
189 $output .= " "x$depth unless ($nospace);
193 for my $key (sort keys %$perl) {
194 $output .= ",\n" if ($c);
196 $output .= perl2prettyJSON($key)." : ".perl2prettyJSON($$perl{$key}, undef, 1);
201 $output .= " "x$depth;
204 } elsif (ref($perl) and ref($perl) =~ /ARRAY/) {
206 $output .= " "x$depth unless ($nospace);
210 for my $part (@$perl) {
211 $output .= ",\n" if ($c);
213 $output .= perl2prettyJSON($part);
218 $output .= " "x$depth;
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.'"';