File Coverage

blib/lib/Devel/PartialDump.pm

Criterion	Covered	Total	%
statement	131	154	85.0
branch	54	68	79.4
condition	25	32	78.1
subroutine	31	36	86.1
pod	20	24	83.3
total	261	314	83.1

use strict;
use warnings;
package Devel::PartialDump; # git description: v0.19-3-ga398185
# vim: set ts=8 sts=4 sw=4 tw=115 et :
# ABSTRACT: Partial dumping of data structures, optimized for argument printing.
# KEYWORDS: development debugging dump dumper diagnostics deep data structures

our $VERSION = '0.20';

use Carp ();
use Scalar::Util qw(looks_like_number reftype blessed);

use namespace::clean 0.19;

use Class::Tiny {
    max_length => undef,
    max_elements => 6,
    max_depth => 2,
    stringify => 0,
    pairs => 1,
    objects => 1,
    list_delim => ", ",
    pair_delim => ": ",
};

use Sub::Exporter -setup => {
    exports => [qw(dump warn show show_scalar croak carp confess cluck $default_dumper)],
    groups => {
        easy => [qw(dump warn show show_scalar carp croak)],
        carp => [qw(croak carp)],
    },
    collectors => {
        override_carp => sub {
            no warnings 'redefine';
            require Carp;
            *Carp::caller_info = \&replacement_caller_info;
        },
    },
};

# a replacement for Carp::caller_info
sub replacement_caller_info {
    my $i = shift(@_) + 1;

    package DB; # git description: v0.19-3-ga398185
    my %call_info;
    @call_info{
    qw(pack file line sub has_args wantarray evaltext is_require)
    } = caller($i);

    return unless (defined $call_info{pack});

    my $sub_name = Carp::get_subname(\%call_info);

    if ($call_info{has_args}) {
        $sub_name .= '(' . Devel::PartialDump::dump(@DB::args) . ')';
    }

    $call_info{sub_name} = $sub_name;

    return wantarray() ? %call_info : \%call_info;
}


sub warn_str {
    my ( @args ) = @_;
    my $self;

    if ( blessed($args[0]) and $args[0]->isa(__PACKAGE__) ) {
        $self = shift @args;
    } else {
        $self = our $default_dumper;
    }
    return $self->_join(
        map {
            !ref($_) && defined($_)
            ? $_
            : $self->dump($_)
        } @args
    );
}

sub warn {
    Carp::carp(warn_str(@_));
}

foreach my $f ( qw(carp croak confess cluck) ) {
    no warnings 'redefine';
    eval "sub $f {
        local \$Carp::CarpLevel = \$Carp::CarpLevel + 1;
        Carp::$f(warn_str(\@_));
    }";
}

sub show {
    my ( @args ) = @_;
    my $self;

    if ( blessed($args[0]) and $args[0]->isa(__PACKAGE__) ) {
        $self = shift @args;
    } else {
        $self = our $default_dumper;
    }

    $self->warn(@args);

    return ( @args == 1 ? $args[0] : @args );
}

sub show_scalar ($) { goto \&show }

sub _join {
    my ( $self, @strings ) = @_;

    my $ret = "";

    if ( @strings ) {
        my $sep = $, || $" || " ";
        my $re = qr/(?: \s| \Q$sep\E )$/x;

        my $last = pop @strings;

        foreach my $string ( @strings ) {
            $ret .= $string;
            $ret .= $sep unless $string =~ $re;
        }

        $ret .= $last;
    }

    return $ret;
}

sub dump {
    my ( @args ) = @_;
    my $self;

    if ( blessed($args[0]) and $args[0]->isa(__PACKAGE__) ) {
        $self = shift @args;
    } else {
        $self = our $default_dumper;
    }

    my $method = "dump_as_" . ( $self->should_dump_as_pairs(@args) ? "pairs" : "list" );

    my $dump = $self->$method(1, @args);

    if ( defined $self->max_length and length($dump) > $self->max_length ) {
        my $max_length = $self->max_length - 3;
        $max_length = 0 if $max_length < 0;
        substr( $dump, $max_length, length($dump) - $max_length ) = '...';
    }

    if ( not defined wantarray ) {
        CORE::warn "$dump\n";
    } else {
        return $dump;
    }
}

