view release on metacpan or  search on metacpan

lib/Devel/PrettyTrace.pm  view on Meta::CPAN

package Devel::PrettyTrace;

use 5.005;
use strict;

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

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

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

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

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();