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 2006 - 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.04';
  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 =~ /^ -? (?: \d{0,13} \. \d* [1-9] | \d{1,13}) $/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
 122     ### add nice newlines (unless pretty is off)
 123     if ($self->{'str_nl'} && length($str) > 80) {
 124         if ($self->{'single_quote'}) {
 125             $str =~ s/\'\s*\+\'$// if $str =~ s/\n/\\n\'$self->{str_nl}${prefix}+\'/g;
 126         } else {
 127             $str =~ s/\"\s*\+\"$// if $str =~ s/\n/\\n\"$self->{str_nl}${prefix}+\"/g;
 128         }
 129     } else {
 130         $str =~ s/\n/\\n/g;
 131     }
 132
 133     return $quote . $str . $quote;
 134 }
 135
 136 1;
 137
 138 __END__
 139
 140 =head1 SYNOPSIS
 141
 142     use CGI::Ex::JSONDump;
 143
 144     my $js = JSONDump(\%complex_data, {pretty => 0});
 145
 146     ### OR
 147
 148     my $js = CGI::Ex::JSONDump->new({pretty => 0})->dump(\%complex_data);
 149
 150 =head1 DESCRIPTION
 151
 152 CGI::Ex::JSONDump is a very lightweight and fast perl data structure to javascript object
 153 notation dumper.  This is useful for AJAX style methods, or dynamic page creation that
 154 needs to embed perl data in the presented page.
 155
 156 CGI::Ex::JSONDump has roughly the same output as JSON::objToJson, but with the following
 157 differences:
 158
 159     - CGI::Ex::JSONDump is much much lighter and smaller (a whopping 134 lines).
 160     - It dumps Javascript in more browser friendly format (handling of </script> tags).
 161     - It removes unknown key types by default instead of dying.
 162     - It allows for a general handler to handle unknown key types.
 163     - It allows for fine grain control of all whitespace.
 164     - It allows for skipping keys by name or by regex.
 165     - It dumps both data structures and scalar types.
 166
 167 =head1 METHODS
 168
 169 =over 4
 170
 171 =item new
 172
 173 Create a CGI::Ex::JSONDump object.  Takes arguments hashref as single argument.
 174
 175     my $obj = CGI::Ex::JSONDump->new(\%args);
 176
 177 See the arguments section for a list of the possible arguments.
 178
 179 =item dump
 180
 181 Takes a perl data structure or scalar string or number and returns a string
 182 containing the javascript representation of that string (in Javascript object
 183 notation - JSON).
 184
 185 =item js_escape
 186
 187 Takes a scalar string or number and returns a javascript escaped string that will
 188 embed properly in javascript.  All numbers and strings of nested data structures
 189 are passed through this method.
 190
 191 =back
 192
 193 =head1 FUNCTIONS
 194
 195 =over 4
 196
 197 =item JSONDump
 198
 199 A wrapper around the new and dump methods.  Takes a structure to dump
 200 and optional args to pass to the new routine.
 201
 202     JSONDump($data, $args);
 203
 204 Is the same as:
 205
 206     CGI::Ex::JSONDump->new($args)->dump($data);
 207
 208 =back
 209
 210 =head1 ARGUMENTS
 211
 212 The following arguments may be passed to the new method or as the second
 213 argument to the JSONDump function.
 214
 215 =over 4
 216
 217 =item pretty
 218
 219 0 or 1.  Default 0 (false).  If true then dumped structures will
 220 include whitespace to make them more readable.
 221
 222      JSONDump({a => [1, 2]}, {pretty => 0});
 223      JSONDump({a => [1, 2]}, {pretty => 1});
 224
 225      Would print
 226
 227      {"a":[1,2]}
 228      {
 229        "a" : [
 230          1,
 231          2,
 232        ]
 233      }
 234
 235 =item single_quote
 236
 237 0 or 1.  Default 0 (false).  If true then escaped values will be quoted
 238 with single quotes.  Otherwise values are quoted with double quotes.
 239
 240      JSONDump("a", {single_quote => 0});
 241      JSONDump('a', {single_quote => 0});
 242
 243      Would print
 244
 245      "a"
 246      'a'
 247
 248 =item sort_keys
 249
 250 0 or 1.  Default 1 (true)
 251
 252 If true, then key/value pairs of hashrefs will be sorted will be output in sorted order.
 253
 254 =item play_coderefs
 255
 256 0 or 1.  Default 0 (false).  If true, then any code refs will be executed
 257 and the returned string will be dumped.
 258
 259 If false, then keys of hashrefs that contain coderefs will be skipped (unless
 260 the handle_unknown_types property is set).  Coderefs
 261 that are in arrayrefs will show up as "CODE(0x814c648)" unless
 262 the handle_unknown_types property is set.
 263
 264 =item handle_unknown_types
 265
 266 Default undef.  If true it should contain a coderef that will be called if any
 267 unknown types are encountered.  The only default known types are scalar string
 268 or number values, unblessed HASH refs and ARRAY refs (and CODE refs if the
 269 play_coderefs property is set).  All other types will be passed to the
 270 handle_unknown_types method call.
 271
 272     JSONDump({a => bless({}, 'A'), b => 1}, {
 273         handle_unknown_types => sub {
 274             my $self = shift; # a JSON object
 275             my $data = shift; # the object to dump
 276
 277             return $self->js_escape("Ref=" . ref $data);
 278         },
 279         pretty => 0,
 280     });
 281
 282     Would print
 283
 284     {"a":"Ref=A","b":1}
 285
 286 If the handle_unknown_types method is not set then keys hashrefs that have values
 287 with unknown types will not be included in the javascript output.
 288
 289     JSONDump({a => bless({}, 'A'), b => 1}, {pretty => 0});
 290
 291     Would print
 292
 293     {"b":1}
 294
 295 =item skip_keys
 296
 297 Should contain an arrayref of keys or a hashref whose keys are the keys to skip.  Default
 298 is unset.  Any keys of hashrefs that are in the skip_keys item will not be included in
 299 the javascript output.
 300
 301     JSONDump({a => 1, b => 1}, {skip_keys => ['a'], pretty => 0});
 302
 303     Would print
 304
 305     {"b":1}
 306
 307 =item skip_keys_qr
 308
 309 Similar to skip_keys but should contain a regex.  Any keys of hashrefs that match the
 310 skip_keys_qr regex will not be included in the javascript output.
 311
 312     JSONDump({a => 1, _b => 1}, {skip_keys_qr => qr/^_/, pretty => 0});
 313
 314     Would print
 315
 316     {"a":1}
 317
 318 =item indent
 319
 320 The level to indent each nested data structure level if pretty is true.  Default is "  ".
 321
 322 =item hash_nl
 323
 324 The whitespace to add after each hashref key/value pair if pretty is true.  Default is "\n".
 325
 326 =item hash_sep
 327
 328 The separator and whitespace to put between each hashref key/value pair if pretty is true.  Default is " : ".
 329
 330 =item array_nl
 331
 332 The whitespace to add after each arrayref entry if pretty is true.  Default is "\n".
 333
 334 =item str_nl
 335
 336 The whitespace to add in between newline separated strings if pretty is true or the output line is
 337 greater than 80 characters.  Default is "\n".
 338
 339     JSONDump("This is a long string\n"
 340              ."with plenty of embedded newlines\n"
 341              ."and is greater than 80 characters.\n", {pretty => 1, str_nl => "\n"});
 342
 343     Would print
 344
 345     "This is a long string\n"
 346       +"with plenty of embedded newlines\n"
 347       +"and is greater than 80 characters.\n"
 348
 349 If the string is less than 80 characters, or if str_nl is set to '', then the escaped
 350 string will be contained on a single line.
 351
 352 =back
 353
 354 =head1 AUTHORS
 355
 356 Paul Seamons <paul at seamons dot com>
 357
 358 =cut