Filename | /usr/lib/perl5/5.14/Carp.pm |
Statements | Executed 417 statements in 5.31ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 232µs | 247µs | BEGIN@3 | Carp::
2 | 1 | 1 | 188µs | 549µs | short_error_loc | Carp::
11 | 2 | 1 | 148µs | 325µs | trusts | Carp::
2 | 1 | 1 | 124µs | 218µs | caller_info | Carp::
14 | 2 | 1 | 113µs | 177µs | get_status | Carp::
1 | 1 | 1 | 69µs | 502µs | carp | Carp::
7 | 1 | 1 | 64µs | 64µs | trusts_directly | Carp::
2 | 1 | 1 | 59µs | 276µs | ret_summary | Carp::
17 | 3 | 1 | 55µs | 55µs | _cgc | Carp::
2 | 2 | 1 | 44µs | 913µs | shortmess | Carp::
1 | 1 | 1 | 42µs | 71µs | format_arg | Carp::
2 | 1 | 1 | 31µs | 856µs | shortmess_heavy | Carp::
1 | 1 | 1 | 31µs | 82µs | BEGIN@341 | Carp::
2 | 1 | 1 | 18µs | 18µs | get_subname | Carp::
1 | 1 | 1 | 17µs | 43µs | BEGIN@4 | Carp::
1 | 1 | 1 | 16µs | 52µs | BEGIN@342 | Carp::
1 | 1 | 1 | 15µs | 495µs | croak | Carp::
1 | 1 | 1 | 15µs | 52µs | BEGIN@46 | Carp::
1 | 1 | 1 | 13µs | 13µs | str_len_trim | Carp::
2 | 2 | 1 | 8µs | 8µs | CORE:subst (opcode) | Carp::
1 | 1 | 1 | 5µs | 5µs | CORE:match (opcode) | Carp::
0 | 0 | 0 | 0s | 0s | cluck | Carp::
0 | 0 | 0 | 0s | 0s | confess | Carp::
0 | 0 | 0 | 0s | 0s | export_fail | Carp::
0 | 0 | 0 | 0s | 0s | long_error_loc | Carp::
0 | 0 | 0 | 0s | 0s | longmess | Carp::
0 | 0 | 0 | 0s | 0s | longmess_heavy | Carp::
0 | 0 | 0 | 0s | 0s | ret_backtrace | Carp::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Carp; | ||||
2 | |||||
3 | 2 | 73µs | 2 | 263µs | # spent 247µs (232+15) within Carp::BEGIN@3 which was called:
# once (232µs+15µs) by DynaLoader::croak at line 3 # spent 247µs making 1 call to Carp::BEGIN@3
# spent 15µs making 1 call to strict::import |
4 | 2 | 431µs | 2 | 69µs | # spent 43µs (17+26) within Carp::BEGIN@4 which was called:
# once (17µs+26µs) by DynaLoader::croak at line 4 # spent 43µs making 1 call to Carp::BEGIN@4
# spent 26µs making 1 call to warnings::import |
5 | |||||
6 | 1 | 2µs | our $VERSION = '1.20'; | ||
7 | |||||
8 | 1 | 1µs | our $MaxEvalLen = 0; | ||
9 | 1 | 500ns | our $Verbose = 0; | ||
10 | 1 | 600ns | our $CarpLevel = 0; | ||
11 | 1 | 500ns | our $MaxArgLen = 64; # How much of each argument to print. 0 = all. | ||
12 | 1 | 500ns | our $MaxArgNums = 8; # How many arguments to print. 0 = all. | ||
13 | |||||
14 | 1 | 500ns | require Exporter; | ||
15 | 1 | 15µs | our @ISA = ('Exporter'); | ||
16 | 1 | 3µs | our @EXPORT = qw(confess croak carp); | ||
17 | 1 | 4µs | our @EXPORT_OK = qw(cluck verbose longmess shortmess); | ||
18 | 1 | 1µs | our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode | ||
19 | |||||
20 | # The members of %Internal are packages that are internal to perl. | ||||
21 | # Carp will not report errors from within these packages if it | ||||
22 | # can. The members of %CarpInternal are internal to Perl's warning | ||||
23 | # system. Carp will not report errors from within these packages | ||||
24 | # either, and will not report calls *to* these packages for carp and | ||||
25 | # croak. They replace $CarpLevel, which is deprecated. The | ||||
26 | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval | ||||
27 | # text and function arguments should be formatted when printed. | ||||
28 | |||||
29 | 1 | 0s | our %CarpInternal; | ||
30 | 1 | 0s | our %Internal; | ||
31 | |||||
32 | # disable these by default, so they can live w/o require Carp | ||||
33 | 1 | 2µs | $CarpInternal{Carp}++; | ||
34 | 1 | 500ns | $CarpInternal{warnings}++; | ||
35 | 1 | 1µs | $Internal{Exporter}++; | ||
36 | 1 | 500ns | $Internal{'Exporter::Heavy'}++; | ||
37 | |||||
38 | # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") | ||||
39 | # then the following method will be called by the Exporter which knows | ||||
40 | # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word | ||||
41 | # 'verbose'. | ||||
42 | |||||
43 | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } | ||||
44 | |||||
45 | sub _cgc { | ||||
46 | 2 | 3.37ms | 2 | 89µs | # spent 52µs (15+37) within Carp::BEGIN@46 which was called:
# once (15µs+37µs) by DynaLoader::croak at line 46 # spent 52µs making 1 call to Carp::BEGIN@46
# spent 37µs making 1 call to strict::unimport |
47 | 34 | 89µs | return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"}; | ||
48 | return; | ||||
49 | } | ||||
50 | |||||
51 | sub longmess { | ||||
52 | # Icky backwards compatibility wrapper. :-( | ||||
53 | # | ||||
54 | # The story is that the original implementation hard-coded the | ||||
55 | # number of call levels to go back, so calls to longmess were off | ||||
56 | # by one. Other code began calling longmess and expecting this | ||||
57 | # behaviour, so the replacement has to emulate that behaviour. | ||||
58 | my $cgc = _cgc(); | ||||
59 | my $call_pack = $cgc ? $cgc->() : caller(); | ||||
60 | if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) { | ||||
61 | return longmess_heavy(@_); | ||||
62 | } | ||||
63 | else { | ||||
64 | local $CarpLevel = $CarpLevel + 1; | ||||
65 | return longmess_heavy(@_); | ||||
66 | } | ||||
67 | } | ||||
68 | |||||
69 | 1 | 500ns | our @CARP_NOT; | ||
70 | |||||
71 | sub shortmess { | ||||
72 | 6 | 34µs | 2 | 13µs | my $cgc = _cgc(); # spent 13µs making 2 calls to Carp::_cgc, avg 7µs/call |
73 | |||||
74 | # Icky backwards compatibility wrapper. :-( | ||||
75 | local @CARP_NOT = $cgc ? $cgc->() : caller(); | ||||
76 | 2 | 856µs | shortmess_heavy(@_); # spent 856µs making 2 calls to Carp::shortmess_heavy, avg 428µs/call | ||
77 | } | ||||
78 | |||||
79 | 1 | 44µs | 1 | 480µs | # spent 495µs (15+480) within Carp::croak which was called:
# once (15µs+480µs) by DynaLoader::croak at line 98 of DynaLoader.pm # spent 480µs making 1 call to Carp::shortmess |
80 | sub confess { die longmess @_ } | ||||
81 | 1 | 71µs | 1 | 433µs | # spent 502µs (69+433) within Carp::carp which was called:
# once (69µs+433µs) by Exporter::Heavy::__ANON__[/usr/lib/perl5/5.14/Exporter/Heavy.pm:52] at line 47 of Exporter/Heavy.pm # spent 433µs making 1 call to Carp::shortmess |
82 | sub cluck { warn longmess @_ } | ||||
83 | |||||
84 | # spent 218µs (124+94) within Carp::caller_info which was called 2 times, avg 109µs/call:
# 2 times (124µs+94µs) by Carp::ret_summary at line 263, avg 109µs/call | ||||
85 | 28 | 117µs | my $i = shift(@_) + 1; | ||
86 | my %call_info; | ||||
87 | 2 | 6µs | my $cgc = _cgc(); # spent 6µs making 2 calls to Carp::_cgc, avg 3µs/call | ||
88 | { | ||||
89 | package DB; | ||||
90 | |||||
- - | |||||
96 | unless ( defined $call_info{pack} ) { | ||||
97 | return (); | ||||
98 | } | ||||
99 | |||||
100 | 2 | 18µs | my $sub_name = Carp::get_subname( \%call_info ); # spent 18µs making 2 calls to Carp::get_subname, avg 9µs/call | ||
101 | if ( $call_info{has_args} ) { | ||||
102 | my @args; | ||||
103 | if ( @DB::args == 1 | ||||
104 | && ref $DB::args[0] eq ref \$i | ||||
105 | && $DB::args[0] == \$i ) { | ||||
106 | @DB::args = (); # Don't let anyone see the address of $i | ||||
107 | local $@; | ||||
108 | my $where = eval { | ||||
109 | my $func = $cgc or return ''; | ||||
110 | my $gv = B::svref_2object($func)->GV; | ||||
111 | my $package = $gv->STASH->NAME; | ||||
112 | my $subname = $gv->NAME; | ||||
113 | return unless defined $package && defined $subname; | ||||
114 | |||||
115 | # returning CORE::GLOBAL::caller isn't useful for tracing the cause: | ||||
116 | return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; | ||||
117 | " in &${package}::$subname"; | ||||
118 | } // ''; | ||||
119 | @args | ||||
120 | = "** Incomplete caller override detected$where; \@DB::args were not set **"; | ||||
121 | } | ||||
122 | else { | ||||
123 | 1 | 71µs | @args = map { Carp::format_arg($_) } @DB::args; # spent 71µs making 1 call to Carp::format_arg | ||
124 | } | ||||
125 | if ( $MaxArgNums and @args > $MaxArgNums ) | ||||
126 | { # More than we want to show? | ||||
127 | $#args = $MaxArgNums; | ||||
128 | push @args, '...'; | ||||
129 | } | ||||
130 | |||||
131 | # Push the args onto the subroutine | ||||
132 | $sub_name .= '(' . join( ', ', @args ) . ')'; | ||||
133 | } | ||||
134 | $call_info{sub_name} = $sub_name; | ||||
135 | return wantarray() ? %call_info : \%call_info; | ||||
136 | } | ||||
137 | |||||
138 | # Transform an argument to a function into a string. | ||||
139 | # spent 71µs (42+28) within Carp::format_arg which was called:
# once (42µs+28µs) by Carp::caller_info at line 123 | ||||
140 | 8 | 57µs | my $arg = shift; | ||
141 | if ( ref($arg) ) { | ||||
142 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; | ||||
143 | } | ||||
144 | if ( defined($arg) ) { | ||||
145 | 1 | 2µs | $arg =~ s/'/\\'/g; # spent 2µs making 1 call to Carp::CORE:subst | ||
146 | 1 | 13µs | $arg = str_len_trim( $arg, $MaxArgLen ); # spent 13µs making 1 call to Carp::str_len_trim | ||
147 | |||||
148 | # Quote it? | ||||
149 | 1 | 5µs | $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/; # spent 5µs making 1 call to Carp::CORE:match | ||
150 | } # 0-9, not \d, as \d will try to | ||||
151 | else { # load Unicode tables | ||||
152 | $arg = 'undef'; | ||||
153 | } | ||||
154 | |||||
155 | # The following handling of "control chars" is direct from | ||||
156 | # the original code - it is broken on Unicode though. | ||||
157 | # Suggestions? | ||||
158 | utf8::is_utf8($arg) | ||||
159 | 2 | 8µs | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; # spent 6µs making 1 call to Carp::CORE:subst
# spent 3µs making 1 call to utf8::is_utf8 | ||
160 | return $arg; | ||||
161 | } | ||||
162 | |||||
163 | # Takes an inheritance cache and a package and returns | ||||
164 | # an anon hash of known inheritances and anon array of | ||||
165 | # inheritances which consequences have not been figured | ||||
166 | # for. | ||||
167 | sub get_status { | ||||
168 | 56 | 119µs | my $cache = shift; | ||
169 | my $pkg = shift; | ||||
170 | 7 | 64µs | $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ]; # spent 64µs making 7 calls to Carp::trusts_directly, avg 9µs/call | ||
171 | return @{ $cache->{$pkg} }; | ||||
172 | } | ||||
173 | |||||
174 | # Takes the info from caller() and figures out the name of | ||||
175 | # the sub/require/eval | ||||
176 | # spent 18µs within Carp::get_subname which was called 2 times, avg 9µs/call:
# 2 times (18µs+0s) by Carp::caller_info at line 100, avg 9µs/call | ||||
177 | 7 | 21µs | my $info = shift; | ||
178 | if ( defined( $info->{evaltext} ) ) { | ||||
179 | my $eval = $info->{evaltext}; | ||||
180 | if ( $info->{is_require} ) { | ||||
181 | return "require $eval"; | ||||
182 | } | ||||
183 | else { | ||||
184 | $eval =~ s/([\\\'])/\\$1/g; | ||||
185 | return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'"; | ||||
186 | } | ||||
187 | } | ||||
188 | |||||
189 | return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; | ||||
190 | } | ||||
191 | |||||
192 | # Figures out what call (from the point of view of the caller) | ||||
193 | # the long error backtrace should start at. | ||||
194 | sub long_error_loc { | ||||
195 | my $i; | ||||
196 | my $lvl = $CarpLevel; | ||||
197 | { | ||||
198 | ++$i; | ||||
199 | my $cgc = _cgc(); | ||||
200 | my $pkg = $cgc ? $cgc->($i) : caller($i); | ||||
201 | unless ( defined($pkg) ) { | ||||
202 | |||||
203 | # This *shouldn't* happen. | ||||
204 | if (%Internal) { | ||||
205 | local %Internal; | ||||
206 | $i = long_error_loc(); | ||||
207 | last; | ||||
208 | } | ||||
209 | else { | ||||
210 | |||||
211 | # OK, now I am irritated. | ||||
212 | return 2; | ||||
213 | } | ||||
214 | } | ||||
215 | redo if $CarpInternal{$pkg}; | ||||
216 | redo unless 0 > --$lvl; | ||||
217 | redo if $Internal{$pkg}; | ||||
218 | } | ||||
219 | return $i - 1; | ||||
220 | } | ||||
221 | |||||
222 | sub longmess_heavy { | ||||
223 | return @_ if ref( $_[0] ); # don't break references as exceptions | ||||
224 | my $i = long_error_loc(); | ||||
225 | return ret_backtrace( $i, @_ ); | ||||
226 | } | ||||
227 | |||||
228 | # Returns a full stack backtrace starting from where it is | ||||
229 | # told. | ||||
230 | sub ret_backtrace { | ||||
231 | my ( $i, @error ) = @_; | ||||
232 | my $mess; | ||||
233 | my $err = join '', @error; | ||||
234 | $i++; | ||||
235 | |||||
236 | my $tid_msg = ''; | ||||
237 | if ( defined &threads::tid ) { | ||||
238 | my $tid = threads->tid; | ||||
239 | $tid_msg = " thread $tid" if $tid; | ||||
240 | } | ||||
241 | |||||
242 | my %i = caller_info($i); | ||||
243 | $mess = "$err at $i{file} line $i{line}$tid_msg\n"; | ||||
244 | |||||
245 | while ( my %i = caller_info( ++$i ) ) { | ||||
246 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; | ||||
247 | } | ||||
248 | |||||
249 | return $mess; | ||||
250 | } | ||||
251 | |||||
252 | # spent 276µs (59+218) within Carp::ret_summary which was called 2 times, avg 138µs/call:
# 2 times (59µs+218µs) by Carp::shortmess_heavy at line 295, avg 138µs/call | ||||
253 | 14 | 58µs | my ( $i, @error ) = @_; | ||
254 | my $err = join '', @error; | ||||
255 | $i++; | ||||
256 | |||||
257 | my $tid_msg = ''; | ||||
258 | if ( defined &threads::tid ) { | ||||
259 | my $tid = threads->tid; | ||||
260 | $tid_msg = " thread $tid" if $tid; | ||||
261 | } | ||||
262 | |||||
263 | 2 | 218µs | my %i = caller_info($i); # spent 218µs making 2 calls to Carp::caller_info, avg 109µs/call | ||
264 | return "$err at $i{file} line $i{line}$tid_msg\n"; | ||||
265 | } | ||||
266 | |||||
267 | # spent 549µs (188+361) within Carp::short_error_loc which was called 2 times, avg 274µs/call:
# 2 times (188µs+361µs) by Carp::shortmess_heavy at line 294, avg 274µs/call | ||||
268 | # You have to create your (hash)ref out here, rather than defaulting it | ||||
269 | # inside trusts *on a lexical*, as you want it to persist across calls. | ||||
270 | # (You can default it on $_[2], but that gets messy) | ||||
271 | 120 | 156µs | my $cache = {}; | ||
272 | my $i = 1; | ||||
273 | my $lvl = $CarpLevel; | ||||
274 | { | ||||
275 | 13 | 36µs | my $cgc = _cgc(); # spent 36µs making 13 calls to Carp::_cgc, avg 3µs/call | ||
276 | my $called = $cgc ? $cgc->($i) : caller($i); | ||||
277 | $i++; | ||||
278 | my $caller = $cgc ? $cgc->($i) : caller($i); | ||||
279 | |||||
280 | return 0 unless defined($caller); # What happened? | ||||
281 | redo if $Internal{$caller}; | ||||
282 | redo if $CarpInternal{$caller}; | ||||
283 | redo if $CarpInternal{$called}; | ||||
284 | 7 | 147µs | redo if trusts( $called, $caller, $cache ); # spent 147µs making 7 calls to Carp::trusts, avg 21µs/call | ||
285 | 4 | 178µs | redo if trusts( $caller, $called, $cache ); # spent 178µs making 4 calls to Carp::trusts, avg 44µs/call | ||
286 | redo unless 0 > --$lvl; | ||||
287 | } | ||||
288 | return $i - 1; | ||||
289 | } | ||||
290 | |||||
291 | # spent 856µs (31+825) within Carp::shortmess_heavy which was called 2 times, avg 428µs/call:
# 2 times (31µs+825µs) by Carp::shortmess at line 76, avg 428µs/call | ||||
292 | 8 | 26µs | return longmess_heavy(@_) if $Verbose; | ||
293 | return @_ if ref( $_[0] ); # don't break references as exceptions | ||||
294 | 2 | 549µs | my $i = short_error_loc(); # spent 549µs making 2 calls to Carp::short_error_loc, avg 274µs/call | ||
295 | 2 | 276µs | if ($i) { # spent 276µs making 2 calls to Carp::ret_summary, avg 138µs/call | ||
296 | ret_summary( $i, @_ ); | ||||
297 | } | ||||
298 | else { | ||||
299 | longmess_heavy(@_); | ||||
300 | } | ||||
301 | } | ||||
302 | |||||
303 | # If a string is too long, trims it with ... | ||||
304 | # spent 13µs within Carp::str_len_trim which was called:
# once (13µs+0s) by Carp::format_arg at line 146 | ||||
305 | 4 | 16µs | my $str = shift; | ||
306 | my $max = shift || 0; | ||||
307 | if ( 2 < $max and $max < length($str) ) { | ||||
308 | substr( $str, $max - 3 ) = '...'; | ||||
309 | } | ||||
310 | return $str; | ||||
311 | } | ||||
312 | |||||
313 | # Takes two packages and an optional cache. Says whether the | ||||
314 | # first inherits from the second. | ||||
315 | # | ||||
316 | # Recursive versions of this have to work to avoid certain | ||||
317 | # possible endless loops, and when following long chains of | ||||
318 | # inheritance are less efficient. | ||||
319 | sub trusts { | ||||
320 | 87 | 143µs | my $child = shift; | ||
321 | my $parent = shift; | ||||
322 | my $cache = shift; | ||||
323 | 11 | 152µs | my ( $known, $partial ) = get_status( $cache, $child ); # spent 152µs making 11 calls to Carp::get_status, avg 14µs/call | ||
324 | |||||
325 | # Figure out consequences until we have an answer | ||||
326 | while ( @$partial and not exists $known->{$parent} ) { | ||||
327 | my $anc = shift @$partial; | ||||
328 | next if exists $known->{$anc}; | ||||
329 | $known->{$anc}++; | ||||
330 | 3 | 26µs | my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc ); # spent 26µs making 3 calls to Carp::get_status, avg 9µs/call | ||
331 | my @found = keys %$anc_knows; | ||||
332 | @$known{@found} = (); | ||||
333 | push @$partial, @$anc_partial; | ||||
334 | } | ||||
335 | return exists $known->{$parent}; | ||||
336 | } | ||||
337 | |||||
338 | # Takes a package and gives a list of those trusted directly | ||||
339 | # spent 64µs within Carp::trusts_directly which was called 7 times, avg 9µs/call:
# 7 times (64µs+0s) by Carp::get_status at line 170, avg 9µs/call | ||||
340 | 14 | 80µs | my $class = shift; | ||
341 | 2 | 67µs | 2 | 132µs | # spent 82µs (31+51) within Carp::BEGIN@341 which was called:
# once (31µs+51µs) by DynaLoader::croak at line 341 # spent 82µs making 1 call to Carp::BEGIN@341
# spent 51µs making 1 call to strict::unimport |
342 | 2 | 248µs | 2 | 88µs | # spent 52µs (16+36) within Carp::BEGIN@342 which was called:
# once (16µs+36µs) by DynaLoader::croak at line 342 # spent 52µs making 1 call to Carp::BEGIN@342
# spent 36µs making 1 call to warnings::unimport |
343 | return @{"$class\::CARP_NOT"} | ||||
344 | ? @{"$class\::CARP_NOT"} | ||||
345 | : @{"$class\::ISA"}; | ||||
346 | } | ||||
347 | |||||
348 | 1 | 54µs | 1; | ||
349 | |||||
350 | __END__ | ||||
# spent 5µs within Carp::CORE:match which was called:
# once (5µs+0s) by Carp::format_arg at line 149 | |||||
sub Carp::CORE:subst; # opcode |