Dogcows Code - chaz/p5-CGI-Ex/blob - 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.11';
  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 AUTHORS
 391
 392 Paul Seamons <paul at seamons dot com>
 393
 394 =cut