File Coverage

blib/lib/Devel/StackTrace.pm

Criterion	Covered	Total	%
statement	131	131	100.0
branch	47	54	87.0
condition	15	20	75.0
subroutine	21	21	100.0
pod	8	8	100.0
total	222	234	94.8

package Devel::StackTrace;

use 5.006;

use strict;
use warnings;

our $VERSION = '2.02';

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)
        @args = $self->{no_args} ? () : @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 as_string {
    my $self = shift;
    my $p    = shift;

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

    return $st;
}

{
    ## 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__