File Coverage

File:local/lib/perl5/Devel/StackTrace.pm
Coverage:12.2%

linestmtbrancondsubtimecode
1package Devel::StackTrace;
2$Devel::StackTrace::VERSION = '1.32';
3
6
6
6
64
10
use 5.006;
4
5
6
6
6
6
14
8
86
use strict;
6
6
6
6
6
13
5
86
use warnings;
7
8
6
6
6
6
1209
10
117
use Devel::StackTrace::Frame;
9
6
6
6
6
22
5
85
use File::Spec;
10
6
6
6
6
16
6
438
use Scalar::Util qw( blessed );
11
12use overload
13
6
4025
    '""'     => \&as_string,
14
6
6
6
18
6
    fallback => 1;
15
16sub new {
17
0
0
    my $class = shift;
18
0
    my %p     = @_;
19
20    # Backwards compatibility - this parameter was renamed to no_refs
21    # ages ago.
22
0
0
    $p{no_refs} = delete $p{no_object_refs}
23        if exists $p{no_object_refs};
24
25
0
    my $self = bless {
26        index  => undef,
27        frames => [],
28        raw    => [],
29        %p,
30    }, $class;
31
32
0
    $self->_record_caller_data();
33
34
0
    return $self;
35}
36
37sub _record_caller_data {
38
0
0
    my $self = shift;
39
40
0
0
    my $filter = $self->{filter_frames_early} && $self->_make_frame_filter();
41
42    # We exclude this method by starting one frame back.
43
0
    my $x = 1;
44
0
0
    while (
45        my @c
46        = $self->{no_args}
47        ? caller( $x++ )
48        : do {
49            package    # the newline keeps dzil from adding a version here
50                DB;
51
0
            @DB::args = ();
52
0
            caller( $x++ );
53        }
54        ) {
55
56
0
        my @args;
57
58
0
0
        @args = $self->{no_args} ? () : @DB::args;
59
60
0
        my $raw = {
61            caller => \@c,
62            args => \@args,
63        };
64
65
0
0
0
        next if $filter && !$filter->($raw);
66
67
0
0
        if ( $self->{no_refs} ) {
68
0
0
0
0
            $raw->{args} = [ map { ref $_ ? $self->_ref_to_string($_) : $_ } @{$raw->{args}} ];
69        }
70
71
0
0
        push @{ $self->{raw} }, $raw;
72    }
73}
74
75sub _ref_to_string {
76
0
0
    my $self = shift;
77
0
    my $ref  = shift;
78
79
0
0
0
    return overload::AddrRef($ref)
80        if blessed $ref && $ref->isa('Exception::Class::Base');
81
82
0
0
    return overload::AddrRef($ref) unless $self->{respect_overload};
83
84
0
    local $@;
85
0
    local $SIG{__DIE__};
86
87
0
0
    my $str = eval { $ref . '' };
88
89
0
0
    return $@ ? overload::AddrRef($ref) : $str;
90}
91
92sub _make_frames {
93
0
0
    my $self = shift;
94
95
0
0
    my $filter = !$self->{filter_frames_early} && $self->_make_frame_filter();
96
97
0
    my $raw = delete $self->{raw};
98
0
0
    for my $r ( @{$raw} ) {
99
0
0
0
        next if $filter && ! $filter->($r);
100
101
0
        $self->_add_frame( $r->{caller}, $r->{args} );
102    }
103}
104
105my $default_filter = sub { 1 };
106
107sub _make_frame_filter {
108
0
0
    my $self = shift;
109
110
0
    my ( @i_pack_re, %i_class );
111
0
0
    if ( $self->{ignore_package} ) {
112
0
        local $@;
113
0
        local $SIG{__DIE__};
114
115        $self->{ignore_package} = [ $self->{ignore_package} ]
116
0
0
0
0
            unless eval { @{ $self->{ignore_package} } };
117
118        @i_pack_re
119
0
0
0
0
            = map { ref $_ ? $_ : qr/^\Q$_\E$/ } @{ $self->{ignore_package} };
120    }
121
122
0
    my $p = __PACKAGE__;
123
0
    push @i_pack_re, qr/^\Q$p\E$/;
124
125
0
0
    if ( $self->{ignore_class} ) {
126
0
0
        $self->{ignore_class} = [ $self->{ignore_class} ]
127            unless ref $self->{ignore_class};
128
0
0
0
        %i_class = map { $_ => 1 } @{ $self->{ignore_class} };
129    }
130
131
0
    my $user_filter = $self->{frame_filter};
132
133    return sub {
134
0
0
0
0
        return 0 if grep { $_[0]{caller}[0] =~ /$_/ } @i_pack_re;
135
0
0
0
        return 0 if grep { $_[0]{caller}[0]->isa($_) } keys %i_class;
136
137
0
0
        if ($user_filter) {
138
0
            return $user_filter->( $_[0] );
139        }
140
141
0
        return 1;
142
0
    };
143}
144
145sub _add_frame {
146
0
0
    my $self = shift;
147
0
    my $c    = shift;
148
0
    my $p    = shift;
149
150    # eval and is_require are only returned when applicable under 5.00503.
151
0
0
    push @$c, ( undef, undef ) if scalar @$c == 6;
152
153
0
0
    push @{ $self->{frames} },
154        Devel::StackTrace::Frame->new(
155        $c,
156        $p,
157        $self->{respect_overload},
158        $self->{max_arg_length},
159        $self->{message},
160        $self->{indent}
161        );
162}
163
164sub next_frame {
165
0
0
    my $self = shift;
166
167    # reset to top if necessary.
168
0
0
    $self->{index} = -1 unless defined $self->{index};
169
170
0
    my @f = $self->frames();
171
0
0
    if ( defined $f[ $self->{index} + 1 ] ) {
172
0
        return $f[ ++$self->{index} ];
173    }
174    else {
175
0
        $self->{index} = undef;
176
0
        return undef;
177    }
178}
179
180sub prev_frame {
181
0
0
    my $self = shift;
182
183
0
    my @f = $self->frames();
184
185    # reset to top if necessary.
186
0
0
    $self->{index} = scalar @f unless defined $self->{index};
187
188
0
0
0
    if ( defined $f[ $self->{index} - 1 ] && $self->{index} >= 1 ) {
189
0
        return $f[ --$self->{index} ];
190    }
191    else {
192
0
        $self->{index} = undef;
193
0
        return undef;
194    }
195}
196
197sub reset_pointer {
198
0
0
    my $self = shift;
199
200
0
    $self->{index} = undef;
201}
202
203sub frames {
204
0
0
    my $self = shift;
205
206
0
0
    if (@_) {
207
0
        die
208            "Devel::StackTrace->frames() can only take Devel::StackTrace::Frame args\n"
209
0
0
            if grep { !$_->isa('Devel::StackTrace::Frame') } @_;
210
211
0
        $self->{frames} = \@_;
212    }
213    else {
214
0
0
        $self->_make_frames() if $self->{raw};
215    }
216
217
0
0
    return @{ $self->{frames} };
218}
219
220sub frame {
221
0
0
    my $self = shift;
222
0
    my $i    = shift;
223
224
0
0
    return unless defined $i;
225
226
0
    return ( $self->frames() )[$i];
227}
228
229sub frame_count {
230
0
0
    my $self = shift;
231
232
0
    return scalar( $self->frames() );
233}
234
235sub as_string {
236
0
0
    my $self = shift;
237
0
    my $p    = shift;
238
239
0
    my $st    = '';
240
0
    my $first = 1;
241
0
    foreach my $f ( $self->frames() ) {
242
0
        $st .= $f->as_string( $first, $p ) . "\n";
243
0
        $first = 0;
244    }
245
246
0
    return $st;
247}
248
249{
250    package
251        Devel::StackTraceFrame;
252
253    our @ISA = 'Devel::StackTrace::Frame';
254}
255
2561;
257
258# ABSTRACT: An object representing a stack trace
259