File Coverage

blib/lib/Devel/StackTrace.pm

Criterion	Covered	Total	%
statement	143	145	98.6
branch	51	60	85.0
condition	15	20	75.0
subroutine	22	22	100.0
pod	9	9	100.0
total	240	256	93.7

package Devel::StackTrace;

use 5.006;

use strict;
use warnings;

our $VERSION = '2.04';

use Devel::StackTrace::Frame;
use File::Spec;
use Scalar::Util qw( blessed );

use overload
    '""'     => \&as_string,
    fallback => 1;

sub new {
    my $class = shift;
    my %p     = @_;

    $p{unsafe_ref_capture} = !delete $p{no_refs}
        if exists $p{no_refs};

    my $self = bless {
        index  => undef,
        frames => [],
        raw    => [],
        %p,
    }, $class;

    $self->_record_caller_data;

    return $self;
}

sub _record_caller_data {
    my $self = shift;

    my $filter = $self->{filter_frames_early} && $self->_make_frame_filter;

    # We exclude this method by starting at least one frame back.
    my $x = 1 + ( $self->{skip_frames} || 0 );

    while (
        my @c
        = $self->{no_args}
        ? caller( $x++ )
        : do {
            ## no critic (Modules::ProhibitMultiplePackages, Variables::ProhibitPackageVars)
            package    # the newline keeps dzil from adding a version here
                DB;
            @DB::args = ();
            caller( $x++ );
        }
    ) {

        my @args;

        ## no critic (Variables::ProhibitPackageVars, BuiltinFunctions::ProhibitComplexMappings)
        unless ( $self->{no_args} ) {

            # This is the same workaroud as was applied to Carp.pm a little
            # while back
            # (https://rt.perl.org/Public/Bug/Display.html?id=131046):
            #
            #   Guard our serialization of the stack from stack refcounting
            #   bugs NOTE this is NOT a complete solution, we cannot 100%
            #   guard against these bugs. However in many cases Perl *is*
            #   capable of detecting them and throws an error when it
            #   does. Unfortunately serializing the arguments on the stack is
            #   a perfect way of finding these bugs, even when they would not
            #   affect normal program flow that did not poke around inside the
            #   stack. Inside of Carp.pm it makes little sense reporting these
            #   bugs, as Carp's job is to report the callers errors, not the
            #   ones it might happen to tickle while doing so.  See:
            #   https://rt.perl.org/Public/Bug/Display.html?id=131046 and:
            #   https://rt.perl.org/Public/Bug/Display.html?id=52610 for more
            #   details and discussion. - Yves
            @args = map {
                my $arg;
                local $@ = $@;
                eval {
                    $arg = $_;
                    1;
                } or do {
                    $arg = '** argument not available anymore **';
                };
                $arg;
            } @DB::args;
        }
        ## use critic

        my $raw = {
            caller => \@c,
            args   => \@args,
        };

        next if $filter && !$filter->($raw);

        unless ( $self->{unsafe_ref_capture} ) {
            $raw->{args} = [ map { ref $_ ? $self->_ref_to_string($_) : $_ }
                    @{ $raw->{args} } ];
        }

        push @{ $self->{raw} }, $raw;
    }
}

sub _ref_to_string {
    my $self = shift;
    my $ref  = shift;

    return overload::AddrRef($ref)
        if blessed $ref && $ref->isa('Exception::Class::Base');

    return overload::AddrRef($ref) unless $self->{respect_overload};

    ## no critic (Variables::RequireInitializationForLocalVars)
    local $@;
    local $SIG{__DIE__};
    ## use critic

    my $str = eval { $ref . q{} };

    return $@ ? overload::AddrRef($ref) : $str;
}

sub _make_frames {
    my $self = shift;

    my $filter = !$self->{filter_frames_early} && $self->_make_frame_filter;

    my $raw = delete $self->{raw};
    for my $r ( @{$raw} ) {
        next if $filter && !$filter->($r);

        $self->_add_frame( $r->{caller}, $r->{args} );
    }
}

