File Coverage

blib/lib/CGI/Ex/JSONDump.pm
Criterion Covered Total %
statement 61 62 98.3
branch 58 66 87.8
condition 32 37 86.4
subroutine 7 7 100.0
pod 4 4 100.0
total 162 176 92.0


line stmt bran cond sub pod time code
1             package CGI::Ex::JSONDump;
2              
3             =head1 NAME
4              
5             CGI::Ex::JSONDump - Comprehensive data to JSON dump.
6              
7             =head1 VERSION
8              
9             version 2.52
10              
11             =cut
12              
13             ###----------------------------------------------------------------###
14             # Copyright - Paul Seamons #
15             # Distributed under the Perl Artistic License without warranty #
16             ###----------------------------------------------------------------###
17              
18 2     2   637 use strict;
  2         3  
  2         63  
19 2     2   10 use Exporter qw(import);
  2         3  
  2         2167  
20              
21             our $VERSION = '2.52'; # VERSION
22             our @EXPORT = qw(JSONDump);
23             our @EXPORT_OK = @EXPORT;
24              
25             sub JSONDump {
26 54     54 1 1273 my ($data, $args) = @_;
27 54         141 return __PACKAGE__->new($args)->dump($data);
28             }
29              
30             ###----------------------------------------------------------------###
31              
32             sub new {
33 57   50 57 1 128 my $class = shift || __PACKAGE__;
34 57   100     127 my $args = shift || {};
35 57         189 my $self = bless {%$args}, $class;
36              
37 1         5 $self->{'skip_keys'} = {map {$_ => 1} ref($self->{'skip_keys'}) eq 'ARRAY' ? @{ $self->{'skip_keys'} } : $self->{'skip_keys'}}
  1         3  
38 57 50 100     158 if $self->{'skip_keys'} && ref $self->{'skip_keys'} ne 'HASH';
    100          
39              
40 57 50       134 $self->{'sort_keys'} = 1 if ! exists $self->{'sort_keys'};
41              
42 57         139 return $self;
43             }
44              
45             sub dump {
46 58     58 1 119 my ($self, $data, $args) = @_;
47 58 50       110 $self = $self->new($args) if ! ref $self;
48              
49 58 100       181 local $self->{'indent'} = ! $self->{'pretty'} ? '' : defined($self->{'indent'}) ? $self->{'indent'} : ' ';
    100          
50 58 100       127 local $self->{'hash_sep'} = ! $self->{'pretty'} ? ':' : defined($self->{'hash_sep'}) ? $self->{'hash_sep'} : ' : ';
    100          
51 58 100       129 local $self->{'hash_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'hash_nl'}) ? $self->{'hash_nl'} : "\n";
    100          
52 58 100       124 local $self->{'array_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'array_nl'}) ? $self->{'array_nl'} : "\n";
    100          
53 58 100       145 local $self->{'str_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'str_nl'}) ? $self->{'str_nl'} : "\n";
    100          
54              
55 58         103 return $self->_dump($data, '');
56             }
57              
58             sub _dump {
59 100     100   145 my ($self, $data, $prefix) = @_;
60 100         142 my $ref = ref $data;
61              
62 100 100 100     192 if ($ref eq 'CODE' && $self->{'play_coderefs'}) {
63 2         7 $data = $data->();
64 2         12 $ref = ref $data;
65             }
66              
67 100 100       213 if ($ref eq 'HASH') {
    100          
    100          
68 23         41 my @keys = (grep { my $r = ref $data->{$_};
69 23 100 66     133 ! $r || $self->{'handle_unknown_types'} || $r eq 'HASH' || $r eq 'ARRAY' || ($r eq 'CODE' && $self->{'play_coderefs'})}
      100        
      100        
      100        
70 25   66     62 grep { ! $self->{'skip_keys'} || ! $self->{'skip_keys'}->{$_} }
71 26   100     90 grep { ! $self->{'skip_keys_qr'} || $_ !~ $self->{'skip_keys_qr'} }
72 23 50       74 ($self->{'sort_keys'} ? (sort keys %$data) : (keys %$data)));
73 23 100       63 return "{}" if ! @keys;
74             return "{$self->{hash_nl}${prefix}$self->{indent}"
75             . join(",$self->{hash_nl}${prefix}$self->{indent}",
76 20         58 map { $self->js_escape($_, "${prefix}$self->{indent}", 1)
77             . $self->{'hash_sep'}
78 22         53 . $self->_dump($data->{$_}, "${prefix}$self->{indent}") }
79             @keys)
80             . "$self->{hash_nl}${prefix}}";
81              
82             } elsif ($ref eq 'ARRAY') {
83 9 50       18 return "[]" if ! @$data;
84             return "[$self->{array_nl}${prefix}$self->{indent}"
85             . join(",$self->{array_nl}${prefix}$self->{indent}",
86 9         23 map { $self->_dump($_, "${prefix}$self->{indent}") }
  20         43  
87             @$data)
88             . "$self->{array_nl}${prefix}]";
89              
90             } elsif ($ref) {
91 3 100       17 return $self->{'handle_unknown_types'}->($self, $data, $ref) if ref($self->{'handle_unknown_types'}) eq 'CODE';
92 1         11 return '"'.$data.'"'; ### don't do anything
93              
94             } else {
95 65         155 return $self->js_escape($data, "${prefix}$self->{indent}");
96             }
97             }
98              
99             sub js_escape {
100 89     89 1 162 my ($self, $str, $prefix, $no_num) = @_;
101 89 100       147 return 'null' if ! defined $str;
102              
103             ### allow things that look like numbers to show up as numbers (and those that aren't quite to not)
104 88 100 100     577 return $str if ! $no_num && $str =~ /^ -? (?: [1-9][0-9]{0,12} | 0) (?: \. \d* [1-9])? $/x;
105              
106 55 100       105 my $quote = $self->{'single_quote'} ? "'" : '"';
107              
108 55         103 $str =~ s/\\/\\\\/g;
109 55         66 $str =~ s/\r/\\r/g;
110 55         69 $str =~ s/\t/\\t/g;
111 55 100       92 $self->{'single_quote'} ? $str =~ s/\'/\\\'/g : $str =~ s/\"/\\\"/g;
112              
113             ### allow for really odd chars
114 55         99 $str =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; # from JSON::Converter
  0         0  
115 55 50 33     112 utf8::decode($str) if $self->{'utf8'} && &utf8::decode;
116              
117             ### escape and tags in the text
118             $str =~ s{() )}{$1$quote+$quote}gx
119 55 100       200 if ! $self->{'no_tag_splitting'};
120              
121             ### add nice newlines (unless pretty is off)
122 55 100 100     153 if ($self->{'str_nl'} && length($str) > 80) {
123 4 100       16 if ($self->{'single_quote'}) {
124 2 50       28 $str =~ s/\'\s*\+\'$// if $str =~ s/\n/\\n\'$self->{str_nl}${prefix}+\'/g;
125             } else {
126 2 50       25 $str =~ s/\"\s*\+\"$// if $str =~ s/\n/\\n\"$self->{str_nl}${prefix}+\"/g;
127             }
128             } else {
129 51         80 $str =~ s/\n/\\n/g;
130             }
131              
132 55         296 return $quote . $str . $quote;
133             }
134              
135             1;
136              
137             __END__