File Coverage

blib/lib/Stacktrace/Configurable.pm

Criterion	Covered	Total	%
statement	161	161	100.0
branch	94	100	94.0
condition	47	60	78.3
subroutine	24	24	100.0
pod	13	14	92.8
total	339	359	94.4

package Stacktrace::Configurable;

use strict;
use 5.01;
our $VERSION = '0.06';

use Stacktrace::Configurable::Frame;

use Scalar::Util qw/looks_like_number/;
use Data::Dumper ();
no warnings 'uninitialized';    ## no critic

our @attr;

BEGIN {
    @attr=(qw/format frames/);
    for (@attr) {
        my $attr=$_;
        no strict 'refs';
        *{__PACKAGE__.'::'.$attr}=sub : lvalue {
            my $I=$_[0];
            $I->{$attr}=$_[1] if @_>1;
            $I->{$attr};
        };
    }
}

sub skip_package_re {}
sub skip_package_number {1}

sub default_format {
    ('env=STACKTRACE_CONFIG,'.
     '%[nr=1,s=    ==== START STACK TRACE ===]b%[nr=1,n]b'.
     '%4b[%*n] at %f line %l%[n]b'.
     '%12b%[skip_package]s %[env=STACKTRACE_CONFIG_A]a'.
     '%[nr!STACKTRACE_CONFIG_MAX,c=%n    ... %C frames cut off]b'.
     '%[nr=$,n]b%[nr=$,s=    === END STACK TRACE ===]b%[nr=$,n]b');
}

sub get_trace {
    my $I=shift;

    my $i=$I->skip_package_number;
    my $skip_re=$I->skip_package_re;

    my $nr=1;

    my @trace;
    while (my @l=do {
        package
            DB;
        @DB::args=();
        CORE::caller $i++;
    }) {
        next if !@trace and $skip_re and $l[0]=~$skip_re;
        push @trace, Stacktrace::Configurable::Frame->new(@l, $nr++,
                                                          [@DB::args]);
    }

    $I->{frames}=\@trace;
    return $I;
}

sub new {
    my $class = shift;
    $class = ref($class)||$class;

    my $I = bless {}=>$class;
    for (my $i = 0; $i<@_; $ i+= 2) {
        my $m = $_[$i];
        $I->$m($_[$i+1]);
    }

    $I->{format} ||= $I->default_format;

    return $I;
}

sub _use_dumper {
    my $p = $_[0];
    return 0 if looks_like_number $_;
    ref and return $p->{dump} || $p->{pkg_dump}->{ref()} || do {
        my $arg = $_;
        !!map({ref($arg) =~ /$_/} @{$p->{pkg_dump_re}});
    };
    return 1;
}

