Profile of Devel/Backtrace/Point.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:23:21 2012

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

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 3.35ms | 4.75ms | Devel::Backtrace::Point::::BEGIN@6Devel::Backtrace::Point::BEGIN@6
1 | 1 | 1 | 18µs | 52µs | Devel::Backtrace::Point::::BEGIN@26Devel::Backtrace::Point::BEGIN@26
1 | 1 | 1 | 16µs | 62µs | Devel::Backtrace::Point::::BEGIN@29Devel::Backtrace::Point::BEGIN@29
1 | 1 | 1 | 15µs | 100µs | Devel::Backtrace::Point::::BEGIN@25Devel::Backtrace::Point::BEGIN@25
1 | 1 | 1 | 13µs | 15µs | Devel::Backtrace::Point::::BEGIN@2Devel::Backtrace::Point::BEGIN@2
1 | 1 | 1 | 11µs | 14µs | Devel::Backtrace::Point::::BEGIN@27Devel::Backtrace::Point::BEGIN@27
1 | 1 | 1 | 8µs | 47µs | Devel::Backtrace::Point::::BEGIN@5Devel::Backtrace::Point::BEGIN@5
1 | 1 | 1 | 7µs | 15µs | Devel::Backtrace::Point::::BEGIN@3Devel::Backtrace::Point::BEGIN@3
0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::::_virtlevelDevel::Backtrace::Point::_virtlevel
0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::::by_indexDevel::Backtrace::Point::by_index
0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::::called_packageDevel::Backtrace::Point::called_package
0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::::newDevel::Backtrace::Point::new
0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::::to_long_stringDevel::Backtrace::Point::to_long_string
0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::::to_stringDevel::Backtrace::Point::to_string

Call graph for these subroutines as a Graphviz dot language file.

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 use strict; # 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 use warnings; # 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 use Carp; # 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 use String::Escape qw(printable); # 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 use base qw(Class::Accessor::Fast); # 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 use overload '""' => \&to_string; # 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 use constant; # 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 BEGIN {
30 | 5 | 14µ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 |  |  |  |  | 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 |  |  |  |  | while (@known_fields > $supported_fields_number) {
40 |  |  |  |  | pop @known_fields;
41 |  |  |  |  | }
42 |  |  |  |  |
43 |  |  |  |  | # If not all supported fields are known, add placeholders
44 |  |  |  |  | while (@known_fields < $supported_fields_number) {
45 |  |  |  |  | push @known_fields, "_unknown".scalar(@known_fields);
46 |  |  |  |  | }
47 |  |  |  |  |
48 |  |  | 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__