]> Dogcows Code - chaz/p5-CGI-Ex/blob - lib/CGI/Ex/JSONDump.pm
CGI::Ex 2.24
[chaz/p5-CGI-Ex] / lib / CGI / Ex / JSONDump.pm
1 package CGI::Ex::JSONDump;
2
3 =head1 NAME
4
5 CGI::Ex::JSONDump - Comprehensive data to JSON dump.
6
7 =cut
8
9 ###----------------------------------------------------------------###
10 # Copyright 2007 - Paul Seamons #
11 # Distributed under the Perl Artistic License without warranty #
12 ###----------------------------------------------------------------###
13
14 use vars qw($VERSION
15 @EXPORT @EXPORT_OK);
16 use strict;
17 use base qw(Exporter);
18
19 BEGIN {
20 $VERSION = '2.24';
21
22 @EXPORT = qw(JSONDump);
23 @EXPORT_OK = @EXPORT;
24
25 };
26
27 sub JSONDump {
28 my ($data, $args) = @_;
29 return __PACKAGE__->new($args)->dump($data);
30 }
31
32 ###----------------------------------------------------------------###
33
34 sub new {
35 my $class = shift || __PACKAGE__;
36 my $args = shift || {};
37 my $self = bless {%$args}, $class;
38
39 $self->{'skip_keys'} = {map {$_ => 1} ref($self->{'skip_keys'}) eq 'ARRAY' ? @{ $self->{'skip_keys'} } : $self->{'skip_keys'}}
40 if $self->{'skip_keys'} && ref $self->{'skip_keys'} ne 'HASH';
41
42 $self->{'sort_keys'} = 1 if ! exists $self->{'sort_keys'};
43
44 return $self;
45 }
46
47 sub dump {
48 my ($self, $data, $args) = @_;
49 $self = $self->new($args) if ! ref $self;
50
51 local $self->{'indent'} = ! $self->{'pretty'} ? '' : defined($self->{'indent'}) ? $self->{'indent'} : ' ';
52 local $self->{'hash_sep'} = ! $self->{'pretty'} ? ':' : defined($self->{'hash_sep'}) ? $self->{'hash_sep'} : ' : ';
53 local $self->{'hash_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'hash_nl'}) ? $self->{'hash_nl'} : "\n";
54 local $self->{'array_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'array_nl'}) ? $self->{'array_nl'} : "\n";
55 local $self->{'str_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'str_nl'}) ? $self->{'str_nl'} : "\n";
56
57 return $self->_dump($data, '');
58 }
59
60 sub _dump {
61 my ($self, $data, $prefix) = @_;
62 my $ref = ref $data;
63
64 if ($ref eq 'CODE' && $self->{'play_coderefs'}) {
65 $data = $data->();
66 $ref = ref $data;
67 }
68
69 if ($ref eq 'HASH') {
70 my @keys = (grep { my $r = ref $data->{$_};
71 ! $r || $self->{'handle_unknown_types'} || $r eq 'HASH' || $r eq 'ARRAY' || ($r eq 'CODE' && $self->{'play_coderefs'})}
72 grep { ! $self->{'skip_keys'} || ! $self->{'skip_keys'}->{$_} }
73 grep { ! $self->{'skip_keys_qr'} || $_ !~ $self->{'skip_keys_qr'} }
74 ($self->{'sort_keys'} ? (sort keys %$data) : (keys %$data)));
75 return "{}" if ! @keys;
76 return "{$self->{hash_nl}${prefix}$self->{indent}"
77 . join(",$self->{hash_nl}${prefix}$self->{indent}",
78 map { $self->js_escape($_, "${prefix}$self->{indent}")
79 . $self->{'hash_sep'}
80 . $self->_dump($data->{$_}, "${prefix}$self->{indent}") }
81 @keys)
82 . "$self->{hash_nl}${prefix}}";
83
84 } elsif ($ref eq 'ARRAY') {
85 return "[]" if ! @$data;
86 return "[$self->{array_nl}${prefix}$self->{indent}"
87 . join(",$self->{array_nl}${prefix}$self->{indent}",
88 map { $self->_dump($_, "${prefix}$self->{indent}") }
89 @$data)
90 . "$self->{array_nl}${prefix}]";
91
92 } elsif ($ref) {
93 return $self->{'handle_unknown_types'}->($self, $data, $ref) if ref($self->{'handle_unknown_types'}) eq 'CODE';
94 return '"'.$data.'"'; ### don't do anything
95
96 } else {
97 return $self->js_escape($data, "${prefix}$self->{indent}");
98 }
99 }
100
101 sub js_escape {
102 my ($self, $str, $prefix) = @_;
103 return 'null' if ! defined $str;
104
105 ### allow things that look like numbers to show up as numbers (and those that aren't quite to not)
106 return $str if $str =~ /^ -? (?: [1-9][0-9]{0,12} | 0) (?: \. \d* [1-9])? $/x;
107
108 my $quote = $self->{'single_quote'} ? "'" : '"';
109
110 $str =~ s/\\/\\\\/g;
111 $str =~ s/\r/\\r/g;
112 $str =~ s/\t/\\t/g;
113 $self->{'single_quote'} ? $str =~ s/\'/\\\'/g : $str =~ s/\"/\\\"/g;
114
115 ### allow for really odd chars
116 $str =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; # from JSON::Converter
117 utf8::decode($str) if $self->{'utf8'} && &utf8::decode;
118
119 ### escape <html> and </html> tags in the text
120 $str =~ s{(</? (?: htm | scrip | !-) | --(?=>) )}{$1$quote+$quote}gx
121 if ! $self->{'no_tag_splitting'};
122
123 ### add nice newlines (unless pretty is off)
124 if ($self->{'str_nl'} && length($str) > 80) {
125 if ($self->{'single_quote'}) {
126 $str =~ s/\'\s*\+\'$// if $str =~ s/\n/\\n\'$self->{str_nl}${prefix}+\'/g;
127 } else {
128 $str =~ s/\"\s*\+\"$// if $str =~ s/\n/\\n\"$self->{str_nl}${prefix}+\"/g;
129 }
130 } else {
131 $str =~ s/\n/\\n/g;
132 }
133
134 return $quote . $str . $quote;
135 }
136
137 1;
138
139 __END__
140
141 =head1 SYNOPSIS
142
143 use CGI::Ex::JSONDump;
144
145 my $js = JSONDump(\%complex_data, {pretty => 0});
146
147 ### OR
148
149 my $js = CGI::Ex::JSONDump->new({pretty => 0})->dump(\%complex_data);
150
151 =head1 DESCRIPTION
152
153 CGI::Ex::JSONDump is a very lightweight and fast perl data structure to javascript object
154 notation dumper. This is useful for AJAX style methods, or dynamic page creation that
155 needs to embed perl data in the presented page.
156
157 CGI::Ex::JSONDump has roughly the same output as JSON::objToJson, but with the following
158 differences:
159
160 - CGI::Ex::JSONDump is much much lighter and smaller (a whopping 134 lines).
161 - It dumps Javascript in more browser friendly format (handling of </script> tags).
162 - It removes unknown key types by default instead of dying.
163 - It allows for a general handler to handle unknown key types.
164 - It allows for fine grain control of all whitespace.
165 - It allows for skipping keys by name or by regex.
166 - It dumps both data structures and scalar types.
167
168 =head1 METHODS
169
170 =over 4
171
172 =item new
173
174 Create a CGI::Ex::JSONDump object. Takes arguments hashref as single argument.
175
176 my $obj = CGI::Ex::JSONDump->new(\%args);
177
178 See the arguments section for a list of the possible arguments.
179
180 =item dump
181
182 Takes a perl data structure or scalar string or number and returns a string
183 containing the javascript representation of that string (in Javascript object
184 notation - JSON).
185
186 =item js_escape
187
188 Takes a scalar string or number and returns a javascript escaped string that will
189 embed properly in javascript. All numbers and strings of nested data structures
190 are passed through this method.
191
192 =back
193
194 =head1 FUNCTIONS
195
196 =over 4
197
198 =item JSONDump
199
200 A wrapper around the new and dump methods. Takes a structure to dump
201 and optional args to pass to the new routine.
202
203 JSONDump($data, $args);
204
205 Is the same as:
206
207 CGI::Ex::JSONDump->new($args)->dump($data);
208
209 =back
210
211 =head1 ARGUMENTS
212
213 The following arguments may be passed to the new method or as the second
214 argument to the JSONDump function.
215
216 =over 4
217
218 =item pretty
219
220 0 or 1. Default 0 (false). If true then dumped structures will
221 include whitespace to make them more readable.
222
223 JSONDump({a => [1, 2]}, {pretty => 0});
224 JSONDump({a => [1, 2]}, {pretty => 1});
225
226 Would print
227
228 {"a":[1,2]}
229 {
230 "a" : [
231 1,
232 2
233 ]
234 }
235
236 =item single_quote
237
238 0 or 1. Default 0 (false). If true then escaped values will be quoted
239 with single quotes. Otherwise values are quoted with double quotes.
240
241 JSONDump("a", {single_quote => 0});
242 JSONDump("a", {single_quote => 1});
243
244 Would print
245
246 "a"
247 'a'
248
249 =item sort_keys
250
251 0 or 1. Default 1 (true)
252
253 If true, then key/value pairs of hashrefs will be output in sorted order.
254
255 =item play_coderefs
256
257 0 or 1. Default 0 (false). If true, then any code refs will be executed
258 and the returned string will be dumped.
259
260 If false, then keys of hashrefs that contain coderefs will be skipped (unless
261 the handle_unknown_types property is set). Coderefs
262 that are in arrayrefs will show up as "CODE(0x814c648)" unless
263 the handle_unknown_types property is set.
264
265 =item handle_unknown_types
266
267 Default undef. If true it should contain a coderef that will be called if any
268 unknown types are encountered. The only default known types are scalar string
269 or number values, unblessed HASH refs and ARRAY refs (and CODE refs if the
270 play_coderefs property is set). All other types will be passed to the
271 handle_unknown_types method call.
272
273 JSONDump({a => bless({}, 'A'), b => 1}, {
274 handle_unknown_types => sub {
275 my $self = shift; # a JSON object
276 my $data = shift; # the object to dump
277
278 return $self->js_escape("Ref=" . ref $data);
279 },
280 pretty => 0,
281 });
282
283 Would print
284
285 {"a":"Ref=A","b":1}
286
287 If the handle_unknown_types method is not set then keys hashrefs that have values
288 with unknown types will not be included in the javascript output.
289
290 JSONDump({a => bless({}, 'A'), b => 1}, {pretty => 0});
291
292 Would print
293
294 {"b":1}
295
296 =item skip_keys
297
298 Should contain an arrayref of keys or a hashref whose keys are the
299 keys to skip. Default is unset. Any keys of hashrefs (including
300 nested hashrefs) that are listed in the skip_keys item will not be included
301 in the javascript output.
302
303 JSONDump({a => 1, b => 1}, {skip_keys => ['a'], pretty => 0});
304
305 Would print
306
307 {"b":1}
308
309 =item skip_keys_qr
310
311 Similar to skip_keys but should contain a regex. Any keys of hashrefs
312 (including nested hashrefs) that match the skip_keys_qr regex will not
313 be included in the javascript output.
314
315 JSONDump({a => 1, _b => 1}, {skip_keys_qr => qr/^_/, pretty => 0});
316
317 Would print
318
319 {"a":1}
320
321 =item indent
322
323 The level to indent each nested data structure level if pretty is true. Default is " " (two spaces).
324
325 =item hash_nl
326
327 The whitespace to add after each hashref key/value pair if pretty is true. Default is "\n".
328
329 =item hash_sep
330
331 The separator and whitespace to put between each hashref key/value pair if pretty is true. Default is " : ".
332
333 =item array_nl
334
335 The whitespace to add after each arrayref entry if pretty is true. Default is "\n".
336
337 =item str_nl
338
339 The whitespace to add in between newline separated strings if pretty is true or the output line is
340 greater than 80 characters. Default is "\n" (if pretty is true).
341
342 JSONDump("This is a long string\n"
343 ."with plenty of embedded newlines\n"
344 ."and is greater than 80 characters.\n", {pretty => 1});
345
346 Would print
347
348 "This is a long string\n"
349 +"with plenty of embedded newlines\n"
350 +"and is greater than 80 characters.\n"
351
352 JSONDump("This is a long string\n"
353 ."with plenty of embedded newlines\n"
354 ."and is greater than 80 characters.\n", {pretty => 1, str_nl => ""});
355
356 Would print
357
358 "This is a long string\nwith plenty of embedded newlines\nand is greater than 80 characters.\n"
359
360 If the string is less than 80 characters, or if str_nl is set to "", then the escaped
361 string will be contained on a single line. Setting pretty to 0 effectively sets str_nl equal to "".
362
363 =item no_tag_splitting
364
365 Default off. If JSON is embedded in an HTML document and the JSON contains C<< <html> >>,
366 C<< </html> >>, C<< <script> >>, C<< </script> >>, C<< <!-- >>, or , C<< --> >> tags, they are
367 split apart with a quote, a +, and a quote. This allows the embedded tags to not affect
368 the currently playing JavaScript.
369
370 However, if the JSON that is output is intended for deserialization by another non-javascript-engine
371 JSON parser, this splitting behavior may cause errors when the JSON is imported. To avoid the splitting
372 behavior in these cases you can use the no_tag_splitting flag to turn off the behavior.
373
374 JSONDump("<html><!-- comment --><script></script></html>");
375
376 Would print
377
378 "<htm"+"l><!-"+"- comment --"+"><scrip"+"t></scrip"+"t></htm"+"l>"
379
380 With the flag
381
382 JSONDump("<html><!-- comment --><script></script></html>", {no_tag_splitting => 1});
383
384 Would print
385
386 "<html><!-- comment --><script></script></html>"
387
388 =back
389
390 =head1 LICENSE
391
392 This module may distributed under the same terms as Perl itself.
393
394 =head1 AUTHORS
395
396 Paul Seamons <perl at seamons dot com>
397
398 =cut
This page took 0.057866 seconds and 4 git commands to generate.