← Index
NYTProf Performance Profile   « line view »
For /usr/local/bin/sa-learn
  Run on Sun Nov 5 02:36:06 2017
Reported on Sun Nov 5 02:56:17 2017

Filename/usr/local/lib/perl5/5.24/Carp.pm
StatementsExecuted 227 statements in 9.07ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
111180µs604µsCarp::::short_error_loc Carp::short_error_loc
311131µs131µsCarp::::trusts_directly Carp::trusts_directly
321118µs366µsCarp::::trusts Carp::trusts
421117µs248µsCarp::::get_status Carp::get_status
111107µs134µsCarp::::caller_info Carp::caller_info
111101µs169µsCarp::::BEGIN@6 Carp::BEGIN@6
63189µs89µsCarp::::_cgc Carp::_cgc
11154µs127µsCarp::::BEGIN@132 Carp::BEGIN@132
22147µs47µsCarp::::_fetch_sub Carp::_fetch_sub
11147µs884µsCarp::::shortmess Carp::shortmess
11146µs46µsCarp::::BEGIN@3 Carp::BEGIN@3
11145µs63µsCarp::::BEGIN@4 Carp::BEGIN@4
11144µs178µsCarp::::ret_summary Carp::ret_summary
11135µs817µsCarp::::shortmess_heavy Carp::shortmess_heavy
11134µs84µsCarp::::BEGIN@605 Carp::BEGIN@605
11130µs58µsCarp::::BEGIN@61 Carp::BEGIN@61
11128µs47µsCarp::::BEGIN@73 Carp::BEGIN@73
11126µs95µsCarp::::BEGIN@592 Carp::BEGIN@592
11122µs906µsCarp::::croak Carp::croak
11118µs46µsCarp::::BEGIN@5 Carp::BEGIN@5
11118µs80µsCarp::::BEGIN@612 Carp::BEGIN@612
11117µs17µsCarp::::BEGIN@49 Carp::BEGIN@49
11116µs16µsCarp::::BEGIN@172 Carp::BEGIN@172
11115µs15µsCarp::::get_subname Carp::get_subname
0000s0sCarp::::__ANON__[:262] Carp::__ANON__[:262]
0000s0sCarp::::__ANON__[:273] Carp::__ANON__[:273]
0000s0sCarp::::__ANON__[:66] Carp::__ANON__[:66]
0000s0sCarp::::__ANON__[:86] Carp::__ANON__[:86]
0000s0sCarp::::carp Carp::carp
0000s0sCarp::::cluck Carp::cluck
0000s0sCarp::::confess Carp::confess
0000s0sCarp::::export_fail Carp::export_fail
0000s0sCarp::::format_arg Carp::format_arg
0000s0sCarp::::long_error_loc Carp::long_error_loc
0000s0sCarp::::longmess Carp::longmess
0000s0sCarp::::longmess_heavy Carp::longmess_heavy
0000s0sCarp::::ret_backtrace Carp::ret_backtrace
0000s0sCarp::::str_len_trim Carp::str_len_trim
0000s0sRegexp::::CARP_TRACERegexp::CARP_TRACE
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Carp;
2
32142µs146µs
# spent 46µs within Carp::BEGIN@3 which was called: # once (46µs+0s) by Pod::Usage::BEGIN@19 at line 3
{ use 5.006; }
# spent 46µs making 1 call to Carp::BEGIN@3
4390µs280µs
# spent 63µs (45+18) within Carp::BEGIN@4 which was called: # once (45µs+18µs) by Pod::Usage::BEGIN@19 at line 4
use strict;
# spent 63µs making 1 call to Carp::BEGIN@4 # spent 18µs making 1 call to strict::import
52134µs274µs
# spent 46µs (18+28) within Carp::BEGIN@5 which was called: # once (18µs+28µs) by Pod::Usage::BEGIN@19 at line 5
use warnings;
# spent 46µs making 1 call to Carp::BEGIN@5 # spent 28µs making 1 call to warnings::import
6
# spent 169µs (101+68) within Carp::BEGIN@6 which was called: # once (101µs+68µs) by Pod::Usage::BEGIN@19 at line 26
BEGIN {
7 # Very old versions of warnings.pm load Carp. This can go wrong due
8 # to the circular dependency. If warnings is invoked before Carp,
9 # then warnings starts by loading Carp, then Carp (above) tries to
10 # invoke warnings, and gets nothing because warnings is in the process
11 # of loading and hasn't defined its import method yet. If we were
12 # only turning on warnings ("use warnings" above) this wouldn't be too
13 # bad, because Carp would just gets the state of the -w switch and so
14 # might not get some warnings that it wanted. The real problem is
15 # that we then want to turn off Unicode warnings, but "no warnings
16 # 'utf8'" won't be effective if we're in this circular-dependency
17 # situation. So, if warnings.pm is an affected version, we turn
18 # off all warnings ourselves by directly setting ${^WARNING_BITS}.
19 # On unaffected versions, we turn off just Unicode warnings, via
20 # the proper API.
21187µs if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
# spent 6µs executing statements in string eval
22 ${^WARNING_BITS} = "";
23 } else {
2417µs168µs "warnings"->unimport("utf8");
# spent 68µs making 1 call to warnings::unimport
25 }
261380µs1169µs}
# spent 169µs making 1 call to Carp::BEGIN@6
27
28
# spent 47µs within Carp::_fetch_sub which was called 2 times, avg 24µs/call: # once (28µs+0s) by Carp::BEGIN@61 at line 62 # once (19µs+0s) by Carp::BEGIN@73 at line 74
sub _fetch_sub { # fetch sub without autovivifying
2925µs my($pack, $sub) = @_;
3024µs $pack .= '::';
31 # only works with top-level packages
3224µs return unless exists($::{$pack});
3324µs for ($::{$pack}) {
3429µs return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
3524µs for ($$_{$sub}) {
36 return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
37225µs }
38 }
39}
40
41# UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
42# must avoid applying a regular expression to an upgraded (is_utf8)
43# string. There are multiple problems, on different Perl versions,
44# that require this to be avoided. All versions prior to 5.13.8 will
45# load utf8_heavy.pl for the swash system, even if the regexp doesn't
46# use character classes. Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
47# specific problems when Carp is being invoked in the aftermath of a
48# syntax error.
49
# spent 17µs within Carp::BEGIN@49 which was called: # once (17µs+0s) by Pod::Usage::BEGIN@19 at line 55
BEGIN {
50124µs if("$]" < 5.013011) {
51 *UTF8_REGEXP_PROBLEM = sub () { 1 };
52 } else {
5313µs *UTF8_REGEXP_PROBLEM = sub () { 0 };
54 }
551185µs117µs}
# spent 17µs making 1 call to Carp::BEGIN@49
56
57# is_utf8() is essentially the utf8::is_utf8() function, which indicates
58# whether a string is represented in the upgraded form (using UTF-8
59# internally). As utf8::is_utf8() is only available from Perl 5.8
60# onwards, extra effort is required here to make it work on Perl 5.6.
61
# spent 58µs (30+28) within Carp::BEGIN@61 which was called: # once (30µs+28µs) by Pod::Usage::BEGIN@19 at line 68
BEGIN {
62123µs128µs if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
# spent 28µs making 1 call to Carp::_fetch_sub
6312µs *is_utf8 = $sub;
64 } else {
65 # black magic for perl 5.6
66 *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
67 }
681260µs158µs}
# spent 58µs making 1 call to Carp::BEGIN@61
69
70# The downgrade() function defined here is to be used for attempts to
71# downgrade where it is acceptable to fail. It must be called with a
72# second argument that is a true value.
73
# spent 47µs (28+19) within Carp::BEGIN@73 which was called: # once (28µs+19µs) by Pod::Usage::BEGIN@19 at line 88
BEGIN {
74116µs119µs if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
# spent 19µs making 1 call to Carp::_fetch_sub
75210µs *downgrade = \&{"utf8::downgrade"};
76 } else {
77 *downgrade = sub {
78 my $r = "";
79 my $l = length($_[0]);
80 for(my $i = 0; $i != $l; $i++) {
81 my $o = ord(substr($_[0], $i, 1));
82 return if $o > 255;
83 $r .= chr($o);
84 }
85 $_[0] = $r;
86 };
87 }
881424µs147µs}
# spent 47µs making 1 call to Carp::BEGIN@73
89
9012µsour $VERSION = '1.40';
91117µs$VERSION =~ tr/_//d;
92
9312µsour $MaxEvalLen = 0;
9412µsour $Verbose = 0;
9512µsour $CarpLevel = 0;
9612µsour $MaxArgLen = 64; # How much of each argument to print. 0 = all.
9712µsour $MaxArgNums = 8; # How many arguments to print. 0 = all.
9812µsour $RefArgFormatter = undef; # allow caller to format reference arguments
99
10012µsrequire Exporter;
101114µsour @ISA = ('Exporter');
10213µsour @EXPORT = qw(confess croak carp);
10313µsour @EXPORT_OK = qw(cluck verbose longmess shortmess);
10412µsour @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
105
106# The members of %Internal are packages that are internal to perl.
107# Carp will not report errors from within these packages if it
108# can. The members of %CarpInternal are internal to Perl's warning
109# system. Carp will not report errors from within these packages
110# either, and will not report calls *to* these packages for carp and
111# croak. They replace $CarpLevel, which is deprecated. The
112# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
113# text and function arguments should be formatted when printed.
114
115our %CarpInternal;
116our %Internal;
117
118# disable these by default, so they can live w/o require Carp
119112µs$CarpInternal{Carp}++;
12012µs$CarpInternal{warnings}++;
12112µs$Internal{Exporter}++;
12212µs$Internal{'Exporter::Heavy'}++;
123
124# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
125# then the following method will be called by the Exporter which knows
126# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
127# 'verbose'.
128
129sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
130
131
# spent 89µs within Carp::_cgc which was called 6 times, avg 15µs/call: # 4 times (58µs+0s) by Carp::short_error_loc at line 513, avg 14µs/call # once (20µs+0s) by Carp::shortmess at line 160 # once (12µs+0s) by Carp::caller_info at line 184
sub _cgc {
1322776µs2200µs
# spent 127µs (54+73) within Carp::BEGIN@132 which was called: # once (54µs+73µs) by Pod::Usage::BEGIN@19 at line 132
no strict 'refs';
# spent 127µs making 1 call to Carp::BEGIN@132 # spent 73µs making 1 call to strict::unimport
1331263µs return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
134649µs return;
135}
136
137sub longmess {
138 local($!, $^E);
139 # Icky backwards compatibility wrapper. :-(
140 #
141 # The story is that the original implementation hard-coded the
142 # number of call levels to go back, so calls to longmess were off
143 # by one. Other code began calling longmess and expecting this
144 # behaviour, so the replacement has to emulate that behaviour.
145 my $cgc = _cgc();
146 my $call_pack = $cgc ? $cgc->() : caller();
147 if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
148 return longmess_heavy(@_);
149 }
150 else {
151 local $CarpLevel = $CarpLevel + 1;
152 return longmess_heavy(@_);
153 }
154}
155
156our @CARP_NOT;
157
158
# spent 884µs (47+837) within Carp::shortmess which was called: # once (47µs+837µs) by Carp::croak at line 167
sub shortmess {
15918µs local($!, $^E);
16018µs120µs my $cgc = _cgc();
# spent 20µs making 1 call to Carp::_cgc
161
162 # Icky backwards compatibility wrapper. :-(
16318µs local @CARP_NOT = $cgc ? $cgc->() : caller();
164119µs1817µs shortmess_heavy(@_);
# spent 817µs making 1 call to Carp::shortmess_heavy
165}
166
167138µs1884µs
# spent 906µs (22+884) within Carp::croak which was called: # once (22µs+884µs) by AutoLoader::autoload_sub at line 54 of AutoLoader.pm
sub croak { die shortmess @_ }
# spent 884µs making 1 call to Carp::shortmess
168sub confess { die longmess @_ }
169sub carp { warn shortmess @_ }
170sub cluck { warn longmess @_ }
171
172
# spent 16µs within Carp::BEGIN@172 which was called: # once (16µs+0s) by Pod::Usage::BEGIN@19 at line 179
BEGIN {
173120µs if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
174 ("$]" >= 5.012005 && "$]" < 5.013)) {
17513µs *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
176 } else {
177 *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
178 }
17914.88ms116µs}
# spent 16µs making 1 call to Carp::BEGIN@172
180
181
# spent 134µs (107+26) within Carp::caller_info which was called: # once (107µs+26µs) by Carp::ret_summary at line 501
sub caller_info {
18214µs my $i = shift(@_) + 1;
18312µs my %call_info;
18416µs112µs my $cgc = _cgc();
# spent 12µs making 1 call to Carp::_cgc
185 {
186 # Some things override caller() but forget to implement the
187 # @DB::args part of it, which we need. We check for this by
188 # pre-populating @DB::args with a sentinel which no-one else
189 # has the address of, so that we can detect whether @DB::args
190 # has been properly populated. However, on earlier versions
191 # of perl this check tickles a bug in CORE::caller() which
192 # leaks memory. So we only check on fixed perls.
19328µs @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
194 package DB;
195
196117µs
- -
20012µs unless ( defined $call_info{file} ) {
201 return ();
202 }
203
20419µs115µs my $sub_name = Carp::get_subname( \%call_info );
# spent 15µs making 1 call to Carp::get_subname
20514µs if ( $call_info{has_args} ) {
20612µs my @args;
20714µs if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
208 && ref $DB::args[0] eq ref \$i
209 && $DB::args[0] == \$i ) {
210 @DB::args = (); # Don't let anyone see the address of $i
211 local $@;
212 my $where = eval {
213 my $func = $cgc or return '';
214 my $gv =
215 (_fetch_sub B => 'svref_2object' or return '')
216 ->($func)->GV;
217 my $package = $gv->STASH->NAME;
218 my $subname = $gv->NAME;
219 return unless defined $package && defined $subname;
220
221 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
222 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
223 " in &${package}::$subname";
224 } || '';
225 @args
226 = "** Incomplete caller override detected$where; \@DB::args were not set **";
227 }
228 else {
22913µs @args = @DB::args;
23012µs my $overflow;
23113µs if ( $MaxArgNums and @args > $MaxArgNums )
232 { # More than we want to show?
233 $#args = $MaxArgNums - 1;
234 $overflow = 1;
235 }
236
23713µs @args = map { Carp::format_arg($_) } @args;
238
23912µs if ($overflow) {
240 push @args, '...';
241 }
242 }
243
244 # Push the args onto the subroutine
24515µs $sub_name .= '(' . join( ', ', @args ) . ')';
246 }
24713µs $call_info{sub_name} = $sub_name;
248120µs return wantarray() ? %call_info : \%call_info;
249}
250
251# Transform an argument to a function into a string.
252our $in_recurse;
253sub format_arg {
254 my $arg = shift;
255
256 if ( ref($arg) ) {
257 # legitimate, let's not leak it.
258 if (!$in_recurse &&
259 do {
260 local $@;
261 local $in_recurse = 1;
262 local $SIG{__DIE__} = sub{};
263 eval {$arg->can('CARP_TRACE') }
264 })
265 {
266 return $arg->CARP_TRACE();
267 }
268 elsif (!$in_recurse &&
269 defined($RefArgFormatter) &&
270 do {
271 local $@;
272 local $in_recurse = 1;
273 local $SIG{__DIE__} = sub{};
274 eval {$arg = $RefArgFormatter->($arg); 1}
275 })
276 {
277 return $arg;
278 }
279 else
280 {
281 my $sub = _fetch_sub(overload => 'StrVal');
282 return $sub ? &$sub($arg) : "$arg";
283 }
284 }
285 return "undef" if !defined($arg);
286 downgrade($arg, 1);
287 return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
288 $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
289 my $suffix = "";
290 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
291 substr ( $arg, $MaxArgLen - 3 ) = "";
292 $suffix = "...";
293 }
294 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
295 for(my $i = length($arg); $i--; ) {
296 my $c = substr($arg, $i, 1);
297 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
298 if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
299 substr $arg, $i, 0, "\\";
300 next;
301 }
302 my $o = ord($c);
303
304 # This code is repeated in Regexp::CARP_TRACE()
305 if ($] ge 5.007_003) {
306 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
307 if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
308 || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
309 } elsif (ord("A") == 65) {
310 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
311 if $o < 0x20 || $o > 0x7e;
312 } else { # Early EBCDIC
313
314 # 3 EBCDIC code pages supported then; all controls but one
315 # are the code points below SPACE. The other one is 0x5F on
316 # POSIX-BC; FF on the other two.
317 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
318 if $o < ord(" ") || ((ord ("^") == 106)
319 ? $o == 0x5f
320 : $o == 0xff);
321 }
322 }
323 } else {
324 $arg =~ s/([\"\\\$\@])/\\$1/g;
325 # This is all the ASCII printables spelled-out. It is portable to all
326 # Perl versions and platforms (such as EBCDIC). There are other more
327 # compact ways to do this, but may not work everywhere every version.
328 $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
329 }
330 downgrade($arg, 1);
331 return "\"".$arg."\"".$suffix;
332}
333
334sub Regexp::CARP_TRACE {
335 my $arg = "$_[0]";
336 downgrade($arg, 1);
337 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
338 for(my $i = length($arg); $i--; ) {
339 my $o = ord(substr($arg, $i, 1));
340 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
341
342 # This code is repeated in format_arg()
343 if ($] ge 5.007_003) {
344 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
345 if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
346 || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
347 } elsif (ord("A") == 65) {
348 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
349 if $o < 0x20 || $o > 0x7e;
350 } else { # Early EBCDIC
351 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
352 if $o < ord(" ") || ((ord ("^") == 106)
353 ? $o == 0x5f
354 : $o == 0xff);
355 }
356 }
357 } else {
358 # See comment in format_arg() about this same regex.
359 $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
360 }
361 downgrade($arg, 1);
362 my $suffix = "";
363 if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
364 ($suffix, $arg) = ($1, $2);
365 }
366 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
367 substr ( $arg, $MaxArgLen - 3 ) = "";
368 $suffix = "...".$suffix;
369 }
370 return "qr($arg)$suffix";
371}
372
373# Takes an inheritance cache and a package and returns
374# an anon hash of known inheritances and anon array of
375# inheritances which consequences have not been figured
376# for.
377
# spent 248µs (117+131) within Carp::get_status which was called 4 times, avg 62µs/call: # 3 times (85µs+93µs) by Carp::trusts at line 574, avg 59µs/call # once (33µs+37µs) by Carp::trusts at line 581
sub get_status {
37847µs my $cache = shift;
37947µs my $pkg = shift;
380463µs3131µs $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
# spent 131µs making 3 calls to Carp::trusts_directly, avg 44µs/call
381848µs return @{ $cache->{$pkg} };
382}
383
384# Takes the info from caller() and figures out the name of
385# the sub/require/eval
386
# spent 15µs within Carp::get_subname which was called: # once (15µs+0s) by Carp::caller_info at line 204
sub get_subname {
38712µs my $info = shift;
38812µs if ( defined( $info->{evaltext} ) ) {
389 my $eval = $info->{evaltext};
390 if ( $info->{is_require} ) {
391 return "require $eval";
392 }
393 else {
394 $eval =~ s/([\\\'])/\\$1/g;
395 return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
396 }
397 }
398
399 # this can happen on older perls when the sub (or the stash containing it)
400 # has been deleted
40112µs if ( !defined( $info->{sub} ) ) {
402 return '__ANON__::__ANON__';
403 }
404
405110µs return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
406}
407
408# Figures out what call (from the point of view of the caller)
409# the long error backtrace should start at.
410sub long_error_loc {
411 my $i;
412 my $lvl = $CarpLevel;
413 {
414 ++$i;
415 my $cgc = _cgc();
416 my @caller = $cgc ? $cgc->($i) : caller($i);
417 my $pkg = $caller[0];
418 unless ( defined($pkg) ) {
419
420 # This *shouldn't* happen.
421 if (%Internal) {
422 local %Internal;
423 $i = long_error_loc();
424 last;
425 }
426 elsif (defined $caller[2]) {
427 # this can happen when the stash has been deleted
428 # in that case, just assume that it's a reasonable place to
429 # stop (the file and line data will still be intact in any
430 # case) - the only issue is that we can't detect if the
431 # deleted package was internal (so don't do that then)
432 # -doy
433 redo unless 0 > --$lvl;
434 last;
435 }
436 else {
437 return 2;
438 }
439 }
440 redo if $CarpInternal{$pkg};
441 redo unless 0 > --$lvl;
442 redo if $Internal{$pkg};
443 }
444 return $i - 1;
445}
446
447sub longmess_heavy {
448 if ( ref( $_[0] ) ) { # don't break references as exceptions
449 return wantarray ? @_ : $_[0];
450 }
451 my $i = long_error_loc();
452 return ret_backtrace( $i, @_ );
453}
454
455# Returns a full stack backtrace starting from where it is
456# told.
457sub ret_backtrace {
458 my ( $i, @error ) = @_;
459 my $mess;
460 my $err = join '', @error;
461 $i++;
462
463 my $tid_msg = '';
464 if ( defined &threads::tid ) {
465 my $tid = threads->tid;
466 $tid_msg = " thread $tid" if $tid;
467 }
468
469 my %i = caller_info($i);
470 $mess = "$err at $i{file} line $i{line}$tid_msg";
471 if( defined $. ) {
472 local $@ = '';
473 local $SIG{__DIE__};
474 eval {
475 CORE::die;
476 };
477 if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
478 $mess .= $1;
479 }
480 }
481 $mess .= "\.\n";
482
483 while ( my %i = caller_info( ++$i ) ) {
484 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
485 }
486
487 return $mess;
488}
489
490
# spent 178µs (44+134) within Carp::ret_summary which was called: # once (44µs+134µs) by Carp::shortmess_heavy at line 547
sub ret_summary {
49113µs my ( $i, @error ) = @_;
49214µs my $err = join '', @error;
49312µs $i++;
494
49513µs my $tid_msg = '';
49612µs if ( defined &threads::tid ) {
497 my $tid = threads->tid;
498 $tid_msg = " thread $tid" if $tid;
499 }
500
501114µs1134µs my %i = caller_info($i);
# spent 134µs making 1 call to Carp::caller_info
502116µs return "$err at $i{file} line $i{line}$tid_msg\.\n";
503}
504
505
# spent 604µs (180+424) within Carp::short_error_loc which was called: # once (180µs+424µs) by Carp::shortmess_heavy at line 545
sub short_error_loc {
506 # You have to create your (hash)ref out here, rather than defaulting it
507 # inside trusts *on a lexical*, as you want it to persist across calls.
508 # (You can default it on $_[2], but that gets messy)
50913µs my $cache = {};
51012µs my $i = 1;
51113µs my $lvl = $CarpLevel;
512 {
513527µs458µs my $cgc = _cgc();
# spent 58µs making 4 calls to Carp::_cgc, avg 14µs/call
51449µs my $called = $cgc ? $cgc->($i) : caller($i);
51546µs $i++;
51649µs my $caller = $cgc ? $cgc->($i) : caller($i);
517
51846µs if (!defined($caller)) {
519 my @caller = $cgc ? $cgc->($i) : caller($i);
520 if (@caller) {
521 # if there's no package but there is other caller info, then
522 # the package has been deleted - treat this as a valid package
523 # in this case
524 redo if defined($called) && $CarpInternal{$called};
525 redo unless 0 > --$lvl;
526 last;
527 }
528 else {
529 return 0;
530 }
531 }
532421µs redo if $Internal{$caller};
53349µs redo if $CarpInternal{$caller};
534314µs redo if $CarpInternal{$called};
535221µs2135µs redo if trusts( $called, $caller, $cache );
# spent 135µs making 2 calls to Carp::trusts, avg 67µs/call
53617µs1232µs redo if trusts( $caller, $called, $cache );
# spent 232µs making 1 call to Carp::trusts
53713µs redo unless 0 > --$lvl;
538 }
539114µs return $i - 1;
540}
541
542
# spent 817µs (35+782) within Carp::shortmess_heavy which was called: # once (35µs+782µs) by Carp::shortmess at line 164
sub shortmess_heavy {
54312µs return longmess_heavy(@_) if $Verbose;
54412µs return @_ if ref( $_[0] ); # don't break references as exceptions
54518µs1604µs my $i = short_error_loc();
# spent 604µs making 1 call to Carp::short_error_loc
546111µs if ($i) {
54718µs1178µs ret_summary( $i, @_ );
# spent 178µs making 1 call to Carp::ret_summary
548 }
549 else {
550 longmess_heavy(@_);
551 }
552}
553
554# If a string is too long, trims it with ...
555sub str_len_trim {
556 my $str = shift;
557 my $max = shift || 0;
558 if ( 2 < $max and $max < length($str) ) {
559 substr( $str, $max - 3 ) = '...';
560 }
561 return $str;
562}
563
564# Takes two packages and an optional cache. Says whether the
565# first inherits from the second.
566#
567# Recursive versions of this have to work to avoid certain
568# possible endless loops, and when following long chains of
569# inheritance are less efficient.
570
# spent 366µs (118+248) within Carp::trusts which was called 3 times, avg 122µs/call: # 2 times (49µs+86µs) by Carp::short_error_loc at line 535, avg 67µs/call # once (69µs+162µs) by Carp::short_error_loc at line 536
sub trusts {
57136µs my $child = shift;
57235µs my $parent = shift;
57335µs my $cache = shift;
574320µs3178µs my ( $known, $partial ) = get_status( $cache, $child );
# spent 178µs making 3 calls to Carp::get_status, avg 59µs/call
575
576 # Figure out consequences until we have an answer
577318µs while ( @$partial and not exists $known->{$parent} ) {
57813µs my $anc = shift @$partial;
57912µs next if exists $known->{$anc};
58013µs $known->{$anc}++;
58117µs170µs my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
# spent 70µs making 1 call to Carp::get_status
58216µs my @found = keys %$anc_knows;
58314µs @$known{@found} = ();
58415µs push @$partial, @$anc_partial;
585 }
586336µs return exists $known->{$parent};
587}
588
589# Takes a package and gives a list of those trusted directly
590
# spent 131µs within Carp::trusts_directly which was called 3 times, avg 44µs/call: # 3 times (131µs+0s) by Carp::get_status at line 380, avg 44µs/call
sub trusts_directly {
59138µs my $class = shift;
5922230µs2165µs
# spent 95µs (26+70) within Carp::BEGIN@592 which was called: # once (26µs+70µs) by Pod::Usage::BEGIN@19 at line 592
no strict 'refs';
# spent 95µs making 1 call to Carp::BEGIN@592 # spent 70µs making 1 call to strict::unimport
593632µs my $stash = \%{"$class\::"};
594310µs for my $var (qw/ CARP_NOT ISA /) {
595 # Don't try using the variable until we know it exists,
596 # to avoid polluting the caller's namespace.
597855µs if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
598213µs return @{$stash->{$var}}
599 }
600 }
601218µs return;
602}
603
60417µsif(!defined($warnings::VERSION) ||
6053102µs2134µs
# spent 84µs (34+50) within Carp::BEGIN@605 which was called: # once (34µs+50µs) by Pod::Usage::BEGIN@19 at line 605
do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
# spent 84µs making 1 call to Carp::BEGIN@605 # spent 50µs making 1 call to warnings::unimport
606 # Very old versions of warnings.pm import from Carp. This can go
607 # wrong due to the circular dependency. If Carp is invoked before
608 # warnings, then Carp starts by loading warnings, then warnings
609 # tries to import from Carp, and gets nothing because Carp is in
610 # the process of loading and hasn't defined its import method yet.
611 # So we work around that by manually exporting to warnings here.
6122168µs2142µs
# spent 80µs (18+62) within Carp::BEGIN@612 which was called: # once (18µs+62µs) by Pod::Usage::BEGIN@19 at line 612
no strict "refs";
# spent 80µs making 1 call to Carp::BEGIN@612 # spent 62µs making 1 call to strict::unimport
613 *{"warnings::$_"} = \&$_ foreach @EXPORT;
614}
615
616149µs1;
617
618__END__
Report produced by the NYTProf 6.04 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.