sub should_dump_as_pairs {
    my ( $self, @what ) = @_;

    return unless $self->pairs;

    return if @what % 2 != 0; # must be an even list

    for ( my $i = 0; $i < @what; $i += 2 ) {
        return if ref $what[$i]; # plain strings are keys
    }

    return 1;
}

sub dump_as_pairs {
    my ( $self, $depth, @what ) = @_;

    my $truncated;
    if ( defined $self->max_elements and ( @what / 2 ) > $self->max_elements ) {
        $truncated = 1;
        @what = splice(@what, 0, $self->max_elements * 2 );
    }

    return join( $self->list_delim, $self->_dump_as_pairs($depth, @what), ($truncated ? "..." : ()) );
}

sub _dump_as_pairs {
    my ( $self, $depth, @what ) = @_;

    return unless @what;

    my ( $key, $value, @rest ) = @what;

    return (
        ( $self->format_key($depth, $key) . $self->pair_delim . $self->format($depth, $value) ),
        $self->_dump_as_pairs($depth, @rest),
    );
}

sub dump_as_list {
    my ( $self, $depth, @what ) = @_;

    my $truncated;
    if ( defined $self->max_elements and @what > $self->max_elements ) {
        $truncated = 1;
        @what = splice(@what, 0, $self->max_elements );
    }

    return join( $self->list_delim, ( map { $self->format($depth, $_) } @what ), ($truncated ? "..." : ()) );
}

sub format {
    my ( $self, $depth, $value ) = @_;

    defined($value)
        ? ( ref($value)
            ? ( blessed($value)
                ? $self->format_object($depth, $value)
                : $self->format_ref($depth, $value) )
            : ( looks_like_number($value)
                ? $self->format_number($depth, $value)
                : $self->format_string($depth, $value) ) )
        : $self->format_undef($depth, $value),
}

sub format_key {
    my ( $self, $depth, $key ) = @_;
    return $key;
}

sub format_ref {
    my ( $self, $depth, $ref ) = @_;

    if ( $depth > $self->max_depth ) {
        return overload::StrVal($ref);
    } else {
        my $reftype = reftype($ref);
                $reftype = 'SCALAR'
                    if $reftype eq 'REF' || $reftype eq 'LVALUE';
        my $method = "format_" . lc $reftype;

        if ( $self->can($method) ) {
            return $self->$method( $depth, $ref );
        } else {
            return overload::StrVal($ref);
        }
    }
}

sub format_array {
    my ( $self, $depth, $array ) = @_;

    my $class = blessed($array) || '';
    $class .= "=" if $class;

    return $class . "[ " . $self->dump_as_list($depth + 1, @$array) . " ]";
}

sub format_hash {
    my ( $self, $depth, $hash ) = @_;

    my $class = blessed($hash) || '';
    $class .= "=" if $class;

    return $class . "{ " . $self->dump_as_pairs($depth + 1, map { $_ => $hash->{$_} } sort keys %$hash) . " }";
}

sub format_scalar {
    my ( $self, $depth, $scalar ) = @_;

    my $class = blessed($scalar) || '';
    $class .= "=" if $class;

    return $class . "\\" . $self->format($depth + 1, $$scalar);
}

sub format_object {
    my ( $self, $depth, $object ) = @_;

    if ( $self->objects ) {
        return $self->format_ref($depth, $object);
    } else {
        return $self->stringify ? "$object" : overload::StrVal($object);
    }
}

sub format_string {
    my ( $self, $depth, $str ) =@_;
    # FIXME use String::Escape ?

    # remove vertical whitespace
    $str =~ s/\n/\\n/g;
    $str =~ s/\r/\\r/g;

    # reformat nonprintables
    $str =~ s/(\P{IsPrint})/"\\x{" . sprintf("%x", ord($1)) . "}"/ge;

    $self->quote($str);
}

sub quote {
    my ( $self, $str ) = @_;

    qq{"$str"};
}

sub format_undef { "undef" }

sub format_number {
    my ( $self, $depth, $value ) = @_;
    return "$value";
}

our $default_dumper = __PACKAGE__->new;

1;

__END__