File Coverage

lib/JSON.pm
Criterion Covered Total %
statement 79 190 41.5
branch 15 86 17.4
condition 3 39 7.6
subroutine 16 28 57.1
pod 8 13 61.5
total 121 356 33.9


line stmt bran cond sub pod time code
1             package JSON;
2              
3              
4             use strict;
5             use Carp ();
6             use base qw(Exporter);
7             @JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);
8              
9             BEGIN {
10             $JSON::VERSION = '2.90';
11             $JSON::DEBUG = 0 unless (defined $JSON::DEBUG);
12             $JSON::DEBUG = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG };
13 1 50 33 1 0 9 }
  1 50 33 1 1 2  
  1 50 0 1 1 41  
  1 50 0 1 0 4  
  1 50 0 1 0 1  
  1 0 33 1 1 18  
  1 0 0 1 1 3  
  1 0 0 1 1 1  
  1 50 0 0 1 162  
  1 50 0 1 0 2  
  1 50 0 1 0 4  
  1 50 0 4 1 1394  
  1 50 0 1 1 9  
  1 50   1   2  
  1 0   0   447  
  1 0   0   6  
  1 0   1   1  
  1 0   1   85  
  1 0   0   221  
  0 50   1   0  
  0 50   0   0  
  1 50   0   1072  
  1 0   0   17327  
  1 0   0   31  
  0 0   0   0  
  0 0   0   0  
  0 0   0   0  
  0 0   0   0  
  0 0       0  
  0 0       0  
  0 50       0  
  0 0       0  
  1 0       3  
  1 0       4  
  1 0       4  
  1 0       5  
  1 0       3  
  1 0       5  
  0 0       0  
  1 0       132  
  1 0       18  
  0 0       0  
  0 0       0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         5  
  1         4  
  1         6  
  1         2  
  1         3  
  1         2  
  1         2  
  1         57  
  1         5  
  1         10  
  1         4  
  1         8  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  4         5  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         3  
  1         2  
  1         4  
  1         1  
  1         5  
  1         2  
  1         3  
  1         15  
  1         6  
  0         0  
  0         0  
  0         0  
  1         2  
  1         4  
  1         4  
  1         5  
  1         4  
  1         8  
  1         3  
  1         1  
  1         5  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         3  
  1         1  
  1         3  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  0         0  
  1         3  
  1         131  
  1         2  
  1         1  
  1         4  
  1         4  
  1         2  
  1         2  
  1         3  
  1         3  
  1         4  
  1         3  
  1         3  
  1         3  
  0         0  
  1         5  
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
  0            