my $default_filter = sub {1};

sub _make_frame_filter {
    my $self = shift;

    my ( @i_pack_re, %i_class );
    if ( $self->{ignore_package} ) {
        ## no critic (Variables::RequireInitializationForLocalVars)
        local $@;
        local $SIG{__DIE__};
        ## use critic

        $self->{ignore_package} = [ $self->{ignore_package} ]
            unless eval { @{ $self->{ignore_package} } };

        @i_pack_re
            = map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $self->{ignore_package} };
    }

    my $p = __PACKAGE__;
    push @i_pack_re, qr/^\Q$p\E$/;

    if ( $self->{ignore_class} ) {
        $self->{ignore_class} = [ $self->{ignore_class} ]
            unless ref $self->{ignore_class};
        %i_class = map { $_ => 1 } @{ $self->{ignore_class} };
    }

    my $user_filter = $self->{frame_filter};

    return sub {
        return 0 if grep { $_[0]{caller}[0] =~ /$_/ } @i_pack_re;
        return 0 if grep { $_[0]{caller}[0]->isa($_) } keys %i_class;

        if ($user_filter) {
            return $user_filter->( $_[0] );
        }

        return 1;
    };
}

sub _add_frame {
    my $self = shift;
    my $c    = shift;
    my $p    = shift;

    # eval and is_require are only returned when applicable under 5.00503.
    push @$c, ( undef, undef ) if scalar @$c == 6;

    push @{ $self->{frames} },
        Devel::StackTrace::Frame->new(
        $c,
        $p,
        $self->{respect_overload},
        $self->{max_arg_length},
        $self->{message},
        $self->{indent}
        );
}

sub next_frame {
    my $self = shift;

    # reset to top if necessary.
    $self->{index} = -1 unless defined $self->{index};

    my @f = $self->frames;
    if ( defined $f[ $self->{index} + 1 ] ) {
        return $f[ ++$self->{index} ];
    }
    else {
        $self->{index} = undef;
        ## no critic (Subroutines::ProhibitExplicitReturnUndef)
        return undef;
    }
}

sub prev_frame {
    my $self = shift;

    my @f = $self->frames;

    # reset to top if necessary.
    $self->{index} = scalar @f unless defined $self->{index};

    if ( defined $f[ $self->{index} - 1 ] && $self->{index} >= 1 ) {
        return $f[ --$self->{index} ];
    }
    else {
        ## no critic (Subroutines::ProhibitExplicitReturnUndef)
        $self->{index} = undef;
        return undef;
    }
}

sub reset_pointer {
    my $self = shift;

    $self->{index} = undef;

    return;
}

sub frames {
    my $self = shift;

    if (@_) {
        die
            "Devel::StackTrace->frames can only take Devel::StackTrace::Frame args\n"
            if grep { !$_->isa('Devel::StackTrace::Frame') } @_;

        $self->{frames} = \@_;
        delete $self->{raw};
    }
    else {
        $self->_make_frames if $self->{raw};
    }

    return @{ $self->{frames} };
}

sub frame {
    my $self = shift;
    my $i    = shift;

    return unless defined $i;

    return ( $self->frames )[$i];
}

sub frame_count {
    my $self = shift;

    return scalar( $self->frames );
}

sub message { $_[0]->{message} }

sub as_string {
    my $self = shift;
    my $p    = shift;

    my @frames = $self->frames;
    if (@frames) {
        my $st    = q{};
        my $first = 1;
        for my $f (@frames) {
            $st .= $f->as_string( $first, $p ) . "\n";
            $first = 0;
        }

        return $st;
    }

    my $msg = $self->message;
    return $msg if defined $msg;

    return 'Trace begun';
}

{
    ## no critic (Modules::ProhibitMultiplePackages, ClassHierarchies::ProhibitExplicitISA)
    package    # hide from PAUSE
        Devel::StackTraceFrame;

    our @ISA = 'Devel::StackTrace::Frame';
}

1;

# ABSTRACT: An object representing a stack trace

__END__