← Index
NYTProf Performance Profile   « line view »
For /home/ss5/perl5/perlbrew/perls/perl-5.22.0/bin/benchmarkanything-storage
  Run on Mon Jan 29 16:55:34 2018
Reported on Mon Jan 29 16:57:06 2018

Filename/home/ss5/perl5/perlbrew/perls/perl-5.22.0/lib/5.22.0/Carp.pm
StatementsExecuted 1267 statements in 3.27ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
1622162µs465µsCarp::::short_error_loc Carp::short_error_loc
3211106µs174µsCarp::::get_status Carp::get_status
322177µs252µsCarp::::trusts Carp::trusts
321169µs69µsCarp::::trusts_directly Carp::trusts_directly
443163µs63µsCarp::::_cgc Carp::_cgc
31160µs123µsCarp::::caller_info Carp::caller_info
61143µs54µsCarp::::format_arg Carp::format_arg
31124µs289µsCarp::::shortmess Carp::shortmess
31123µs146µsCarp::::ret_summary Carp::ret_summary
11118µs28µsCarp::::BEGIN@6 Carp::BEGIN@6
31117µs314µsCarp::::croak Carp::croak
31113µs256µsCarp::::shortmess_heavy Carp::shortmess_heavy
22111µs11µsCarp::::_fetch_sub Carp::_fetch_sub
1117µs7µsCarp::::BEGIN@3 Carp::BEGIN@3
1116µs10µsCarp::::BEGIN@73 Carp::BEGIN@73
1116µs16µsCarp::::BEGIN@589 Carp::BEGIN@589
1116µs12µsCarp::::BEGIN@602 Carp::BEGIN@602
3116µs6µsCarp::::get_subname Carp::get_subname
1115µs12µsCarp::::BEGIN@61 Carp::BEGIN@61
1115µs13µsCarp::::BEGIN@609 Carp::BEGIN@609
1115µs7µsCarp::::BEGIN@4 Carp::BEGIN@4
6115µs5µsCarp::::CORE:match Carp::CORE:match (opcode)
1115µs15µsCarp::::BEGIN@131 Carp::BEGIN@131
1114µs4µsCarp::::BEGIN@49 Carp::BEGIN@49
1114µs4µsCarp::::BEGIN@171 Carp::BEGIN@171
1113µs6µsCarp::::BEGIN@5 Carp::BEGIN@5
12213µs3µsCarp::::CORE:subst Carp::CORE:subst (opcode)
0000s0sCarp::::__ANON__[:261] Carp::__ANON__[:261]
0000s0sCarp::::__ANON__[:272] Carp::__ANON__[:272]
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::::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
3223µs17µs
# spent 7µs within Carp::BEGIN@3 which was called: # once (7µs+0s) by Attribute::Handlers::BEGIN@3 at line 3
{ use 5.006; }
# spent 7µs making 1 call to Carp::BEGIN@3
4315µs28µs
# spent 7µs (5+2) within Carp::BEGIN@4 which was called: # once (5µs+2µs) by Attribute::Handlers::BEGIN@3 at line 4
use strict;
# spent 7µs making 1 call to Carp::BEGIN@4 # spent 2µs making 1 call to strict::import
5242µs29µs
# spent 6µs (3+3) within Carp::BEGIN@5 which was called: # once (3µs+3µs) by Attribute::Handlers::BEGIN@3 at line 5
use warnings;
# spent 6µs making 1 call to Carp::BEGIN@5 # spent 3µs making 1 call to warnings::import
6
# spent 28µs (18+9) within Carp::BEGIN@6 which was called: # once (18µs+9µs) by Attribute::Handlers::BEGIN@3 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.
21112µs if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
# spent 2µs executing statements in string eval
22 ${^WARNING_BITS} = "";
23 } else {
2411µs19µs "warnings"->unimport("utf8");
# spent 9µs making 1 call to warnings::unimport
25 }
261114µs128µs}
# spent 28µs making 1 call to Carp::BEGIN@6
27
28
# spent 11µs within Carp::_fetch_sub which was called 2 times, avg 5µs/call: # once (6µs+0s) by Carp::BEGIN@61 at line 62 # once (4µs+0s) by Carp::BEGIN@73 at line 74
sub _fetch_sub { # fetch sub without autovivifying
2921µs my($pack, $sub) = @_;
302600ns $pack .= '::';
31 # only works with top-level packages
322600ns return unless exists($::{$pack});
3321µs for ($::{$pack}) {
3423µs return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
352900ns for ($$_{$sub}) {
36 return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
3727µ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 4µs within Carp::BEGIN@49 which was called: # once (4µs+0s) by Attribute::Handlers::BEGIN@3 at line 55
BEGIN {
5016µs if("$]" < 5.013011) {
51 *UTF8_REGEXP_PROBLEM = sub () { 1 };
52 } else {
531800ns *UTF8_REGEXP_PROBLEM = sub () { 0 };
54 }
55151µs14µs}
# spent 4µ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 12µs (5+6) within Carp::BEGIN@61 which was called: # once (5µs+6µs) by Attribute::Handlers::BEGIN@3 at line 68
BEGIN {
6213µs16µs if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
# spent 6µs making 1 call to Carp::_fetch_sub
63 *is_utf8 = $sub;
64 } else {
65 # black magic for perl 5.6
66 *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
67 }
68177µs112µs}
# spent 12µ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 10µs (6+4) within Carp::BEGIN@73 which was called: # once (6µs+4µs) by Attribute::Handlers::BEGIN@3 at line 88
BEGIN {
7413µs14µs if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
# spent 4µs making 1 call to Carp::_fetch_sub
75 *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 }
881120µs110µs}
# spent 10µs making 1 call to Carp::BEGIN@73
89
901300nsour $VERSION = '1.36';
91
921100nsour $MaxEvalLen = 0;
931100nsour $Verbose = 0;
941100nsour $CarpLevel = 0;
9510sour $MaxArgLen = 64; # How much of each argument to print. 0 = all.
961100nsour $MaxArgNums = 8; # How many arguments to print. 0 = all.
971200nsour $RefArgFormatter = undef; # allow caller to format reference arguments
98
991386µsrequire Exporter;
10014µsour @ISA = ('Exporter');
1011600nsour @EXPORT = qw(confess croak carp);
1021500nsour @EXPORT_OK = qw(cluck verbose longmess shortmess);
1031300nsour @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
104
105# The members of %Internal are packages that are internal to perl.
106# Carp will not report errors from within these packages if it
107# can. The members of %CarpInternal are internal to Perl's warning
108# system. Carp will not report errors from within these packages
109# either, and will not report calls *to* these packages for carp and
110# croak. They replace $CarpLevel, which is deprecated. The
111# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
112# text and function arguments should be formatted when printed.
113
114our %CarpInternal;
115our %Internal;
116
117# disable these by default, so they can live w/o require Carp
1181700ns$CarpInternal{Carp}++;
1191200ns$CarpInternal{warnings}++;
1201200ns$Internal{Exporter}++;
1211100ns$Internal{'Exporter::Heavy'}++;
122
123# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
124# then the following method will be called by the Exporter which knows
125# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
126# 'verbose'.
127
128sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
129
130
# spent 63µs within Carp::_cgc which was called 44 times, avg 1µs/call: # 38 times (51µs+0s) by Carp::short_error_loc at line 510, avg 1µs/call # 3 times (9µs+0s) by Carp::shortmess at line 159, avg 3µs/call # 3 times (3µs+0s) by Carp::caller_info at line 183, avg 1µs/call
sub _cgc {
1312205µs225µs
# spent 15µs (5+10) within Carp::BEGIN@131 which was called: # once (5µs+10µs) by Attribute::Handlers::BEGIN@3 at line 131
no strict 'refs';
# spent 15µs making 1 call to Carp::BEGIN@131 # spent 10µs making 1 call to strict::unimport
1324446µs return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
1334439µs return;
134}
135
136sub longmess {
137 local($!, $^E);
138 # Icky backwards compatibility wrapper. :-(
139 #
140 # The story is that the original implementation hard-coded the
141 # number of call levels to go back, so calls to longmess were off
142 # by one. Other code began calling longmess and expecting this
143 # behaviour, so the replacement has to emulate that behaviour.
144 my $cgc = _cgc();
145 my $call_pack = $cgc ? $cgc->() : caller();
146 if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
147 return longmess_heavy(@_);
148 }
149 else {
150 local $CarpLevel = $CarpLevel + 1;
151 return longmess_heavy(@_);
152 }
153}
154
155our @CARP_NOT;
156
157
# spent 289µs (24+265) within Carp::shortmess which was called 3 times, avg 96µs/call: # 3 times (24µs+265µs) by Carp::croak at line 166, avg 96µs/call
sub shortmess {
15835µs local($!, $^E);
15933µs39µs my $cgc = _cgc();
# spent 9µs making 3 calls to Carp::_cgc, avg 3µs/call
160
161 # Icky backwards compatibility wrapper. :-(
16235µs local @CARP_NOT = $cgc ? $cgc->() : caller();
16339µs3256µs shortmess_heavy(@_);
# spent 256µs making 3 calls to Carp::shortmess_heavy, avg 85µs/call
164}
165
166335µs6298µs
# spent 314µs (17+298) within Carp::croak which was called 3 times, avg 105µs/call: # 3 times (17µs+298µs) by Exporter::Heavy::heavy_export at line 159 of Exporter/Heavy.pm, avg 105µs/call
sub croak { die shortmess @_ }
# spent 289µs making 3 calls to Carp::shortmess, avg 96µs/call # spent 9µs making 3 calls to Exporter::Heavy::__ANON__[Exporter/Heavy.pm:63], avg 3µs/call
167sub confess { die longmess @_ }
168sub carp { warn shortmess @_ }
169sub cluck { warn longmess @_ }
170
171
# spent 4µs within Carp::BEGIN@171 which was called: # once (4µs+0s) by Attribute::Handlers::BEGIN@3 at line 178
BEGIN {
17214µs if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
173 ("$]" >= 5.012005 && "$]" < 5.013)) {
174 *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
175 } else {
176 *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
177 }
17811.33ms14µs}
# spent 4µs making 1 call to Carp::BEGIN@171
179
180
# spent 123µs (60+63) within Carp::caller_info which was called 3 times, avg 41µs/call: # 3 times (60µs+63µs) by Carp::ret_summary at line 498, avg 41µs/call
sub caller_info {
18132µs my $i = shift(@_) + 1;
1823500ns my %call_info;
18331µs33µs my $cgc = _cgc();
# spent 3µs making 3 calls to Carp::_cgc, avg 1µs/call
184 {
185 # Some things override caller() but forget to implement the
186 # @DB::args part of it, which we need. We check for this by
187 # pre-populating @DB::args with a sentinel which no-one else
188 # has the address of, so that we can detect whether @DB::args
189 # has been properly populated. However, on earlier versions
190 # of perl this check tickles a bug in CORE::caller() which
191 # leaks memory. So we only check on fixed perls.
19264µs @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
193 package DB;
194
195313µs
- -
19931µs unless ( defined $call_info{file} ) {
200 return ();
201 }
202
20333µs36µs my $sub_name = Carp::get_subname( \%call_info );
# spent 6µs making 3 calls to Carp::get_subname, avg 2µs/call
20431µs if ( $call_info{has_args} ) {
2053300ns my @args;
20631µs if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
207 && ref $DB::args[0] eq ref \$i
208 && $DB::args[0] == \$i ) {
209 @DB::args = (); # Don't let anyone see the address of $i
210 local $@;
211 my $where = eval {
212 my $func = $cgc or return '';
213 my $gv =
214 (_fetch_sub B => 'svref_2object' or return '')
215 ->($func)->GV;
216 my $package = $gv->STASH->NAME;
217 my $subname = $gv->NAME;
218 return unless defined $package && defined $subname;
219
220 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
221 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
222 " in &${package}::$subname";
223 } || '';
224 @args
225 = "** Incomplete caller override detected$where; \@DB::args were not set **";
226 }
227 else {
22832µs @args = @DB::args;
2293600ns my $overflow;
23031µs if ( $MaxArgNums and @args > $MaxArgNums )
231 { # More than we want to show?
232 $#args = $MaxArgNums;
233 $overflow = 1;
234 }
235
23699µs654µs @args = map { Carp::format_arg($_) } @args;
# spent 54µs making 6 calls to Carp::format_arg, avg 9µs/call
237
2383500ns if ($overflow) {
239 push @args, '...';
240 }
241 }
242
243 # Push the args onto the subroutine
24434µs $sub_name .= '(' . join( ', ', @args ) . ')';
245 }
2463800ns $call_info{sub_name} = $sub_name;
247311µs return wantarray() ? %call_info : \%call_info;
248}
249
250# Transform an argument to a function into a string.
251our $in_recurse;
252
# spent 54µs (43+11) within Carp::format_arg which was called 6 times, avg 9µs/call: # 6 times (43µs+11µs) by Carp::caller_info at line 236, avg 9µs/call
sub format_arg {
25362µs my $arg = shift;
254
2556800ns if ( ref($arg) ) {
256 # legitimate, let's not leak it.
257 if (!$in_recurse &&
258 do {
259 local $@;
260 local $in_recurse = 1;
261 local $SIG{__DIE__} = sub{};
262 eval {$arg->can('CARP_TRACE') }
263 })
264 {
265 return $arg->CARP_TRACE();
266 }
267 elsif (!$in_recurse &&
268 defined($RefArgFormatter) &&
269 do {
270 local $@;
271 local $in_recurse = 1;
272 local $SIG{__DIE__} = sub{};
273 eval {$arg = $RefArgFormatter->($arg); 1}
274 })
275 {
276 return $arg;
277 }
278 else
279 {
280 my $sub = _fetch_sub(overload => 'StrVal');
281 return $sub ? &$sub($arg) : "$arg";
282 }
283 }
2846500ns return "undef" if !defined($arg);
28569µs62µs downgrade($arg, 1);
# spent 2µs making 6 calls to utf8::downgrade, avg 333ns/call
286611µs65µs return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
# spent 5µs making 6 calls to Carp::CORE:match, avg 800ns/call
287 $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
28861µs my $suffix = "";
28962µs if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
290 substr ( $arg, $MaxArgLen - 3 ) = "";
291 $suffix = "...";
292 }
2936800ns if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
294 for(my $i = length($arg); $i--; ) {
295 my $c = substr($arg, $i, 1);
296 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
297 if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
298 substr $arg, $i, 0, "\\";
299 next;
300 }
301 my $o = ord($c);
302
303 # This code is repeated in Regexp::CARP_TRACE()
304 if ($] ge 5.007_003) {
305 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
306 if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
307 || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
308 } elsif (ord("A") == 65) {
309 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
310 if $o < 0x20 || $o > 0x7e;
311 } else { # Early EBCDIC
312
313 # 3 EBCDIC code pages supported then; all controls but one
314 # are the code points below SPACE. The other one is 0x5F on
315 # POSIX-BC; FF on the other two.
316 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
317 if $o < ord(" ") || ((ord ("^") == 106)
318 ? $o == 0x5f
319 : $o == 0xff);
320 }
321 }
322 } else {
32368µs62µs $arg =~ s/([\"\\\$\@])/\\$1/g;
# spent 2µs making 6 calls to Carp::CORE:subst, avg 333ns/call
324 # This is all the ASCII printables spelled-out. It is portable to all
325 # Perl versions and platforms (such as EBCDIC). There are other more
326 # compact ways to do this, but may not work everywhere every version.
32766µs61µs $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
# spent 1µs making 6 calls to Carp::CORE:subst, avg 200ns/call
328 }
32966µs61µs downgrade($arg, 1);
# spent 1µs making 6 calls to utf8::downgrade, avg 183ns/call
33069µs return "\"".$arg."\"".$suffix;
331}
332
333sub Regexp::CARP_TRACE {
334 my $arg = "$_[0]";
335 downgrade($arg, 1);
336 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
337 for(my $i = length($arg); $i--; ) {
338 my $o = ord(substr($arg, $i, 1));
339 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
340
341 # This code is repeated in format_arg()
342 if ($] ge 5.007_003) {
343 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
344 if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
345 || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
346 } elsif (ord("A") == 65) {
347 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
348 if $o < 0x20 || $o > 0x7e;
349 } else { # Early EBCDIC
350 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
351 if $o < ord(" ") || ((ord ("^") == 106)
352 ? $o == 0x5f
353 : $o == 0xff);
354 }
355 }
356 } else {
357 # See comment in format_arg() about this same regex.
358 $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
359 }
360 downgrade($arg, 1);
361 my $suffix = "";
362 if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
363 ($suffix, $arg) = ($1, $2);
364 }
365 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
366 substr ( $arg, $MaxArgLen - 3 ) = "";
367 $suffix = "...".$suffix;
368 }
369 return "qr($arg)$suffix";
370}
371
372# Takes an inheritance cache and a package and returns
373# an anon hash of known inheritances and anon array of
374# inheritances which consequences have not been figured
375# for.
376
# spent 174µs (106+69) within Carp::get_status which was called 32 times, avg 5µs/call: # 32 times (106µs+69µs) by Carp::trusts at line 571, avg 5µs/call
sub get_status {
377323µs my $cache = shift;
378323µs my $pkg = shift;
3793265µs3269µs $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
# spent 69µs making 32 calls to Carp::trusts_directly, avg 2µs/call
3803235µs return @{ $cache->{$pkg} };
381}
382
383# Takes the info from caller() and figures out the name of
384# the sub/require/eval
385
# spent 6µs within Carp::get_subname which was called 3 times, avg 2µs/call: # 3 times (6µs+0s) by Carp::caller_info at line 203, avg 2µs/call
sub get_subname {
3863600ns my $info = shift;
38731µs if ( defined( $info->{evaltext} ) ) {
388 my $eval = $info->{evaltext};
389 if ( $info->{is_require} ) {
390 return "require $eval";
391 }
392 else {
393 $eval =~ s/([\\\'])/\\$1/g;
394 return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
395 }
396 }
397
398 # this can happen on older perls when the sub (or the stash containing it)
399 # has been deleted
4003700ns if ( !defined( $info->{sub} ) ) {
401 return '__ANON__::__ANON__';
402 }
403
40435µs return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
405}
406
407# Figures out what call (from the point of view of the caller)
408# the long error backtrace should start at.
409sub long_error_loc {
410 my $i;
411 my $lvl = $CarpLevel;
412 {
413 ++$i;
414 my $cgc = _cgc();
415 my @caller = $cgc ? $cgc->($i) : caller($i);
416 my $pkg = $caller[0];
417 unless ( defined($pkg) ) {
418
419 # This *shouldn't* happen.
420 if (%Internal) {
421 local %Internal;
422 $i = long_error_loc();
423 last;
424 }
425 elsif (defined $caller[2]) {
426 # this can happen when the stash has been deleted
427 # in that case, just assume that it's a reasonable place to
428 # stop (the file and line data will still be intact in any
429 # case) - the only issue is that we can't detect if the
430 # deleted package was internal (so don't do that then)
431 # -doy
432 redo unless 0 > --$lvl;
433 last;
434 }
435 else {
436 return 2;
437 }
438 }
439 redo if $CarpInternal{$pkg};
440 redo unless 0 > --$lvl;
441 redo if $Internal{$pkg};
442 }
443 return $i - 1;
444}
445
446sub longmess_heavy {
447 return @_ if ref( $_[0] ); # don't break references as exceptions
448 my $i = long_error_loc();
449 return ret_backtrace( $i, @_ );
450}
451
452# Returns a full stack backtrace starting from where it is
453# told.
454sub ret_backtrace {
455 my ( $i, @error ) = @_;
456 my $mess;
457 my $err = join '', @error;
458 $i++;
459
460 my $tid_msg = '';
461 if ( defined &threads::tid ) {
462 my $tid = threads->tid;
463 $tid_msg = " thread $tid" if $tid;
464 }
465
466 my %i = caller_info($i);
467 $mess = "$err at $i{file} line $i{line}$tid_msg";
468 if( defined $. ) {
469 local $@ = '';
470 local $SIG{__DIE__};
471 eval {
472 CORE::die;
473 };
474 if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
475 $mess .= $1;
476 }
477 }
478 $mess .= "\.\n";
479
480 while ( my %i = caller_info( ++$i ) ) {
481 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
482 }
483
484 return $mess;
485}
486
487
# spent 146µs (23+123) within Carp::ret_summary which was called 3 times, avg 49µs/call: # 3 times (23µs+123µs) by Carp::shortmess_heavy at line 543, avg 49µs/call
sub ret_summary {
48832µs my ( $i, @error ) = @_;
48932µs my $err = join '', @error;
4903300ns $i++;
491
4923700ns my $tid_msg = '';
4933900ns if ( defined &threads::tid ) {
494 my $tid = threads->tid;
495 $tid_msg = " thread $tid" if $tid;
496 }
497
49838µs3123µs my %i = caller_info($i);
# spent 123µs making 3 calls to Carp::caller_info, avg 41µs/call
49939µs return "$err at $i{file} line $i{line}$tid_msg\.\n";
500}
501
502
# spent 465µs (162+303) within Carp::short_error_loc which was called 16 times, avg 29µs/call: # 13 times (121µs+247µs) by warnings::__chk at line 451 of warnings.pm, avg 28µs/call # 3 times (41µs+56µs) by Carp::shortmess_heavy at line 542, avg 32µs/call
sub short_error_loc {
503 # You have to create your (hash)ref out here, rather than defaulting it
504 # inside trusts *on a lexical*, as you want it to persist across calls.
505 # (You can default it on $_[2], but that gets messy)
506165µs my $cache = {};
507162µs my $i = 1;
508162µs my $lvl = $CarpLevel;
509 {
5105423µs3851µs my $cgc = _cgc();
# spent 51µs making 38 calls to Carp::_cgc, avg 1µs/call
5113810µs my $called = $cgc ? $cgc->($i) : caller($i);
512383µs $i++;
513389µs my $caller = $cgc ? $cgc->($i) : caller($i);
514
515384µs if (!defined($caller)) {
516 my @caller = $cgc ? $cgc->($i) : caller($i);
517 if (@caller) {
518 # if there's no package but there is other caller info, then
519 # the package has been deleted - treat this as a valid package
520 # in this case
521 redo if defined($called) && $CarpInternal{$called};
522 redo unless 0 > --$lvl;
523 last;
524 }
525 else {
526 return 0;
527 }
528 }
529387µs redo if $Internal{$caller};
530325µs redo if $CarpInternal{$caller};
531298µs redo if $CarpInternal{$called};
5321612µs16151µs redo if trusts( $called, $caller, $cache );
# spent 151µs making 16 calls to Carp::trusts, avg 9µs/call
533169µs16100µs redo if trusts( $caller, $called, $cache );
# spent 100µs making 16 calls to Carp::trusts, avg 6µs/call
534167µs redo unless 0 > --$lvl;
535 }
5361632µs return $i - 1;
537}
538
539
# spent 256µs (13+243) within Carp::shortmess_heavy which was called 3 times, avg 85µs/call: # 3 times (13µs+243µs) by Carp::shortmess at line 163, avg 85µs/call
sub shortmess_heavy {
5403900ns return longmess_heavy(@_) if $Verbose;
5413700ns return @_ if ref( $_[0] ); # don't break references as exceptions
54233µs397µs my $i = short_error_loc();
# spent 97µs making 3 calls to Carp::short_error_loc, avg 32µs/call
54337µs3146µs if ($i) {
# spent 146µs making 3 calls to Carp::ret_summary, avg 49µs/call
544 ret_summary( $i, @_ );
545 }
546 else {
547 longmess_heavy(@_);
548 }
549}
550
551# If a string is too long, trims it with ...
552sub str_len_trim {
553 my $str = shift;
554 my $max = shift || 0;
555 if ( 2 < $max and $max < length($str) ) {
556 substr( $str, $max - 3 ) = '...';
557 }
558 return $str;
559}
560
561# Takes two packages and an optional cache. Says whether the
562# first inherits from the second.
563#
564# Recursive versions of this have to work to avoid certain
565# possible endless loops, and when following long chains of
566# inheritance are less efficient.
567
# spent 252µs (77+174) within Carp::trusts which was called 32 times, avg 8µs/call: # 16 times (47µs+104µs) by Carp::short_error_loc at line 532, avg 9µs/call # 16 times (30µs+70µs) by Carp::short_error_loc at line 533, avg 6µs/call
sub trusts {
568325µs my $child = shift;
569323µs my $parent = shift;
570323µs my $cache = shift;
5713221µs32174µs my ( $known, $partial ) = get_status( $cache, $child );
# spent 174µs making 32 calls to Carp::get_status, avg 5µs/call
572
573 # Figure out consequences until we have an answer
574329µs while ( @$partial and not exists $known->{$parent} ) {
575 my $anc = shift @$partial;
576 next if exists $known->{$anc};
577 $known->{$anc}++;
578 my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
579 my @found = keys %$anc_knows;
580 @$known{@found} = ();
581 push @$partial, @$anc_partial;
582 }
5833235µs return exists $known->{$parent};
584}
585
586# Takes a package and gives a list of those trusted directly
587
# spent 69µs within Carp::trusts_directly which was called 32 times, avg 2µs/call: # 32 times (69µs+0s) by Carp::get_status at line 379, avg 2µs/call
sub trusts_directly {
588324µs my $class = shift;
589264µs225µs
# spent 16µs (6+10) within Carp::BEGIN@589 which was called: # once (6µs+10µs) by Attribute::Handlers::BEGIN@3 at line 589
no strict 'refs';
# spent 16µs making 1 call to Carp::BEGIN@589 # spent 10µs making 1 call to strict::unimport
5903217µs my $stash = \%{"$class\::"};
5913210µs for my $var (qw/ CARP_NOT ISA /) {
592 # Don't try using the variable until we know it exists,
593 # to avoid polluting the caller's namespace.
5946418µs if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
595 return @{$stash->{$var}}
596 }
597 }
5983233µs return;
599}
600
6011600nsif(!defined($warnings::VERSION) ||
602328µs218µs
# spent 12µs (6+6) within Carp::BEGIN@602 which was called: # once (6µs+6µs) by Attribute::Handlers::BEGIN@3 at line 602
do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
# spent 12µs making 1 call to Carp::BEGIN@602 # spent 6µs making 1 call to warnings::unimport
603 # Very old versions of warnings.pm import from Carp. This can go
604 # wrong due to the circular dependency. If Carp is invoked before
605 # warnings, then Carp starts by loading warnings, then warnings
606 # tries to import from Carp, and gets nothing because Carp is in
607 # the process of loading and hasn't defined its import method yet.
608 # So we work around that by manually exporting to warnings here.
609256µs221µs
# spent 13µs (5+8) within Carp::BEGIN@609 which was called: # once (5µs+8µs) by Attribute::Handlers::BEGIN@3 at line 609
no strict "refs";
# spent 13µs making 1 call to Carp::BEGIN@609 # spent 8µs making 1 call to strict::unimport
610 *{"warnings::$_"} = \&$_ foreach @EXPORT;
611}
612
61318µs1;
614
615__END__
 
# spent 5µs within Carp::CORE:match which was called 6 times, avg 800ns/call: # 6 times (5µs+0s) by Carp::format_arg at line 286, avg 800ns/call
sub Carp::CORE:match; # opcode
# spent 3µs within Carp::CORE:subst which was called 12 times, avg 267ns/call: # 6 times (2µs+0s) by Carp::format_arg at line 323, avg 333ns/call # 6 times (1µs+0s) by Carp::format_arg at line 327, avg 200ns/call
sub Carp::CORE:subst; # opcode