Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Devel/Backtrace/Point.pm |
Statements | Executed 34 statements in 958µs |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 3.35ms | 4.75ms | BEGIN@6 | Devel::Backtrace::Point::
1 | 1 | 1 | 18µs | 52µs | BEGIN@26 | Devel::Backtrace::Point::
1 | 1 | 1 | 16µs | 62µs | BEGIN@29 | Devel::Backtrace::Point::
1 | 1 | 1 | 15µs | 100µs | BEGIN@25 | Devel::Backtrace::Point::
1 | 1 | 1 | 13µs | 15µs | BEGIN@2 | Devel::Backtrace::Point::
1 | 1 | 1 | 11µs | 14µs | BEGIN@27 | Devel::Backtrace::Point::
1 | 1 | 1 | 8µs | 47µs | BEGIN@5 | Devel::Backtrace::Point::
1 | 1 | 1 | 7µs | 15µs | BEGIN@3 | Devel::Backtrace::Point::
0 | 0 | 0 | 0s | 0s | _virtlevel | Devel::Backtrace::Point::
0 | 0 | 0 | 0s | 0s | by_index | Devel::Backtrace::Point::
0 | 0 | 0 | 0s | 0s | called_package | Devel::Backtrace::Point::
0 | 0 | 0 | 0s | 0s | new | Devel::Backtrace::Point::
0 | 0 | 0 | 0s | 0s | to_long_string | Devel::Backtrace::Point::
0 | 0 | 0 | 0s | 0s | to_string | Devel::Backtrace::Point::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Devel::Backtrace::Point; | ||||
2 | 3 | 17µs | 2 | 17µs | # spent 15µs (13+2) within Devel::Backtrace::Point::BEGIN@2 which was called:
# once (13µs+2µs) by Devel::Backtrace::BEGIN@4 at line 2 # spent 15µs making 1 call to Devel::Backtrace::Point::BEGIN@2
# spent 2µs making 1 call to strict::import |
3 | 3 | 28µs | 2 | 22µs | # spent 15µs (7+8) within Devel::Backtrace::Point::BEGIN@3 which was called:
# once (7µs+8µs) by Devel::Backtrace::BEGIN@4 at line 3 # spent 15µs making 1 call to Devel::Backtrace::Point::BEGIN@3
# spent 8µs making 1 call to warnings::import |
4 | 1 | 700ns | our $VERSION = '0.11'; | ||
5 | 3 | 21µs | 2 | 87µs | # spent 47µs (8+39) within Devel::Backtrace::Point::BEGIN@5 which was called:
# once (8µs+39µs) by Devel::Backtrace::BEGIN@4 at line 5 # spent 47µs making 1 call to Devel::Backtrace::Point::BEGIN@5
# spent 39µs making 1 call to Exporter::import |
6 | 3 | 139µs | 2 | 4.88ms | # spent 4.75ms (3.35+1.41) within Devel::Backtrace::Point::BEGIN@6 which was called:
# once (3.35ms+1.41ms) by Devel::Backtrace::BEGIN@4 at line 6 # spent 4.75ms making 1 call to Devel::Backtrace::Point::BEGIN@6
# spent 121µs making 1 call to Exporter::import |
7 | |||||
8 | =head1 NAME | ||||
9 | |||||
10 | Devel::Backtrace::Point - Object oriented access to the information caller() | ||||
11 | provides | ||||
12 | |||||
13 | =head1 SYNOPSIS | ||||
14 | |||||
15 | print Devel::Backtrace::Point->new([caller(0)])->to_long_string; | ||||
16 | |||||
17 | =head1 DESCRIPTION | ||||
18 | |||||
19 | This class is a nice way to access all the information caller provides on a | ||||
20 | given level. It is used by L<Devel::Backtrace>, which generates an array of | ||||
21 | all trace points. | ||||
22 | |||||
23 | =cut | ||||
24 | |||||
25 | 3 | 34µs | 2 | 185µs | # spent 100µs (15+85) within Devel::Backtrace::Point::BEGIN@25 which was called:
# once (15µs+85µs) by Devel::Backtrace::BEGIN@4 at line 25 # spent 100µs making 1 call to Devel::Backtrace::Point::BEGIN@25
# spent 85µs making 1 call to base::import |
26 | 3 | 25µs | 2 | 87µs | # spent 52µs (18+35) within Devel::Backtrace::Point::BEGIN@26 which was called:
# once (18µs+35µs) by Devel::Backtrace::BEGIN@4 at line 26 # spent 52µs making 1 call to Devel::Backtrace::Point::BEGIN@26
# spent 35µs making 1 call to overload::import |
27 | 3 | 98µs | 2 | 18µs | # spent 14µs (11+3) within Devel::Backtrace::Point::BEGIN@27 which was called:
# once (11µs+3µs) by Devel::Backtrace::BEGIN@4 at line 27 # spent 14µs making 1 call to Devel::Backtrace::Point::BEGIN@27
# spent 3µs making 1 call to constant::import |
28 | |||||
29 | # spent 62µs (16+46) within Devel::Backtrace::Point::BEGIN@29 which was called:
# once (16µs+46µs) by Devel::Backtrace::BEGIN@4 at line 49 | ||||
30 | 1 | 2µs | my @known_fields = (qw(package filename line subroutine hasargs wantarray | ||
31 | evaltext is_require hints bitmask hinthash)); | ||||
32 | # The number of caller()'s return values depends on the perl version. For | ||||
33 | # instance, hinthash is not available below perl 5.9. We try and see how | ||||
34 | # many fields are supported | ||||
35 | 1 | 6µs | my $supported_fields_number = () = caller(0) | ||
36 | or die "Caller doesn't work as expected"; | ||||
37 | |||||
38 | # If not all known fields are supported, remove some | ||||
39 | 1 | 900ns | while (@known_fields > $supported_fields_number) { | ||
40 | pop @known_fields; | ||||
41 | } | ||||
42 | |||||
43 | # If not all supported fields are known, add placeholders | ||||
44 | 1 | 800ns | while (@known_fields < $supported_fields_number) { | ||
45 | push @known_fields, "_unknown".scalar(@known_fields); | ||||
46 | } | ||||
47 | |||||
48 | 1 | 5µs | 1 | 45µs | constant->import (FIELDS => @known_fields); # spent 45µs making 1 call to constant::import |
49 | 1 | 546µs | 1 | 62µs | } # spent 62µs making 1 call to Devel::Backtrace::Point::BEGIN@29 |
50 | |||||
51 | =head1 METHODS | ||||
52 | |||||
53 | =head2 $p->package, $p->filename, $p->line, $p->subroutine, $p->hasargs, | ||||
54 | $p->wantarray, $p->evaltext, $p->is_require, $p->hints, $p->bitmask, | ||||
55 | $p->hinthash | ||||
56 | |||||
57 | See L<perlfunc/caller> for documentation of these fields. | ||||
58 | |||||
59 | hinthash is only available in perl 5.9 and higher. When this module is loaded, | ||||
60 | it tests how many values caller returns. Depending on the result, it adds the | ||||
61 | necessary accessors. Thus, you should be able to find out if your perl | ||||
62 | supports hinthash by using L<UNIVERSAL/can>: | ||||
63 | |||||
64 | Devel::Backtrace::Point->can('hinthash'); | ||||
65 | |||||
66 | =cut | ||||
67 | |||||
68 | 1 | 8µs | 2 | 337µs | __PACKAGE__->mk_ro_accessors(FIELDS); # spent 333µs making 1 call to Class::Accessor::mk_ro_accessors
# spent 4µs making 1 call to constant::__ANON__[constant.pm:141] |
69 | |||||
70 | =head2 $p->level | ||||
71 | |||||
72 | This is the level given to new(). It's intended to be the parameter that was | ||||
73 | given to caller(). | ||||
74 | |||||
75 | =cut | ||||
76 | |||||
77 | 1 | 1µs | 1 | 30µs | __PACKAGE__->mk_ro_accessors('level'); # spent 30µs making 1 call to Class::Accessor::mk_ro_accessors |
78 | |||||
79 | =head2 $p->called_package | ||||
80 | |||||
81 | This returns the package that $p->subroutine is in. | ||||
82 | |||||
83 | If $p->subroutine does not contain '::', then '(unknown)' is returned. This is | ||||
84 | the case if $p->subroutine is '(eval)'. | ||||
85 | |||||
86 | =cut | ||||
87 | |||||
88 | sub called_package { | ||||
89 | my $this = shift; | ||||
90 | my $sub = $this->subroutine; | ||||
91 | |||||
92 | my $idx = rindex($sub, '::'); | ||||
93 | return '(unknown)' if -1 == $idx; | ||||
94 | return substr($sub, 0, $idx); | ||||
95 | } | ||||
96 | |||||
97 | =head2 $p->by_index($i) | ||||
98 | |||||
99 | You may also access the fields by their index in the list that caller() | ||||
100 | returns. This may be useful if some future perl version introduces a new field | ||||
101 | for caller, and the author of this module doesn't react in time. | ||||
102 | |||||
103 | =cut | ||||
104 | |||||
105 | sub by_index { | ||||
106 | my ($this, $idx) = @_; | ||||
107 | my $fieldname = (FIELDS)[$idx]; | ||||
108 | unless (defined $fieldname) { | ||||
109 | croak "There is no field with index $idx."; | ||||
110 | } | ||||
111 | return $this->$fieldname(); | ||||
112 | } | ||||
113 | |||||
114 | =head2 new([caller($i)]) | ||||
115 | |||||
116 | This constructs a Devel::Backtrace object. The argument must be a reference to | ||||
117 | an array holding the return values of caller(). This array must have either | ||||
118 | three or ten elements (or eleven if hinthash is supported) (see | ||||
119 | L<perlfunc/caller>). | ||||
120 | |||||
121 | Optional additional parameters: | ||||
122 | |||||
123 | -format => 'formatstring', | ||||
124 | -level => $i | ||||
125 | |||||
126 | The format string will be used as a default for to_string(). | ||||
127 | |||||
128 | The level should be the parameter that was given to caller() to obtain the | ||||
129 | caller information. | ||||
130 | |||||
131 | =cut | ||||
132 | |||||
133 | 1 | 1µs | 1 | 29µs | __PACKAGE__->mk_ro_accessors('_format'); # spent 29µs making 1 call to Class::Accessor::mk_ro_accessors |
134 | 1 | 8µs | 1 | 40µs | __PACKAGE__->mk_accessors('_skip'); # spent 40µs making 1 call to Class::Accessor::mk_accessors |
135 | |||||
136 | sub new { | ||||
137 | my $class = shift; | ||||
138 | my ($caller, %opts) = @_; | ||||
139 | |||||
140 | my %data; | ||||
141 | |||||
142 | unless ('ARRAY' eq ref $caller) { | ||||
143 | croak 'That is not an array reference.'; | ||||
144 | } | ||||
145 | |||||
146 | if (@$caller == (() = FIELDS)) { | ||||
147 | for (FIELDS) { | ||||
148 | $data{$_} = $caller->[keys %data] | ||||
149 | } | ||||
150 | } elsif (@$caller == 3) { | ||||
151 | @data{qw(package filename line)} = @$caller; | ||||
152 | } else { | ||||
153 | croak 'That does not look like the return values of caller.'; | ||||
154 | } | ||||
155 | |||||
156 | for my $opt (keys %opts) { | ||||
157 | if ('-format' eq $opt) { | ||||
158 | $data{'_format'} = $opts{$opt}; | ||||
159 | } elsif ('-level' eq $opt) { | ||||
160 | $data{'level'} = $opts{$opt}; | ||||
161 | } elsif ('-skip' eq $opt) { | ||||
162 | $data{'_skip'} = $opts{$opt}; | ||||
163 | } else { | ||||
164 | croak "Unknown option $opt"; | ||||
165 | } | ||||
166 | } | ||||
167 | |||||
168 | return $class->SUPER::new(\%data); | ||||
169 | } | ||||
170 | |||||
171 | sub _virtlevel { | ||||
172 | my $this = shift; | ||||
173 | |||||
174 | return $this->level - ($this->_skip || 0); | ||||
175 | } | ||||
176 | |||||
177 | =head2 $tracepoint->to_string() | ||||
178 | |||||
179 | Returns a string of the form "Blah::subname called from main (foo.pl:17)". | ||||
180 | This means that the subroutine C<subname> from package C<Blah> was called by | ||||
181 | package C<main> in C<foo.pl> line 17. | ||||
182 | |||||
183 | If you print a C<Devel::Backtrace::Point> object or otherwise treat it as a | ||||
184 | string, to_string() will be called automatically due to overloading. | ||||
185 | |||||
186 | Optional parameters: -format => 'formatstring' | ||||
187 | |||||
188 | The format string changes the appearance of the return value. It can contain | ||||
189 | C<%p> (package), C<%c> (called_package), C<%f> (filename), C<%l> (line), C<%s> | ||||
190 | (subroutine), C<%a> (hasargs), C<%e> (evaltext), C<%r> (is_require), C<%h> | ||||
191 | (hints), C<%b> (bitmask), C<%i> (level), C<%I> (level, see below). | ||||
192 | |||||
193 | The difference between C<%i> and C<%I> is that the former is the argument to | ||||
194 | caller() while the latter is actually the index in $backtrace->points(). C<%i> | ||||
195 | and C<%I> are different if C<-start>, skipme() or skipmysubs() is used in | ||||
196 | L<Devel::Backtrace>. | ||||
197 | |||||
198 | If no format string is given, the one passed to C<new> will be used. If none | ||||
199 | was given to C<new>, the format string defaults to 'default', which is an | ||||
200 | abbreviation for C<%s called from %p (%f:%l)>. | ||||
201 | |||||
202 | Format strings have been added in Devel-Backtrace-0.10. | ||||
203 | |||||
204 | =cut | ||||
205 | |||||
206 | 1 | 1µs | my %formats = ( | ||
207 | 'default' => '%s called from %p (%f:%l)', | ||||
208 | ); | ||||
209 | |||||
210 | 1 | 7µs | my %percent = ( | ||
211 | 'p' => 'package', | ||||
212 | 'c' => 'called_package', | ||||
213 | 'f' => 'filename', | ||||
214 | 'l' => 'line', | ||||
215 | 's' => 'subroutine', | ||||
216 | 'a' => 'hasargs', | ||||
217 | 'w' => 'wantarray', | ||||
218 | 'e' => 'evaltext', | ||||
219 | 'r' => 'is_require', | ||||
220 | 'h' => 'hints', | ||||
221 | 'b' => 'bitmask', | ||||
222 | 'i' => 'level', | ||||
223 | 'I' => '_virtlevel', | ||||
224 | ); | ||||
225 | |||||
226 | sub to_string { | ||||
227 | my ($this, @opts) = @_; | ||||
228 | |||||
229 | my %opts; | ||||
230 | if (defined $opts[0]) { # check that we are not called as stringification | ||||
231 | %opts = @opts; | ||||
232 | } | ||||
233 | |||||
234 | my $format = $this->_format(); | ||||
235 | |||||
236 | for my $opt (keys %opts) { | ||||
237 | if ($opt eq '-format') { | ||||
238 | $format = $opts{$opt}; | ||||
239 | } else { | ||||
240 | croak "Unknown option $opt"; | ||||
241 | } | ||||
242 | } | ||||
243 | |||||
244 | $format = 'default' unless defined $format; | ||||
245 | $format = $formats{$format} if exists $formats{$format}; | ||||
246 | |||||
247 | my $result = $format; | ||||
248 | $result =~ s{%(\S)} { | ||||
249 | my $percent = $percent{$1} or croak "Unknown symbol %$1\n"; | ||||
250 | my $val = $this->$percent(); | ||||
251 | defined($val) ? printable($val) : 'undef'; | ||||
252 | }ge; | ||||
253 | |||||
254 | return $result; | ||||
255 | } | ||||
256 | |||||
257 | =head2 $tracepoint->to_long_string() | ||||
258 | |||||
259 | This returns a string which lists all available fields in a table that spans | ||||
260 | several lines. | ||||
261 | |||||
262 | Example: | ||||
263 | |||||
264 | package: main | ||||
265 | filename: /tmp/foo.pl | ||||
266 | line: 6 | ||||
267 | subroutine: main::foo | ||||
268 | hasargs: 1 | ||||
269 | wantarray: undef | ||||
270 | evaltext: undef | ||||
271 | is_require: undef | ||||
272 | hints: 0 | ||||
273 | bitmask: \00\00\00\00\00\00\00\00\00\00\00\00 | ||||
274 | |||||
275 | hinthash is not included in the output, as it is a hash. | ||||
276 | |||||
277 | =cut | ||||
278 | |||||
279 | sub to_long_string { | ||||
280 | my $this = shift; | ||||
281 | return join '', | ||||
282 | map { | ||||
283 | "$_: " . | ||||
284 | (defined ($this->{$_}) ? printable($this->{$_}) : 'undef') | ||||
285 | . "\n" | ||||
286 | } grep { | ||||
287 | ! /^_/ && 'hinthash' ne $_ | ||||
288 | } FIELDS; | ||||
289 | } | ||||
290 | |||||
291 | =head2 FIELDS | ||||
292 | |||||
293 | This constant contains a list of all the available field names. The number of | ||||
294 | fields depends on your perl version. | ||||
295 | |||||
296 | =cut | ||||
297 | |||||
298 | 1 | 8µs | 1 | ||
299 | __END__ |