File Coverage

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

Criterion	Covered	Total	%
statement	66	67	98.5
branch	6	12	50.0
condition	3	9	33.3
subroutine	15	15	100.0
pod	0	1	0.0
total	90	104	86.5

package Data::Printer::Profile::Dumper;
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 => '$VAR1',
        arrows => 'first',
        return_value => 'dump',
        output => 'stderr',
        indent => 10,
        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'  => \&_data_dumper_class_filter,
                'SCALAR'  => \&_data_dumper_scalar_filter,
                'LVALUE'  => \&_data_dumper_lvalue_filter,
                'HASH'    => \&_data_dumper_hash_filter,
                'ARRAY'   => \&_data_dumper_array_filter,
                'CODE'    => \&_data_dumper_code_filter,
                'FORMAT'  => \&_data_dumper_format_filter,
                'GLOB'    => \&_data_dumper_glob_filter,
                'REF'     => \&_data_dumper_ref_filter,,
                'Regexp'  => \&_data_dumper_regexp_filter,
                'VSTRING' => \&_data_dumper_vstring_filter,
            },
        ],
    };
}

sub _data_dumper_regexp_filter {
    my ($re, $ddp) = @_;
    my $v = "$re";
    my $mod = "";
    if ($v =~ /^\(\?\^?([msixpadlun-]*):([\x00-\xFF]*)\)\z/) {
      $mod = $1;
      $v = $2;
      $mod =~ s/-.*//;
    }
    $v =~ s{/}{\\/}g;
    return _output_wrapper($ddp, $ddp->maybe_colorize("qr/$v/$mod", 'regex'));
}

sub _data_dumper_glob_filter {
    my ($glob, $ddp) = @_;
    my $ret = "$$glob";
    $ret =~ s|\A\*main:|\*:|;
    $ret =~ s|\A\*|\\*{'|;
    $ret .= '\'}';
    return _output_wrapper($ddp, $ddp->maybe_colorize($ret, 'glob'));
}

sub _data_dumper_lvalue_filter {
    my (undef, $ddp) = @_;
    Data::Printer::Common::_warn($ddp, 'cannot handle ref type 10');
    return _output_wrapper($ddp, '');
}

sub _data_dumper_scalar_filter {
    my ($scalar, $ddp) = @_;
    my $ret = Data::Printer::Filter::SCALAR::parse(@_);
    return _output_wrapper($ddp, $ret);
}

sub _data_dumper_ref_filter {
    my ($scalar, $ddp) = @_;
    $ddp->indent;
    my $ret = Data::Printer::Filter::REF::parse(@_);
    $ret =~ s{\A[\\]+\s+}{\\}; # DDP's REF filter adds a space after refs.
    $ddp->outdent;
    return _output_wrapper($ddp, $ret);
}

sub _data_dumper_vstring_filter {
    my ($scalar, $ddp) = @_;
    my $ret = Data::Printer::Filter::VSTRING::parse(@_);
    if ($] < 5.009 && substr($ret, 0, 7) eq 'VSTRING') {
        $ret = $ddp->maybe_colorize('', 'vstring');
    }
    return _output_wrapper($ddp, $ret);
}

sub _data_dumper_format_filter {
    my (undef, $ddp) = @_;
    Data::Printer::Common::_warn($ddp, 'cannot handle ref type 14');
    return _output_wrapper($ddp, '');
}

sub _data_dumper_code_filter {
    my (undef, $ddp) = @_;
    return _output_wrapper($ddp, $ddp->maybe_colorize('sub { "DUMMY" }', 'code'));
}

sub _data_dumper_array_filter {
    my ($hashref, $ddp) = @_;
    my $ret = Data::Printer::Filter::ARRAY::parse(@_);
    return _output_wrapper($ddp, $ret);
}

sub _data_dumper_hash_filter {
    my ($hashref, $ddp) = @_;
    my $ret = Data::Printer::Filter::HASH::parse(@_);
    return _output_wrapper($ddp, $ret);
}

sub _data_dumper_class_filter {
    my ($obj, $ddp) = @_;
    require Scalar::Util;
    my $reftype = Scalar::Util::reftype($obj);
    $reftype = 'Regexp' if $reftype eq 'REGEXP';
    my ($parse_prefix, $parse_suffix) = ('', '');
    if ($reftype eq 'SCALAR' || $reftype eq 'REF' || $reftype eq 'VSTRING') {
        $parse_prefix = 'do{\(my $o = ';
        $parse_prefix .= '\\' if $reftype eq 'REF';
        $parse_suffix = ')}';
    }
    $ddp->indent;
    my $ret = $ddp->maybe_colorize('bless( ' . $parse_prefix, 'method')
            . $ddp->parse_as($reftype, $obj)
            . $ddp->maybe_colorize($parse_suffix, 'method')
            . q|, '| . $ddp->maybe_colorize(ref($obj), 'class') . q|'|
            . $ddp->maybe_colorize(' )', 'method')
            ;
    $ddp->outdent;

    return _output_wrapper($ddp, $ret);
}

sub _output_wrapper {
    my ($ddp, $output) = @_;
    if ($ddp->current_depth == 0) {
        $output = '$VAR1 = ' . $output . ';';
    }
    return $output;
}

1;
__END__