File Coverage

blib/lib/Devel/PrettyTrace.pm

Criterion	Covered	Total	%
statement	58	61	95.0
branch	15	18	83.3
condition	7	9	77.7
subroutine	12	12	100.0
pod	0	6	0.0
total	92	106	86.7

package Devel::PrettyTrace;

use 5.005;
use strict;

use parent qw(Exporter);
use Data::Printer;
use List::MoreUtils qw(all any);

our $VERSION = '0.04';
our @EXPORT = qw(bt);

our $Indent = '  ';
our $Evalen = 40;
our $Deeplimit = 0;
our $Skiplevels = 0;

our %IgnorePkg;
our %Opts = (
    colored		=> 1,
    class 		=> {
        internals       => 1,
        show_methods    => 'none',
        parents         => 0,
        linear_isa      => 0,
        expand          => 1,
    },
    max_depth	=> 2,
    indent		=> 2,
);

sub bt() {
    #local @DB::args;
    my $ret = '';
    my $i = $Skiplevels + 1;	#skip own call
    my $filter = get_ignore_filter();

    while (
        ($Deeplimit <= 0 || $i < $Deeplimit + 1)
            &&
        (my @info = get_caller_info($i + 1))	#+1 as we introduce another call frame
    ){
        $i++;
        next if $filter->($info[3]);

        $ret .= format_call(\@info);
    }

    if (defined wantarray){
        return $ret;
    }else{
        print STDERR $ret;
    }
}

sub get_ignore_filter{
    my @filters = map { qr/^\Q$_\E/ } keys %IgnorePkg;

    return sub {
        my $test_pkg = shift;

        return 1 if any { $test_pkg =~ $_ } @filters;
        return 0;
    }
}

sub format_call{
    my $info = shift;

    my $result = $Indent;

    if (defined $info->[6]){
        if ($info->[7]){
            $result .= "require $info->[6]";

        }else{
            $info->[6] =~ s/\n;$/;/;
            $result .= "eval '".trim_to_length($info->[6], $Evalen)."'";
        }

    }elsif ($info->[3] eq '(eval)'){
            $result .= 'eval {...}';

    }else{
        $result .= $info->[3];
    }

    if ($info->[4]){
        $result .= "(";

        if (scalar @DB::args){
            $result .= format_args();
        }

        $result .= ')';
    }

    $result .= " called at $info->[1] line $info->[2]\n";

    return $result;
}

sub format_args{
    my $result = p(@DB::args, %Opts);

    #result is always non-empty array, so transform [\n a\n b\n] => \n\t\t a \n\t\t b \n\t
    $result =~ s/^.*?\n/\n/;
    $result =~ s/\]$//;
    $result =~ s/\n/\n$Indent/go;

    return $result;
}

sub trim_to_length{
    my ($str, $len) = @_;

    if ($len > 2 && length($str) > $len){
        substr($str, $len - 3) = '...';
    }

    return $str;
}

sub get_caller_info{
    my $level = shift;

    do {
        package DB;
        @DB::args = ();
        return caller($level);
    };
}

1;