| 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 | Devel::Backtrace::Point::BEGIN@6 |
| 1 | 1 | 1 | 18µs | 52µs | Devel::Backtrace::Point::BEGIN@26 |
| 1 | 1 | 1 | 16µs | 62µs | Devel::Backtrace::Point::BEGIN@29 |
| 1 | 1 | 1 | 15µs | 100µs | Devel::Backtrace::Point::BEGIN@25 |
| 1 | 1 | 1 | 13µs | 15µs | Devel::Backtrace::Point::BEGIN@2 |
| 1 | 1 | 1 | 11µs | 14µs | Devel::Backtrace::Point::BEGIN@27 |
| 1 | 1 | 1 | 8µs | 47µs | Devel::Backtrace::Point::BEGIN@5 |
| 1 | 1 | 1 | 7µs | 15µs | Devel::Backtrace::Point::BEGIN@3 |
| 0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::_virtlevel |
| 0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::by_index |
| 0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::called_package |
| 0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::new |
| 0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::to_long_string |
| 0 | 0 | 0 | 0s | 0s | Devel::Backtrace::Point::to_string |
| 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 | 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__ |