14              
15             my $Module_XS = 'JSON::XS';
16             my $Module_PP = 'JSON::PP';
17             my $Module_bp = 'JSON::backportPP'; # included in JSON distribution
18             my $PP_Version = '2.27203';
19             my $XS_Version = '2.34';
20              
21              
22             # XS and PP common methods
23              
24             my @PublicMethods = qw/
25             ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref
26             allow_blessed convert_blessed filter_json_object filter_json_single_key_object
27             shrink max_depth max_size encode decode decode_prefix allow_unknown
28             /;
29              
30             my @Properties = qw/
31             ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref
32             allow_blessed convert_blessed shrink max_depth max_size allow_unknown
33             /;
34              
35             my @XSOnlyMethods = qw/allow_tags/; # Currently nothing
36              
37             my @PPOnlyMethods = qw/
38             indent_length sort_by
39             allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed
40             /; # JSON::PP specific
41              
42              
43             # used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently)
44             my $_INSTALL_DONT_DIE = 1; # When _load_xs fails to load XS, don't die.
45             my $_INSTALL_ONLY = 2; # Don't call _set_methods()
46             my $_ALLOW_UNSUPPORTED = 0;
47             my $_UNIV_CONV_BLESSED = 0;
48             my $_USSING_bpPP = 0;
49              
50              
51             # Check the environment variable to decide worker module.
52              
53             unless ($JSON::Backend) {
54             $JSON::DEBUG and Carp::carp("Check used worker module...");
55              
56             my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1;
57              
58             if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) {
59             _load_xs($_INSTALL_DONT_DIE) or _load_pp();
60             }
61             elsif ($backend eq '0' or $backend eq 'JSON::PP') {
62             _load_pp();
63             }
64             elsif ($backend eq '2' or $backend eq 'JSON::XS') {
65             _load_xs();
66             }
67             elsif ($backend eq 'JSON::backportPP') {
68             $_USSING_bpPP = 1;
69             _load_pp();
70             }
71             else {
72             Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
73             }
74             }
75              
76              
77             sub import {
78             my $pkg = shift;
79             my @what_to_export;
80             my $no_export;
81              
82             for my $tag (@_) {
83             if ($tag eq '-support_by_pp') {
84             if (!$_ALLOW_UNSUPPORTED++) {
85             JSON::Backend::XS
86             ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS);
87             }
88             next;
89             }
90             elsif ($tag eq '-no_export') {
91             $no_export++, next;
92             }
93             elsif ( $tag eq '-convert_blessed_universally' ) {
94             eval q|
95             require B;
96             *UNIVERSAL::TO_JSON = sub {
97             my $b_obj = B::svref_2object( $_[0] );
98             return $b_obj->isa('B::HV') ? { %{ $_[0] } }
99             : $b_obj->isa('B::AV') ? [ @{ $_[0] } ]
100             : undef
101             ;
102             }
103             | if ( !$_UNIV_CONV_BLESSED++ );
104             next;
105             }
106             push @what_to_export, $tag;
107             }
108              
109             return if ($no_export);
110              
111             __PACKAGE__->export_to_level(1, $pkg, @what_to_export);
112             }
113              
114              
115             # OBSOLETED
116              
117             sub jsonToObj {
118             my $alternative = 'from_json';
119             if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
120             shift @_; $alternative = 'decode';
121             }
122             Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead.";
123             return JSON::from_json(@_);
124             };
125              
126             sub objToJson {
127             my $alternative = 'to_json';
128             if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
129             shift @_; $alternative = 'encode';
130             }
131             Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead.";
132             JSON::to_json(@_);
133             };
134              
135              
136             # INTERFACES
137              
138             sub to_json ($@) {
139             if (
140             ref($_[0]) eq 'JSON'
141             or (@_ > 2 and $_[0] eq 'JSON')
142             ) {
143             Carp::croak "to_json should not be called as a method.";
144             }
145             my $json = JSON->new;
146              
147             if (@_ == 2 and ref $_[1] eq 'HASH') {
148             my $opt = $_[1];
149             for my $method (keys %$opt) {
150             $json->$method( $opt->{$method} );
151             }
152             }
153              
154             $json->encode($_[0]);
155             }
156              
157              
158             sub from_json ($@) {
159             if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) {
160             Carp::croak "from_json should not be called as a method.";
161             }
162             my $json = JSON->new;
163              
164             if (@_ == 2 and ref $_[1] eq 'HASH') {
165             my $opt = $_[1];
166             for my $method (keys %$opt) {
167             $json->$method( $opt->{$method} );
168             }
169             }
170              
171             return $json->decode( $_[0] );
172             }
173              
174              
175              
176             sub true { $JSON::true }
177              
178             sub false { $JSON::false }
179              
180             sub null { undef; }
181              
182              
183             sub require_xs_version { $XS_Version; }
184              
185             sub backend {
186             my $proto = shift;
187             $JSON::Backend;
188             }
189              
190             #*module = *backend;
191              
192              
193             sub is_xs {
194             return $_[0]->backend eq $Module_XS;
195             }
196              
197              
198             sub is_pp {
199             return not $_[0]->is_xs;
200             }
201              
202              
203             sub pureperl_only_methods { @PPOnlyMethods; }
204              
205              
206             sub property {
207             my ($self, $name, $value) = @_;
208              
209             if (@_ == 1) {
210             my %props;
211             for $name (@Properties) {
212             my $method = 'get_' . $name;
213             if ($name eq 'max_size') {
214             my $value = $self->$method();
215             $props{$name} = $value == 1 ? 0 : $value;
216             next;
217             }
218             $props{$name} = $self->$method();
219             }
220             return \%props;
221             }
222             elsif (@_ > 3) {
223             Carp::croak('property() can take only the option within 2 arguments.');
224             }
225             elsif (@_ == 2) {
226             if ( my $method = $self->can('get_' . $name) ) {
227             if ($name eq 'max_size') {
228             my $value = $self->$method();
229             return $value == 1 ? 0 : $value;
230             }
231             $self->$method();
232             }
233             }
234             else {
235             $self->$name($value);
236             }
237              
238             }
239              
240              
241              
242             # INTERNAL
243              
244             sub _load_xs {
245             my $opt = shift;
246              
247             $JSON::DEBUG and Carp::carp "Load $Module_XS.";
248              
249             # if called after install module, overload is disable.... why?
250             JSON::Boolean::_overrride_overload($Module_XS);
251             JSON::Boolean::_overrride_overload($Module_PP);
252              
253             eval qq|
254             use $Module_XS $XS_Version ();
255             |;
256              
257             if ($@) {
258             if (defined $opt and $opt & $_INSTALL_DONT_DIE) {
259             $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)";
260             return 0;
261             }
262             Carp::croak $@;
263             }
264              
265             unless (defined $opt and $opt & $_INSTALL_ONLY) {
266             _set_module( $JSON::Backend = $Module_XS );
267             my $data = join("", ); # this code is from Jcode 2.xx.
268             close(DATA);
269             eval $data;
270             JSON::Backend::XS->init;
271             }
272              
273             return 1;
274             };
275              
276              
277             sub _load_pp {
278             my $opt = shift;
279             my $backend = $_USSING_bpPP ? $Module_bp : $Module_PP;
280              
281             $JSON::DEBUG and Carp::carp "Load $backend.";
282              
283             # if called after install module, overload is disable.... why?
284             JSON::Boolean::_overrride_overload($Module_XS);
285             JSON::Boolean::_overrride_overload($backend);
286              
287             if ( $_USSING_bpPP ) {
288             eval qq| require $backend |;
289             }
290             else {
291             eval qq| use $backend $PP_Version () |;
292             }
293              
294             if ($@) {
295             if ( $backend eq $Module_PP ) {
296             $JSON::DEBUG and Carp::carp "Can't load $Module_PP ($@), so try to load $Module_bp";
297             $_USSING_bpPP++;
298             $backend = $Module_bp;
299             JSON::Boolean::_overrride_overload($backend);
300             local $^W; # if PP installed but invalid version, backportPP redefines methods.
301             eval qq| require $Module_bp |;
302             }
303             Carp::croak $@ if $@;
304             }
305              
306             unless (defined $opt and $opt & $_INSTALL_ONLY) {
307             _set_module( $JSON::Backend = $Module_PP ); # even if backportPP, set $Backend with 'JSON::PP'
308             JSON::Backend::PP->init;
309             }
310             };
311              
312              
313             sub _set_module {
314             return if defined $JSON::true;
315              
316             my $module = shift;
317              
318             local $^W;
319             no strict qw(refs);
320              
321             $JSON::true = ${"$module\::true"};
322             $JSON::false = ${"$module\::false"};
323              
324             push @JSON::ISA, $module;
325             if ( JSON->is_xs and JSON->backend->VERSION < 3 ) {
326             eval 'package JSON::PP::Boolean';
327             push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean);
328             }
329              
330             *{"JSON::is_bool"} = \&{"$module\::is_bool"};
331              
332             for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) {
333             *{"JSON::$method"} = sub {
334             Carp::carp("$method is not supported in $module.");
335             $_[0];
336             };
337             }
338              
339             return 1;
340             }
341              
342              
343              
344             #
345             # JSON Boolean
346             #
347              
348             package JSON::Boolean;
349              
350             my %Installed;
351              
352             sub _overrride_overload {
353             return; # this function is currently disable.
354             return if ($Installed{ $_[0] }++);
355              
356             my $boolean = $_[0] . '::Boolean';
357              
358             eval sprintf(q|
359             package %s;
360             use overload (
361             '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' },
362             'eq' => sub {
363             my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]);
364             if ($op eq 'true' or $op eq 'false') {
365             return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op;
366             }
367             else {
368             return $obj ? 1 == $op : 0 == $op;
369             }
370             },
371             );
372             |, $boolean);
373              
374             if ($@) { Carp::croak $@; }
375              
376             if ( exists $INC{'JSON/XS.pm'} and $boolean eq 'JSON::XS::Boolean' ) {
377             local $^W;
378             my $true = do { bless \(my $dummy = 1), $boolean };
379             my $false = do { bless \(my $dummy = 0), $boolean };
380             *JSON::XS::true = sub () { $true };
381             *JSON::XS::false = sub () { $false };
382             }
383             elsif ( exists $INC{'JSON/PP.pm'} and $boolean eq 'JSON::PP::Boolean' ) {
384             local $^W;
385             my $true = do { bless \(my $dummy = 1), $boolean };
386             my $false = do { bless \(my $dummy = 0), $boolean };
387             *JSON::PP::true = sub { $true };
388             *JSON::PP::false = sub { $false };
389             }
390              
391             return 1;
392             }
393              
394              
395             #
396             # Helper classes for Backend Module (PP)
397             #
398              
399             package JSON::Backend::PP;
400              
401             sub init {
402             local $^W;
403             no strict qw(refs); # this routine may be called after JSON::Backend::XS init was called.
404             *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"};
405             *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"};
406             *{"JSON::PP::is_xs"} = sub { 0 };
407             *{"JSON::PP::is_pp"} = sub { 1 };
408             return 1;
409             }
410              
411             #
412             # To save memory, the below lines are read only when XS backend is used.
413             #
414              
415             package JSON;
416              
417             1;
418             __DATA__