File Coverage

blib/lib/Data/Printer/Profile/JSON.pm

Criterion	Covered	Total	%
statement	52	52	100.0
branch	7	10	70.0
condition	1	3	33.3
subroutine	11	11	100.0
pod	0	1	0.0
total	71	77	92.2

package Data::Printer::Profile::JSON;
use strict;
use warnings;

sub profile {
    return {
        show_tainted => 0,
        show_unicode => 0,
        show_lvalue  => 0,
        print_escapes => 0,
        scalar_quotes => q("),
        escape_chars => 'none',
        string_max => 0,
        unicode_charnames => 0,
        array_max => 0,
        index => 0,
        hash_max => 0,
        hash_separator => ': ',
        align_hash => 0,
        sort_keys => 0,
        quote_keys => 1,
        name => 'var',
        return_value => 'dump',
        output => 'stderr',
        indent => 2,
        show_readonly => 0,
        show_tied => 0,
        show_dualvar => 'off',
        show_weak => 0,
        show_refcount => 0,
        show_memsize => 0,
        separator => ',',
        end_separator => 0,
        caller_info => 0,
        colored => 0,
        class_method => undef,
        # Data::Printer doesn't provide a way to directly
        # decorate filters, so we do it ourselves:
        filters => [
            {
                '-class'  => \&_json_class_filter,
                'SCALAR'  => \&_json_scalar_filter,
                'LVALUE'  => \&_json_scalar_filter,
                'CODE'    => \&_json_code_filter,
                'FORMAT'  => \&_json_format_filter,
                'GLOB'    => \&_json_glob_filter,
                'REF'     => \&_json_ref_filter,,
                'Regexp'  => \&_json_regexp_filter,
                'VSTRING' => \&_json_vstring_filter,
            },
        ],
    };
}

sub _json_class_filter {
    my ($obj, $ddp) = @_;
    Data::Printer::Common::_warn($ddp, 'json cannot express blessed objects. Showing internals only');
    require Scalar::Util;
    my $reftype = Scalar::Util::reftype($obj);
    $reftype = 'Regexp' if $reftype eq 'REGEXP';
    $ddp->indent;
    my $string = $ddp->parse_as($reftype, $obj);
    $ddp->outdent;
    return $string;
}

sub _json_ref_filter {
    my ($ref, $ddp) = @_;
    my $reftype = ref $$ref;
    if ($reftype ne 'HASH' && $reftype ne 'ARRAY') {
        Data::Printer::Common::_warn($ddp, 'json cannot express references to scalars. Cast to non-reference');
    }
    require Scalar::Util;
    my $id = pack 'J', Scalar::Util::refaddr($$ref);
    if ($ddp->seen($$ref)) {
        Data::Printer::Common::_warn($ddp, 'json cannot express circular references. Cast to string');
        return '"' . $ddp->parse($$ref) . '"';
    }
    return $ddp->parse($$ref);
}

sub _json_glob_filter {
    my (undef, $ddp) = @_;
    Data::Printer::Common::_warn($ddp, 'json cannot express globs.');
    return '';
}

sub _json_format_filter {
    my $res = Data::Printer::Filter::FORMAT::parse(@_);
    return '"' . $res . '"';
}

sub _json_regexp_filter {
    my ($re, $ddp) = @_;
    Data::Printer::Common::_warn($ddp, 'regular expression cast to string (flags removed)');
    my $v = "$re";
    my $mod = "";
    if ($v =~ /^\(\?\^?([msixpadlun-]*):([\x00-\xFF]*)\)\z/) {
      $mod = $1;
      $v = $2;
      $mod =~ s/-.*//;
    }
    $v =~ s{/}{\\/}g;
    return '"' . "/$v/$mod" . '"';
}

sub _json_vstring_filter {
    my ($scalar, $ddp) = @_;
    Data::Printer::Common::_warn($ddp, 'json cannot express vstrings. Cast to string');
    my $ret = Data::Printer::Filter::VSTRING::parse(@_);
    return '"' . $ret . '"';
}

sub _json_scalar_filter {
    my ($scalar, $ddp) = @_;
    return $ddp->maybe_colorize('null', 'undef') if !defined $$scalar;
    return Data::Printer::Filter::SCALAR::parse(@_);
}

sub _json_code_filter {
    my (undef, $ddp) = @_;
    Data::Printer::Common::_warn($ddp, 'json cannot express subroutines. Cast to string');
    my $res = Data::Printer::Filter::CODE::parse(@_);
    return '"' . $res . '"';
}

1;
__END__