sub fmt_b {                     # space & control
    my ($I, $frame, $width, $param) = @_;
    my $nr = $frame->{nr};
    $width //= 1;
    my $cutoff;
    if ($param =~ s/^nr!(\d+),//) {
        return '' unless $nr == $1;
        $cutoff = @{$I->{frames}} - $nr;
        $#{$I->{frames}} = $nr - 1;
    } elsif ($param =~ s/^nr!(\w+),//) {
        return '' unless length $ENV{$1} and $nr == $ENV{$1};
        $cutoff = @{$I->{frames}} - $nr;
        $#{$I->{frames}} = $nr - 1;
    } elsif ($param =~ s/^nr%(\d+)(?:=(\d+))?,//) {
        return '' unless $nr % $1 == ($2//0);
    } elsif ($param =~ s/^nr=(\d+|\$),//) {
        if ($1 eq '$') {
            return '' unless $nr == @{$I->{frames}};
        } else {
            return '' unless $nr == $1;
        }
    }

    if ($param =~ s/^c=//) {
        return '' if $cutoff <= 0;
        $param =~ s/%([Cn])/$1 eq 'C' ? $cutoff : "\n"/ge;
        return $param x $width;
    } elsif ($param =~ s/^s=//) {
        return $param x $width;
    } else {
        return +($param eq 'n'
                 ? "\n"
                 : $param eq 't'
                 ? "\t"
                 : ' ') x $width;
    }
}

sub fmt_n {                     # frame number
    my ($I, $frame, $width, $param) = @_;
    if ($width eq '*') {
        $width = length '' . (0 + @{$I->{frames}});
    } elsif ($width eq '-*') {
        $width = -length '' . (0 + @{$I->{frames}});
    }
    return sprintf "%${width}d", $frame->{nr};
}

sub fmt_s {                     # subroutine
    my ($I, $frame, $width, $param) = @_;
    if (my $eval = $frame->{evaltext}) {
        return "require $eval" if $frame->{is_require};
        $eval =~ s/([\\\'])/\\$1/g;
        return "eval '$eval'";
    }
    my $s = $frame->{subroutine};

    for (split /,\s*/, $param) {
        last if s/^skip_package// and $s =~ s!^.*::!!;
    }
    return $s;
}

sub fmt_a {                     # args
    my ($I, $frame, $width, $param) = @_;
    return '' unless $frame->{hasargs};
    my @param = split /,\s*/, $param;
    my %p;
    my @ml;
    for (@param) {
        ## no critic
        $p{dump} = 1,                          next if /^dump$/;
        $p{pkg_dump}->{$1} = 1,                next if m~^dump=(?!/)(.+)$~;
        push(@{$p{pkg_dump_re}}, $1),          next if m~^dump=/(.+)/$~;
        push(@param, split /,\s*/, $ENV{$1}),  next if /^env=(.+)/;
        $p{deparse} = 1,                       next if /^deparse$/;
        @ml = ($1||4, $2||4),                  next if m~^multiline(?:=(\d+)(?:\.(\d+))?)?$~;
    }
    if (@ml) {
        return "(\n".join(",\n", map {(' 'x($ml[0]+$ml[1])).$_} map {
            (!defined $_
             ? "undef"
             : _use_dumper (\%p)
             ? Data::Dumper->new([$_])->Useqq(1)->Deparse($p{deparse} || 0)
                           ->Indent(0)->Terse(1)->Dump
             : "$_");
        } @{$frame->{args}})."\n".(' 'x$ml[0]).")";
    } else {
        return '('.join(', ', map {
            (!defined $_
             ? "undef"
             : _use_dumper (\%p)
             ? Data::Dumper->new([$_])->Useqq(1)->Deparse($p{deparse} || 0)
                           ->Indent(0)->Terse(1)->Dump
             : "$_");
        } @{$frame->{args}}).')';
    }
}

sub fmt_f {                     # filename
    my ($I, $frame, $width, $param) = @_;
    my $fn = $frame->{filename};
    for (split /,\s*/, $param) {
        last if s/^skip_prefix=// and $fn =~ s!^\Q$_\E!!;
        last if s/^basename$// and $fn =~ s!^.*/!!;
    }
    return substr($fn, 0, $width) . '...' if $width > 0 and length $fn > $width;
    return '...' . substr($fn, $width) if $width < 0 and length $fn > -$width;
    return $fn;
}

sub fmt_l {                     # linenr
    my ($I, $frame, $width, $param) = @_;
    return sprintf "%${width}d", $frame->{line};
}

sub fmt_c {                     # context (void/scalar/list)
    my ($I, $frame, $width, $param) = @_;
    return (!defined $frame->{wantarray}
            ? 'void'
            : $frame->{wantarray}
            ? 'list'
            : 'scalar');
}

sub fmt_p {                     # package
    my ($I, $frame, $width, $param) = @_;
    my $pn = $frame->{package};
    for (split /,\s*/, $param) {
        last if s/^skip_prefix=// and $pn =~ s!^\Q$_\E!!;
    }
    return substr($pn, 0, $width) . '...' if $width > 0 and length $pn > $width;
    return '...' . substr($pn, $width) if $width < 0 and length $pn > -$width;
    return $pn;
}

sub as_string {
    my $I = shift;
    my $fmt = $I->{format};

    my %seen;
    while ($fmt =~ s/^env=(\w+)(,|$)//) {
        my $var = $1;
        return '' if $ENV{$var}=~/^(?:off|no|0)$/i;

        undef $seen{$var};
        unless (length $fmt) {
            $fmt = $ENV{$var} || $I->default_format;
            $fmt =~ /^env=(\w+)(,|$)/ and exists $seen{$1} and
                $fmt = 'format cycle detected';
        }
    }

    local $@;
    local $SIG{__DIE__};

    my $s = '';
    for my $frame (@{$I->{frames}}) {
        my $l = $fmt;
        $l =~ s/
                   %                         # leading %
                   (?:
                       (%)
                   |
                       (-?(?:\d+|\*))?       # width
                       (?:\[(.+?)\])?        # modifiers
                       ([bnasflcp])          # placeholder
                   )
               /$1 ? $1 : do {my $m="fmt_$4"; $I->$m($frame, $2, $3)}/gex;
        $s .= $l."\n";
    }
    chomp $s;

    return $s;
}

1;
__END__