File Coverage

blib/lib/Devel/Backtrace.pm
Criterion Covered Total %
statement 60 61 98.3
branch 11 12 91.6
condition 6 8 75.0
subroutine 13 13 100.0
pod 7 7 100.0
total 97 101 96.0


line stmt bran cond sub pod time code
1             package Devel::Backtrace;
2 5     5   46370 use strict;
  5         9  
  5         118  
3 5     5   17 use warnings;
  5         5  
  5         127  
4 5     5   1746 use Devel::Backtrace::Point;
  5         10  
  5         22  
5 5     5   151 use Carp;
  5         5  
  5         338  
6              
7 5     5   20 use overload '""' => \&to_string;
  5         5  
  5         25  
8              
9             =head1 NAME
10              
11             Devel::Backtrace - Object-oriented backtrace
12              
13             =head1 VERSION
14              
15             This is version 0.11_01.
16              
17             =cut
18              
19             our $VERSION = '0.11_01';
20              
21             =head1 SYNOPSIS
22              
23             my $backtrace = Devel::Backtrace->new;
24              
25             print $backtrace; # use automatic stringification
26             # See EXAMPLES to see what the output might look like
27              
28             print $backtrace->point(0)->line;
29              
30             =head1 METHODS
31              
32             =head2 Devel::Backtrace->new()
33              
34             Optional parameters: -start => $start, -format => $format
35              
36             If only one parameter is given, it will be used as $start.
37              
38             Constructs a new C which is filled with all the information
39             C provides, where C<$i> starts from C<$start>. If no argument is
40             given, C<$start> defaults to 0.
41              
42             If C<$start> is 1 (or higher), the backtrace won't contain the information that
43             (and where) Devel::Backtrace::new() was called.
44              
45             =cut
46              
47             sub new {
48 13     13 1 2100 my $class = shift;
49 13         27 my (@opts) = @_;
50              
51 13         14 my $start;
52             my %pointopts;
53              
54 13 100       39 if (1 == @opts) {
55 6         8 $start = shift @opts;
56             }
57 13         40 while (my $opt = shift @opts) {
58 3 100       11 if ('-format' eq $opt) {
    50          
59 1         4 $pointopts{$opt} = shift @opts;
60             } elsif ('-start' eq $opt) {
61 2         8 $start = shift @opts;
62             } else {
63 0         0 croak "Unknown option $opt";
64             }
65             }
66              
67 13 100       28 if (defined $start) {
68 8         15 $pointopts{'-skip'} = $start;
69             } else {
70 5         8 $start = 0;
71             }
72              
73 13         66 my @backtrace;
74 13         111 for (my $deep = $start; my @caller = caller($deep); ++$deep) {
75 67         1039 push @backtrace, Devel::Backtrace::Point->new(
76             \@caller,
77             -level => $deep,
78             %pointopts,
79             );
80             }
81              
82 13         194 return bless \@backtrace, $class;
83             }
84              
85             =head2 $backtrace->point($i)
86              
87             Returns the i'th tracepoint as a L object (see its documentation
88             for how to access every bit of information).
89              
90             Note that the following code snippet will print the information of
91             C:
92              
93             print Devel::Backtrace->new($start)->point($i)
94              
95             =cut
96              
97             sub point {
98 42     42 1 2015 my $this = shift;
99 42         40 my ($i) = @_;
100 42         136 return $this->[$i];
101             }
102              
103             =head2 $backtrace->points()
104              
105             Returns a list of all tracepoints. In scalar context, the number of
106             tracepoints is returned.
107              
108             =cut
109              
110             sub points {
111 20     20 1 28 my $this = shift;
112 20         113 return @$this;
113             }
114              
115             =head2 $backtrace->skipme([$package])
116              
117             This method deletes all leading tracepoints that contain information about calls
118             within C<$package>. Afterwards the C<$backtrace> will look as though it had
119             been created with a higher value of C<$start>.
120              
121             If the optional parameter C<$package> is not given, it defaults to the calling
122             package.
123              
124             The effect is similar to what the L module does.
125              
126             This module ships with an example "skipme.pl" that demonstrates how to use this
127             method. See also L.
128              
129             =cut
130              
131             sub skipme {
132 7     7 1 13 my $this = shift;
133 7 100       12 my $package = @_ ? $_[0] : caller;
134              
135 7         8 my $skip = 0;
136 7         8 my $skipped;
137 7   66     76 while (@$this and $package eq $this->point(0)->package) {
138 10         86 $skipped = shift @$this;
139 10         31 $skip++;
140             }
141 7         77 $this->_adjustskip($skip);
142 7         232 return $skipped;
143             }
144              
145             sub _adjustskip {
146 13     13   24 my ($this, $newskip) = @_;
147              
148 13   100     16 $_->_skip($newskip + ($_->_skip || 0)) for $this->points;
149             }
150              
151             =head2 $backtrace->skipmysubs([$package])
152              
153             This method is like C except that it deletes calls I the package
154             rather than calls I the package.
155              
156             Before discarding those calls, C is called. This is because usually
157             the topmost call in the stack is to Devel::Backtrace->new, which would not be
158             catched by C otherwise.
159              
160             This means that skipmysubs usually deletes more lines than skipme would.
161              
162             C was added in Devel::Backtrace version 0.06.
163              
164             See also L and the example "skipme.pl".
165              
166             =cut
167              
168             sub skipmysubs {
169 6     6 1 14 my $this = shift;
170 6 100       16 my $package = @_ ? $_[0] : caller;
171              
172 6         18 my $skipped = $this->skipme($package);
173 6         6 my $skip = 0;
174 6   66     19 while (@$this and $package eq $this->point(0)->called_package) {
175 6         8 $skipped = shift @$this;
176 6         16 $skip++;
177             }
178 6         9 $this->_adjustskip($skip);
179 6         147 return $skipped;
180             }
181              
182             =head2 $backtrace->to_string()
183              
184             Returns a string that contains one line for each tracepoint. It will contain
185             the information from C's to_string() method. To get
186             more information, use the to_long_string() method.
187              
188             Note that you don't have to call to_string() if you print a C
189             object or otherwise treat it as a string, as the stringification operator is
190             overloaded.
191              
192             See L.
193              
194             =cut
195              
196             sub to_string {
197 4     4 1 40 my $this = shift;
198 4         10 return join '', map "$_\n", $this->points;
199             }
200              
201              
202             =head2 $backtrace->to_long_string()
203              
204             Returns a very long string that contains several lines for each trace point.
205             The result will contain every available bit of information. See
206             L for an example of what the result
207             looks like.
208              
209             =cut
210              
211             sub to_long_string {
212 1     1 1 294 my $this = shift;
213 1         3 return join "\n", map $_->to_long_string, $this->points;
214             }
215              
216              
217             1
218             __END__