+package CGI::Ex::JSONDump;
+
+=head1 NAME
+
+CGI::Ex::JSONDump - Comprehensive data to JSON dump.
+
+=cut
+
+###----------------------------------------------------------------###
+# Copyright 2006 - Paul Seamons #
+# Distributed under the Perl Artistic License without warranty #
+###----------------------------------------------------------------###
+
+use vars qw($VERSION
+ @EXPORT @EXPORT_OK);
+use strict;
+use base qw(Exporter);
+
+BEGIN {
+ $VERSION = '2.04';
+
+ @EXPORT = qw(JSONDump);
+ @EXPORT_OK = @EXPORT;
+
+};
+
+sub JSONDump {
+ my ($data, $args) = @_;
+ return __PACKAGE__->new($args)->dump($data);
+}
+
+###----------------------------------------------------------------###
+
+sub new {
+ my $class = shift || __PACKAGE__;
+ my $args = shift || {};
+ my $self = bless {%$args}, $class;
+
+ $self->{'skip_keys'} = {map {$_ => 1} ref($self->{'skip_keys'}) eq 'ARRAY' ? @{ $self->{'skip_keys'} } : $self->{'skip_keys'}}
+ if $self->{'skip_keys'} && ref $self->{'skip_keys'} ne 'HASH';
+
+ $self->{'sort_keys'} = 1 if ! exists $self->{'sort_keys'};
+
+ return $self;
+}
+
+sub dump {
+ my ($self, $data, $args) = @_;
+ $self = $self->new($args) if ! ref $self;
+
+ local $self->{'indent'} = ! $self->{'pretty'} ? '' : defined($self->{'indent'}) ? $self->{'indent'} : ' ';
+ local $self->{'hash_sep'} = ! $self->{'pretty'} ? ':' : defined($self->{'hash_sep'}) ? $self->{'hash_sep'} : ' : ';
+ local $self->{'hash_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'hash_nl'}) ? $self->{'hash_nl'} : "\n";
+ local $self->{'array_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'array_nl'}) ? $self->{'array_nl'} : "\n";
+ local $self->{'str_nl'} = ! $self->{'pretty'} ? '' : defined($self->{'str_nl'}) ? $self->{'str_nl'} : "\n";
+
+ return $self->_dump($data, '');
+}
+
+sub _dump {
+ my ($self, $data, $prefix) = @_;
+ my $ref = ref $data;
+
+ if ($ref eq 'CODE' && $self->{'play_coderefs'}) {
+ $data = $data->();
+ $ref = ref $data;
+ }
+
+ if ($ref eq 'HASH') {
+ my @keys = (grep { my $r = ref $data->{$_};
+ ! $r || $self->{'handle_unknown_types'} || $r eq 'HASH' || $r eq 'ARRAY' || ($r eq 'CODE' && $self->{'play_coderefs'})}
+ grep { ! $self->{'skip_keys'} || ! $self->{'skip_keys'}->{$_} }
+ grep { ! $self->{'skip_keys_qr'} || $_ !~ $self->{'skip_keys_qr'} }
+ ($self->{'sort_keys'} ? (sort keys %$data) : (keys %$data)));
+ return "{}" if ! @keys;
+ return "{$self->{hash_nl}${prefix}$self->{indent}"
+ . join(",$self->{hash_nl}${prefix}$self->{indent}",
+ map { $self->js_escape($_, "${prefix}$self->{indent}")
+ . $self->{'hash_sep'}
+ . $self->_dump($data->{$_}, "${prefix}$self->{indent}") }
+ @keys)
+ . "$self->{hash_nl}${prefix}}";
+
+ } elsif ($ref eq 'ARRAY') {
+ return "[]" if ! @$data;
+ return "[$self->{array_nl}${prefix}$self->{indent}"
+ . join(",$self->{array_nl}${prefix}$self->{indent}",
+ map { $self->_dump($_, "${prefix}$self->{indent}") }
+ @$data)
+ . "$self->{array_nl}${prefix}]";
+
+ } elsif ($ref) {
+ return $self->{'handle_unknown_types'}->($self, $data, $ref) if ref($self->{'handle_unknown_types'}) eq 'CODE';
+ return '"'.$data.'"'; ### don't do anything
+
+ } else {
+ return $self->js_escape($data, "${prefix}$self->{indent}");
+ }
+}
+
+sub js_escape {
+ my ($self, $str, $prefix) = @_;
+ return 'null' if ! defined $str;
+
+ ### allow things that look like numbers to show up as numbers (and those that aren't quite to not)
+ return $str if $str =~ /^ -? (?: \d{0,13} \. \d* [1-9] | \d{1,13}) $/x;
+
+ my $quote = $self->{'single_quote'} ? "'" : '"';
+
+ $str =~ s/\\/\\\\/g;
+ $str =~ s/\r/\\\r/g;
+ $str =~ s/\t/\\\t/g;
+ $self->{'single_quote'} ? $str =~ s/\'/\\\'/g : $str =~ s/\"/\\\"/g;
+
+ ### allow for really odd chars
+ $str =~ s/([\x00-\x07\x0b\x0e-\x1f])/'\\u00' . unpack('H2',$1)/eg; # from JSON::Converter
+ utf8::decode($str) if $self->{'utf8'} && &utf8::decode;
+
+ ### escape <html> and </html> tags in the text
+ $str =~ s{(</? (?: htm | scrip | !-))}{$1$quote+$quote}gx;
+
+ ### add nice newlines (unless pretty is off)
+ if ($self->{'str_nl'} && length($str) > 80) {
+ if ($self->{'single_quote'}) {
+ $str =~ s/\'\s*\+\'$// if $str =~ s/\n/\\n\'$self->{str_nl}${prefix}+\'/g;
+ } else {
+ $str =~ s/\"\s*\+\"$// if $str =~ s/\n/\\n\"$self->{str_nl}${prefix}+\"/g;
+ }
+ } else {
+ $str =~ s/\n/\\n/g;
+ }
+
+ return $quote . $str . $quote;
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ use CGI::Ex::JSONDump;
+
+ my $js = JSONDump(\%complex_data, {pretty => 0});
+
+ ### OR
+
+ my $js = CGI::Ex::JSONDump->new({pretty => 0})->dump(\%complex_data);
+
+=head1 DESCRIPTION
+
+CGI::Ex::JSONDump is a very lightweight and fast perl data structure to javascript object
+notation dumper. This is useful for AJAX style methods, or dynamic page creation that
+needs to embed perl data in the presented page.
+
+CGI::Ex::JSONDump has roughly the same output as JSON::objToJson, but with the following
+differences:
+
+ - CGI::Ex::JSONDump is much much lighter and smaller (a whopping 134 lines).
+ - It dumps Javascript in more browser friendly format (handling of </script> tags).
+ - It removes unknown key types by default instead of dying.
+ - It allows for a general handler to handle unknown key types.
+ - It allows for fine grain control of all whitespace.
+ - It allows for skipping keys by name or by regex.
+ - It dumps both data structures and scalar types.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+Create a CGI::Ex::JSONDump object. Takes arguments hashref as single argument.
+
+ my $obj = CGI::Ex::JSONDump->new(\%args);
+
+See the arguments section for a list of the possible arguments.
+
+=item dump
+
+Takes a perl data structure or scalar string or number and returns a string
+containing the javascript representation of that string (in Javascript object
+notation - JSON).
+
+=item js_escape
+
+Takes a scalar string or number and returns a javascript escaped string that will
+embed properly in javascript. All numbers and strings of nested data structures
+are passed through this method.
+
+=back
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item JSONDump
+
+A wrapper around the new and dump methods. Takes a structure to dump
+and optional args to pass to the new routine.
+
+ JSONDump($data, $args);
+
+Is the same as:
+
+ CGI::Ex::JSONDump->new($args)->dump($data);
+
+=back
+
+=head1 ARGUMENTS
+
+The following arguments may be passed to the new method or as the second
+argument to the JSONDump function.
+
+=over 4
+
+=item pretty
+
+0 or 1. Default 0 (false). If true then dumped structures will
+include whitespace to make them more readable.
+
+ JSONDump({a => [1, 2]}, {pretty => 0});
+ JSONDump({a => [1, 2]}, {pretty => 1});
+
+ Would print
+
+ {"a":[1,2]}
+ {
+ "a" : [
+ 1,
+ 2,
+ ]
+ }
+
+=item single_quote
+
+0 or 1. Default 0 (false). If true then escaped values will be quoted
+with single quotes. Otherwise values are quoted with double quotes.
+
+ JSONDump("a", {single_quote => 0});
+ JSONDump('a', {single_quote => 0});
+
+ Would print
+
+ "a"
+ 'a'
+
+=item sort_keys
+
+0 or 1. Default 1 (true)
+
+If true, then key/value pairs of hashrefs will be sorted will be output in sorted order.
+
+=item play_coderefs
+
+0 or 1. Default 0 (false). If true, then any code refs will be executed
+and the returned string will be dumped.
+
+If false, then keys of hashrefs that contain coderefs will be skipped (unless
+the handle_unknown_types property is set). Coderefs
+that are in arrayrefs will show up as "CODE(0x814c648)" unless
+the handle_unknown_types property is set.
+
+=item handle_unknown_types
+
+Default undef. If true it should contain a coderef that will be called if any
+unknown types are encountered. The only default known types are scalar string
+or number values, unblessed HASH refs and ARRAY refs (and CODE refs if the
+play_coderefs property is set). All other types will be passed to the
+handle_unknown_types method call.
+
+ JSONDump({a => bless({}, 'A'), b => 1}, {
+ handle_unknown_types => sub {
+ my $self = shift; # a JSON object
+ my $data = shift; # the object to dump
+
+ return $self->js_escape("Ref=" . ref $data);
+ },
+ pretty => 0,
+ });
+
+ Would print
+
+ {"a":"Ref=A","b":1}
+
+If the handle_unknown_types method is not set then keys hashrefs that have values
+with unknown types will not be included in the javascript output.
+
+ JSONDump({a => bless({}, 'A'), b => 1}, {pretty => 0});
+
+ Would print
+
+ {"b":1}
+
+=item skip_keys
+
+Should contain an arrayref of keys or a hashref whose keys are the keys to skip. Default
+is unset. Any keys of hashrefs that are in the skip_keys item will not be included in
+the javascript output.
+
+ JSONDump({a => 1, b => 1}, {skip_keys => ['a'], pretty => 0});
+
+ Would print
+
+ {"b":1}
+
+=item skip_keys_qr
+
+Similar to skip_keys but should contain a regex. Any keys of hashrefs that match the
+skip_keys_qr regex will not be included in the javascript output.
+
+ JSONDump({a => 1, _b => 1}, {skip_keys_qr => qr/^_/, pretty => 0});
+
+ Would print
+
+ {"a":1}
+
+=item indent
+
+The level to indent each nested data structure level if pretty is true. Default is " ".
+
+=item hash_nl
+
+The whitespace to add after each hashref key/value pair if pretty is true. Default is "\n".
+
+=item hash_sep
+
+The separator and whitespace to put between each hashref key/value pair if pretty is true. Default is " : ".
+
+=item array_nl
+
+The whitespace to add after each arrayref entry if pretty is true. Default is "\n".
+
+=item str_nl
+
+The whitespace to add in between newline separated strings if pretty is true or the output line is
+greater than 80 characters. Default is "\n".
+
+ JSONDump("This is a long string\n"
+ ."with plenty of embedded newlines\n"
+ ."and is greater than 80 characters.\n", {pretty => 1, str_nl => "\n"});
+
+ Would print
+
+ "This is a long string\n"
+ +"with plenty of embedded newlines\n"
+ +"and is greater than 80 characters.\n"
+
+If the string is less than 80 characters, or if str_nl is set to '', then the escaped
+string will be contained on a single line.
+
+=back
+
+=head1 AUTHORS
+
+Paul Seamons <paul at seamons dot com>
+
+=cut