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

package CGI::Ex::JSONDump;

=head1 NAME

CGI::Ex::JSONDump - Comprehensive data to JSON dump.

=head1 VERSION

version 2.54

=cut

###----------------------------------------------------------------###
#  Copyright - Paul Seamons                                          #
#  Distributed under the Perl Artistic License without warranty      #
###----------------------------------------------------------------###

use strict;
use Exporter qw(import);

our $VERSION = '2.54'; # VERSION
our @EXPORT = qw(JSONDump);
our @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}", 1)
                              . $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, $no_num) = @_;
    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 ! $no_num && $str =~ /^ -? (?: [1-9][0-9]{0,12} | 0) (?: \. \d* [1-9])? $/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  and  tags in the text
    $str =~ s{() )}{$1$quote+$quote}gx
        if ! $self->{'no_tag_splitting'};

    ### 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__