← Index
NYTProf Performance Profile   « line view »
For ../prof.pl
  Run on Thu Dec 15 15:23:56 2022
Reported on Thu Dec 15 15:27:01 2022

Filename/Users/ether/perl5/perlbrew/perls/36.0/lib/5.36.0/Carp.pm
StatementsExecuted 2355 statements in 5.38ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
1111.04ms1.09msCarp::::BEGIN@169 Carp::BEGIN@169
2721400µs1.08msCarp::::trusts Carp::trusts
12321343µs678µsCarp::::get_status Carp::get_status
11511335µs335µsCarp::::trusts_directly Carp::trusts_directly
1011240µs1.36msCarp::::short_error_loc Carp::short_error_loc
161146µs46µsCarp::::_cgc Carp::_cgc
11133µs33µsCarp::::BEGIN@95 Carp::BEGIN@95
11123µs23µsCarp::::BEGIN@3 Carp::BEGIN@3
11120µs20µsCarp::::BEGIN@574 Carp::BEGIN@574
33116µs16µsCarp::::_fetch_sub Carp::_fetch_sub
11114µs20µsCarp::::BEGIN@6 Carp::BEGIN@6
11111µs19µsCarp::::BEGIN@730 Carp::BEGIN@730
1119µs17µsCarp::::BEGIN@137 Carp::BEGIN@137
1116µs12µsCarp::::BEGIN@256 Carp::BEGIN@256
1116µs24µsCarp::::BEGIN@744 Carp::BEGIN@744
1115µs11µsCarp::::BEGIN@73 Carp::BEGIN@73
1115µs7µsCarp::::BEGIN@751 Carp::BEGIN@751
1115µs5µsCarp::::_univ_mod_loaded Carp::_univ_mod_loaded
1114µs4µsCarp::::BEGIN@296 Carp::BEGIN@296
1114µs4µsCarp::::BEGIN@49 Carp::BEGIN@49
1114µs11µsCarp::::BEGIN@61 Carp::BEGIN@61
1113µs8µsCarp::::BEGIN@188 Carp::BEGIN@188
1113µs5µsCarp::::BEGIN@4 Carp::BEGIN@4
1112µs15µsCarp::::BEGIN@5 Carp::BEGIN@5
0000s0sCarp::::__ANON__[:103] Carp::__ANON__[:103]
0000s0sCarp::::__ANON__[:115] Carp::__ANON__[:115]
0000s0sCarp::::__ANON__[:139] Carp::__ANON__[:139]
0000s0sCarp::::__ANON__[:185] Carp::__ANON__[:185]
0000s0sCarp::::__ANON__[:189] Carp::__ANON__[:189]
0000s0sCarp::::__ANON__[:191] Carp::__ANON__[:191]
0000s0sCarp::::__ANON__[:193] Carp::__ANON__[:193]
0000s0sCarp::::__ANON__[:209] Carp::__ANON__[:209]
0000s0sCarp::::__ANON__[:408] Carp::__ANON__[:408]
0000s0sCarp::::__ANON__[:419] Carp::__ANON__[:419]
0000s0sCarp::::__ANON__[:66] Carp::__ANON__[:66]
0000s0sCarp::::__ANON__[:86] Carp::__ANON__[:86]
0000s0sCarp::::caller_info Carp::caller_info
0000s0sCarp::::carp Carp::carp
0000s0sCarp::::cluck Carp::cluck
0000s0sCarp::::confess Carp::confess
0000s0sCarp::::croak Carp::croak
0000s0sCarp::::export_fail Carp::export_fail
0000s0sCarp::::format_arg Carp::format_arg
0000s0sCarp::::get_subname Carp::get_subname
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::::ret_summary Carp::ret_summary
0000s0sCarp::::shortmess Carp::shortmess
0000s0sCarp::::shortmess_heavy Carp::shortmess_heavy
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
3239µs123µs
# spent 23µs within Carp::BEGIN@3 which was called: # once (23µs+0s) by Moo::_Utils::BEGIN@37 at line 3
{ use 5.006; }
# spent 23µs making 1 call to Carp::BEGIN@3
4313µs27µs
# spent 5µs (3+2) within Carp::BEGIN@4 which was called: # once (3µs+2µs) by Moo::_Utils::BEGIN@37 at line 4
use strict;
# spent 5µs making 1 call to Carp::BEGIN@4 # spent 2µs making 1 call to strict::import
5238µs228µs
# spent 15µs (2+13) within Carp::BEGIN@5 which was called: # once (2µs+13µs) by Moo::_Utils::BEGIN@37 at line 5
use warnings;
# spent 15µs making 1 call to Carp::BEGIN@5 # spent 13µs making 1 call to warnings::import
6
# spent 20µs (14+6) within Carp::BEGIN@6 which was called: # once (14µs+6µs) by Moo::_Utils::BEGIN@37 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.
21114µs if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
# spent 1µs executing statements in string eval
22 ${^WARNING_BITS} = "";
23 } else {
2412µs16µs "warnings"->unimport("utf8");
# spent 6µs making 1 call to warnings::unimport
25 }
261108µs120µs}
# spent 20µs making 1 call to Carp::BEGIN@6
27
28
# spent 16µs within Carp::_fetch_sub which was called 3 times, avg 5µs/call: # once (7µs+0s) by Carp::BEGIN@61 at line 62 # once (6µs+0s) by Carp::BEGIN@73 at line 74 # once (3µs+0s) by Carp::BEGIN@137 at line 144
sub _fetch_sub { # fetch sub without autovivifying
2932µs my($pack, $sub) = @_;
3031µs $pack .= '::';
31 # only works with top-level packages
3231µs return unless exists($::{$pack});
3330s for ($::{$pack}) {
3435µs return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
3530s for ($$_{$sub}) {
36 return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
37313µ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 Moo::_Utils::BEGIN@37 at line 55
BEGIN {
5014µs if("$]" < 5.013011) {
51 *UTF8_REGEXP_PROBLEM = sub () { 1 };
52 } else {
5310s *UTF8_REGEXP_PROBLEM = sub () { 0 };
54 }
55149µ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 11µs (4+7) within Carp::BEGIN@61 which was called: # once (4µs+7µs) by Moo::_Utils::BEGIN@37 at line 68
BEGIN {
6212µs17µs if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
# spent 7µ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 }
68180µs111µs}
# spent 11µ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 11µs (5+6) within Carp::BEGIN@73 which was called: # once (5µs+6µs) by Moo::_Utils::BEGIN@37 at line 88
BEGIN {
7412µs16µs if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
# spent 6µ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 }
88168µs111µs}
# spent 11µs making 1 call to Carp::BEGIN@73
89
90# is_safe_printable_codepoint() indicates whether a character, specified
91# by integer codepoint, is OK to output literally in a trace. Generally
92# this is if it is a printable character in the ancestral character set
93# (ASCII or EBCDIC). This is used on some Perls in situations where a
94# regexp can't be used.
95
# spent 33µs within Carp::BEGIN@95 which was called: # once (33µs+0s) by Moo::_Utils::BEGIN@37 at line 117
BEGIN {
96 *is_safe_printable_codepoint =
97 "$]" >= 5.007_003 ?
98 eval(q(sub ($) {
99 my $u = utf8::native_to_unicode($_[0]);
100 $u >= 0x20 && $u <= 0x7e;
101 }))
102 : ord("A") == 65 ?
103 sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e }
104 :
105 sub ($) {
106 # Early EBCDIC
107 # 3 EBCDIC code pages supported then; all controls but one
108 # are the code points below SPACE. The other one is 0x5F on
109 # POSIX-BC; FF on the other two.
110 # FIXME: there are plenty of unprintable codepoints other
111 # than those that this code and the comment above identifies
112 # as "controls".
113 $_[0] >= ord(" ") && $_[0] <= 0xff &&
114 $_[0] != (ord ("^") == 106 ? 0x5f : 0xff);
115 }
116130µs ;
# spent 3µs executing statements in string eval
1171125µs133µs}
# spent 33µs making 1 call to Carp::BEGIN@95
118
119
# spent 5µs within Carp::_univ_mod_loaded which was called: # once (5µs+0s) by Carp::BEGIN@137 at line 138
sub _univ_mod_loaded {
12010s return 0 unless exists($::{"UNIVERSAL::"});
12110s for ($::{"UNIVERSAL::"}) {
12217µs return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"};
123 for ($$_{"$_[0]::"}) {
124 return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"};
125 for ($$_{"VERSION"}) {
126 return 0 unless ref \$_ eq "GLOB";
127 return ${*$_{SCALAR}};
128 }
129 }
130 }
131}
132
133# _maybe_isa() is usually the UNIVERSAL::isa function. We have to avoid
134# the latter if the UNIVERSAL::isa module has been loaded, to avoid infi-
135# nite recursion; in that case _maybe_isa simply returns true.
13610smy $isa;
137
# spent 17µs (9+8) within Carp::BEGIN@137 which was called: # once (9µs+8µs) by Moo::_Utils::BEGIN@37 at line 146
BEGIN {
13812µs15µs if (_univ_mod_loaded('isa')) {
# spent 5µs making 1 call to Carp::_univ_mod_loaded
139 *_maybe_isa = sub { 1 }
140 }
141 else {
142 # Since we have already done the check, record $isa for use below
143 # when defining _StrVal.
14412µs13µs *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa");
# spent 3µs making 1 call to Carp::_fetch_sub
145 }
146169µs117µs}
# spent 17µs making 1 call to Carp::BEGIN@137
147
148
149# We need an overload::StrVal or equivalent function, but we must avoid
150# loading any modules on demand, as Carp is used from __DIE__ handlers and
151# may be invoked after a syntax error.
152# We can copy recent implementations of overload::StrVal and use
153# overloading.pm, which is the fastest implementation, so long as
154# overloading is available. If it is not available, we use our own pure-
155# Perl StrVal. We never actually use overload::StrVal, for various rea-
156# sons described below.
157# overload versions are as follows:
158# undef-1.00 (up to perl 5.8.0) uses bless (avoid!)
159# 1.01-1.17 (perl 5.8.1 to 5.14) uses Scalar::Util
160# 1.18+ (perl 5.16+) uses overloading
161# The ancient 'bless' implementation (that inspires our pure-Perl version)
162# blesses unblessed references and must be avoided. Those using
163# Scalar::Util use refaddr, possibly the pure-Perl implementation, which
164# has the same blessing bug, and must be avoided. Also, Scalar::Util is
165# loaded on demand. Since we avoid the Scalar::Util implementations, we
166# end up having to implement our own overloading.pm-based version for perl
167# 5.10.1 to 5.14. Since it also works just as well in more recent ver-
168# sions, we use it there, too.
169
# spent 1.09ms (1.04+54µs) within Carp::BEGIN@169 which was called: # once (1.04ms+54µs) by Moo::_Utils::BEGIN@37 at line 211
BEGIN {
1702735µs if (eval { require "overloading.pm" }) {
171128µs *_StrVal = eval 'sub { no overloading; "$_[0]" }'
# spent 28µs executing statements in string eval
# includes 10µs spent executing 1 call to 2 subs defined therein.
172 }
173 else {
174 # Work around the UNIVERSAL::can/isa modules to avoid recursion.
175
176 # _mycan is either UNIVERSAL::can, or, in the presence of an
177 # override, overload::mycan.
178 *_mycan = _univ_mod_loaded('can')
179 ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
180 : \&UNIVERSAL::can;
181
182 # _blessed is either UNIVERAL::isa(...), or, in the presence of an
183 # override, a hideous, but fairly reliable, workaround.
184 *_blessed = $isa
185 ? sub { &$isa($_[0], "UNIVERSAL") }
186 : sub {
187 my $probe = "UNIVERSAL::Carp_probe_" . rand;
1882116µs213µs
# spent 8µs (3+5) within Carp::BEGIN@188 which was called: # once (3µs+5µs) by Moo::_Utils::BEGIN@37 at line 188
no strict 'refs';
# spent 8µs making 1 call to Carp::BEGIN@188 # spent 5µs making 1 call to strict::unimport
189 local *$probe = sub { "unlikely string" };
190 local $@;
191 local $SIG{__DIE__} = sub{};
192 (eval { $_[0]->$probe } || '') eq 'unlikely string'
193 };
194
195 *_StrVal = sub {
196 my $pack = ref $_[0];
197 # Perl's overload mechanism uses the presence of a special
198 # "method" named "((" or "()" to signal it is in effect.
199 # This test seeks to see if it has been set up. "((" post-
200 # dates overloading.pm, so we can skip it.
201 return "$_[0]" unless _mycan($pack, "()");
202 # Even at this point, the invocant may not be blessed, so
203 # check for that.
204 return "$_[0]" if not _blessed($_[0]);
205 bless $_[0], "Carp";
206 my $str = "$_[0]";
207 bless $_[0], $pack;
208 $pack . substr $str, index $str, "=";
209 }
210 }
2111383µs11.09ms}
# spent 1.09ms making 1 call to Carp::BEGIN@169
212
213
21410sour $VERSION = '1.52';
21511µs$VERSION =~ tr/_//d;
216
21710sour $MaxEvalLen = 0;
21810sour $Verbose = 0;
21910sour $CarpLevel = 0;
22010sour $MaxArgLen = 64; # How much of each argument to print. 0 = all.
22110sour $MaxArgNums = 8; # How many arguments to print. 0 = all.
22210sour $RefArgFormatter = undef; # allow caller to format reference arguments
223
22411µsrequire Exporter;
22517µsour @ISA = ('Exporter');
22610sour @EXPORT = qw(confess croak carp);
22711µsour @EXPORT_OK = qw(cluck verbose longmess shortmess);
22810sour @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
229
230# The members of %Internal are packages that are internal to perl.
231# Carp will not report errors from within these packages if it
232# can. The members of %CarpInternal are internal to Perl's warning
233# system. Carp will not report errors from within these packages
234# either, and will not report calls *to* these packages for carp and
235# croak. They replace $CarpLevel, which is deprecated. The
236# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
237# text and function arguments should be formatted when printed.
238
239our %CarpInternal;
240our %Internal;
241
242# disable these by default, so they can live w/o require Carp
24311µs$CarpInternal{Carp}++;
24410s$CarpInternal{warnings}++;
24510s$Internal{Exporter}++;
24610s$Internal{'Exporter::Heavy'}++;
247
248# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
249# then the following method will be called by the Exporter which knows
250# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
251# 'verbose'.
252
253sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
254
255
# spent 46µs within Carp::_cgc which was called 16 times, avg 3µs/call: # 16 times (46µs+0s) by Carp::short_error_loc at line 651, avg 3µs/call
sub _cgc {
2562212µs218µs
# spent 12µs (6+6) within Carp::BEGIN@256 which was called: # once (6µs+6µs) by Moo::_Utils::BEGIN@37 at line 256
no strict 'refs';
# spent 12µs making 1 call to Carp::BEGIN@256 # spent 6µs making 1 call to strict::unimport
2571627µs return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
2581660µs return;
259}
260
261sub longmess {
262 local($!, $^E);
263 # Icky backwards compatibility wrapper. :-(
264 #
265 # The story is that the original implementation hard-coded the
266 # number of call levels to go back, so calls to longmess were off
267 # by one. Other code began calling longmess and expecting this
268 # behaviour, so the replacement has to emulate that behaviour.
269 my $cgc = _cgc();
270 my $call_pack = $cgc ? $cgc->() : caller();
271 if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
272 return longmess_heavy(@_);
273 }
274 else {
275 local $CarpLevel = $CarpLevel + 1;
276 return longmess_heavy(@_);
277 }
278}
279
280our @CARP_NOT;
281
282sub shortmess {
283 local($!, $^E);
284 my $cgc = _cgc();
285
286 # Icky backwards compatibility wrapper. :-(
287 local @CARP_NOT = scalar( $cgc ? $cgc->() : caller() );
288 shortmess_heavy(@_);
289}
290
291sub croak { die shortmess @_ }
292sub confess { die longmess @_ }
293sub carp { warn shortmess @_ }
294sub cluck { warn longmess @_ }
295
296
# spent 4µs within Carp::BEGIN@296 which was called: # once (4µs+0s) by Moo::_Utils::BEGIN@37 at line 303
BEGIN {
29715µs if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
298 ("$]" >= 5.012005 && "$]" < 5.013)) {
299 *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
300 } else {
301 *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
302 }
30311.13ms14µs}
# spent 4µs making 1 call to Carp::BEGIN@296
304
305sub caller_info {
306 my $i = shift(@_) + 1;
307 my %call_info;
308 my $cgc = _cgc();
309 {
310 # Some things override caller() but forget to implement the
311 # @DB::args part of it, which we need. We check for this by
312 # pre-populating @DB::args with a sentinel which no-one else
313 # has the address of, so that we can detect whether @DB::args
314 # has been properly populated. However, on earlier versions
315 # of perl this check tickles a bug in CORE::caller() which
316 # leaks memory. So we only check on fixed perls.
317 @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
318 package DB;
319
- -
324 unless ( defined $call_info{file} ) {
325 return ();
326 }
327
328 my $sub_name = Carp::get_subname( \%call_info );
329 if ( $call_info{has_args} ) {
330 # Guard our serialization of the stack from stack refcounting bugs
331 # NOTE this is NOT a complete solution, we cannot 100% guard against
332 # these bugs. However in many cases Perl *is* capable of detecting
333 # them and throws an error when it does. Unfortunately serializing
334 # the arguments on the stack is a perfect way of finding these bugs,
335 # even when they would not affect normal program flow that did not
336 # poke around inside the stack. Inside of Carp.pm it makes little
337 # sense reporting these bugs, as Carp's job is to report the callers
338 # errors, not the ones it might happen to tickle while doing so.
339 # See: https://rt.perl.org/Public/Bug/Display.html?id=131046
340 # and: https://rt.perl.org/Public/Bug/Display.html?id=52610
341 # for more details and discussion. - Yves
342 my @args = map {
343 my $arg;
344 local $@= $@;
345 eval {
346 $arg = $_;
347 1;
348 } or do {
349 $arg = '** argument not available anymore **';
350 };
351 $arg;
352 } @DB::args;
353 if (CALLER_OVERRIDE_CHECK_OK && @args == 1
354 && ref $args[0] eq ref \$i
355 && $args[0] == \$i ) {
356 @args = (); # Don't let anyone see the address of $i
357 local $@;
358 my $where = eval {
359 my $func = $cgc or return '';
360 my $gv =
361 (_fetch_sub B => 'svref_2object' or return '')
362 ->($func)->GV;
363 my $package = $gv->STASH->NAME;
364 my $subname = $gv->NAME;
365 return unless defined $package && defined $subname;
366
367 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
368 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
369 " in &${package}::$subname";
370 } || '';
371 @args
372 = "** Incomplete caller override detected$where; \@DB::args were not set **";
373 }
374 else {
375 my $overflow;
376 if ( $MaxArgNums and @args > $MaxArgNums )
377 { # More than we want to show?
378 $#args = $MaxArgNums - 1;
379 $overflow = 1;
380 }
381
382 @args = map { Carp::format_arg($_) } @args;
383
384 if ($overflow) {
385 push @args, '...';
386 }
387 }
388
389 # Push the args onto the subroutine
390 $sub_name .= '(' . join( ', ', @args ) . ')';
391 }
392 $call_info{sub_name} = $sub_name;
393 return wantarray() ? %call_info : \%call_info;
394}
395
396# Transform an argument to a function into a string.
397our $in_recurse;
398sub format_arg {
399 my $arg = shift;
400
401 if ( my $pack= ref($arg) ) {
402
403 # legitimate, let's not leak it.
404 if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) &&
405 do {
406 local $@;
407 local $in_recurse = 1;
408 local $SIG{__DIE__} = sub{};
409 eval {$arg->can('CARP_TRACE') }
410 })
411 {
412 return $arg->CARP_TRACE();
413 }
414 elsif (!$in_recurse &&
415 defined($RefArgFormatter) &&
416 do {
417 local $@;
418 local $in_recurse = 1;
419 local $SIG{__DIE__} = sub{};
420 eval {$arg = $RefArgFormatter->($arg); 1}
421 })
422 {
423 return $arg;
424 }
425 else
426 {
427 # Argument may be blessed into a class with overloading, and so
428 # might have an overloaded stringification. We don't want to
429 # risk getting the overloaded stringification, so we need to
430 # use _StrVal, our overload::StrVal()-equivalent.
431 return _StrVal $arg;
432 }
433 }
434 return "undef" if !defined($arg);
435 downgrade($arg, 1);
436 return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
437 $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
438 my $suffix = "";
439 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
440 substr ( $arg, $MaxArgLen - 3 ) = "";
441 $suffix = "...";
442 }
443 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
444 for(my $i = length($arg); $i--; ) {
445 my $c = substr($arg, $i, 1);
446 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
447 if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
448 substr $arg, $i, 0, "\\";
449 next;
450 }
451 my $o = ord($c);
452 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
453 unless is_safe_printable_codepoint($o);
454 }
455 } else {
456 $arg =~ s/([\"\\\$\@])/\\$1/g;
457 # This is all the ASCII printables spelled-out. It is portable to all
458 # Perl versions and platforms (such as EBCDIC). There are other more
459 # compact ways to do this, but may not work everywhere every version.
460 $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
461 }
462 downgrade($arg, 1);
463 return "\"".$arg."\"".$suffix;
464}
465
466sub Regexp::CARP_TRACE {
467 my $arg = "$_[0]";
468 downgrade($arg, 1);
469 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
470 for(my $i = length($arg); $i--; ) {
471 my $o = ord(substr($arg, $i, 1));
472 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
473 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
474 unless is_safe_printable_codepoint($o);
475 }
476 } else {
477 # See comment in format_arg() about this same regex.
478 $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
479 }
480 downgrade($arg, 1);
481 my $suffix = "";
482 if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
483 ($suffix, $arg) = ($1, $2);
484 }
485 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
486 substr ( $arg, $MaxArgLen - 3 ) = "";
487 $suffix = "...".$suffix;
488 }
489 return "qr($arg)$suffix";
490}
491
492# Takes an inheritance cache and a package and returns
493# an anon hash of known inheritances and anon array of
494# inheritances which consequences have not been figured
495# for.
496
# spent 678µs (343+335) within Carp::get_status which was called 123 times, avg 6µs/call: # 96 times (228µs+247µs) by Carp::trusts at line 719, avg 5µs/call # 27 times (115µs+88µs) by Carp::trusts at line 712, avg 8µs/call
sub get_status {
49712310µs my $cache = shift;
49812315µs my $pkg = shift;
499123176µs115335µs $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
# spent 335µs making 115 calls to Carp::trusts_directly, avg 3µs/call
500123132µs return @{ $cache->{$pkg} };
501}
502
503# Takes the info from caller() and figures out the name of
504# the sub/require/eval
505sub get_subname {
506 my $info = shift;
507 if ( defined( $info->{evaltext} ) ) {
508 my $eval = $info->{evaltext};
509 if ( $info->{is_require} ) {
510 return "require $eval";
511 }
512 else {
513 $eval =~ s/([\\\'])/\\$1/g;
514 return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
515 }
516 }
517
518 # this can happen on older perls when the sub (or the stash containing it)
519 # has been deleted
520 if ( !defined( $info->{sub} ) ) {
521 return '__ANON__::__ANON__';
522 }
523
524 return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
525}
526
527# Figures out what call (from the point of view of the caller)
528# the long error backtrace should start at.
529sub long_error_loc {
530 my $i;
531 my $lvl = $CarpLevel;
532 {
533 ++$i;
534 my $cgc = _cgc();
535 my @caller = $cgc ? $cgc->($i) : caller($i);
536 my $pkg = $caller[0];
537 unless ( defined($pkg) ) {
538
539 # This *shouldn't* happen.
540 if (%Internal) {
541 local %Internal;
542 $i = long_error_loc();
543 last;
544 }
545 elsif (defined $caller[2]) {
546 # this can happen when the stash has been deleted
547 # in that case, just assume that it's a reasonable place to
548 # stop (the file and line data will still be intact in any
549 # case) - the only issue is that we can't detect if the
550 # deleted package was internal (so don't do that then)
551 # -doy
552 redo unless 0 > --$lvl;
553 last;
554 }
555 else {
556 return 2;
557 }
558 }
559 redo if $CarpInternal{$pkg};
560 redo unless 0 > --$lvl;
561 redo if $Internal{$pkg};
562 }
563 return $i - 1;
564}
565
566sub longmess_heavy {
567 if ( ref( $_[0] ) ) { # don't break references as exceptions
568 return wantarray ? @_ : $_[0];
569 }
570 my $i = long_error_loc();
571 return ret_backtrace( $i, @_ );
572}
573
574
# spent 20µs within Carp::BEGIN@574 which was called: # once (20µs+0s) by Moo::_Utils::BEGIN@37 at line 581
BEGIN {
57515µs if("$]" >= 5.017004) {
576 # The LAST_FH constant is a reference to the variable.
577112µs $Carp::{LAST_FH} = \eval '\${^LAST_FH}';
# spent 3µs executing statements in string eval
578 } else {
579 eval '*LAST_FH = sub () { 0 }';
580 }
5811463µs120µs}
# spent 20µs making 1 call to Carp::BEGIN@574
582
583# Returns a full stack backtrace starting from where it is
584# told.
585sub ret_backtrace {
586 my ( $i, @error ) = @_;
587 my $mess;
588 my $err = join '', @error;
589 $i++;
590
591 my $tid_msg = '';
592 if ( defined &threads::tid ) {
593 my $tid = threads->tid;
594 $tid_msg = " thread $tid" if $tid;
595 }
596
597 my %i = caller_info($i);
598 $mess = "$err at $i{file} line $i{line}$tid_msg";
599 if( $. ) {
600 # Use ${^LAST_FH} if available.
601 if (LAST_FH) {
602 if (${+LAST_FH}) {
603 $mess .= sprintf ", <%s> %s %d",
604 *${+LAST_FH}{NAME},
605 ($/ eq "\n" ? "line" : "chunk"), $.
606 }
607 }
608 else {
609 local $@ = '';
610 local $SIG{__DIE__};
611 eval {
612 CORE::die;
613 };
614 if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
615 $mess .= $1;
616 }
617 }
618 }
619 $mess .= "\.\n";
620
621 while ( my %i = caller_info( ++$i ) ) {
622 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
623 }
624
625 return $mess;
626}
627
628sub ret_summary {
629 my ( $i, @error ) = @_;
630 my $err = join '', @error;
631 $i++;
632
633 my $tid_msg = '';
634 if ( defined &threads::tid ) {
635 my $tid = threads->tid;
636 $tid_msg = " thread $tid" if $tid;
637 }
638
639 my %i = caller_info($i);
640 return "$err at $i{file} line $i{line}$tid_msg\.\n";
641}
642
643
# spent 1.36ms (240µs+1.12) within Carp::short_error_loc which was called 10 times, avg 136µs/call: # 10 times (240µs+1.12ms) by Method::Generate::Constructor::install_delayed at line 80 of Method/Generate/Constructor.pm, avg 136µs/call
sub short_error_loc {
644 # You have to create your (hash)ref out here, rather than defaulting it
645 # inside trusts *on a lexical*, as you want it to persist across calls.
646 # (You can default it on $_[2], but that gets messy)
647101µs my $cache = {};
648106µs my $i = 1;
649101µs my $lvl = $CarpLevel;
650 {
6512627µs1646µs my $cgc = _cgc();
# spent 46µs making 16 calls to Carp::_cgc, avg 3µs/call
6521610µs my $called = $cgc ? $cgc->($i) : caller($i);
653163µs $i++;
654169µs my $caller = $cgc ? $cgc->($i) : caller($i);
655
656163µs if (!defined($caller)) {
657 my @caller = $cgc ? $cgc->($i) : caller($i);
658 if (@caller) {
659 # if there's no package but there is other caller info, then
660 # the package has been deleted - treat this as a valid package
661 # in this case
662 redo if defined($called) && $CarpInternal{$called};
663 redo unless 0 > --$lvl;
664 last;
665 }
666 else {
667 return 0;
668 }
669 }
6701610µs redo if $Internal{$caller};
671167µs redo if $CarpInternal{$caller};
672162µs redo if $CarpInternal{$called};
6731621µs16954µs redo if trusts( $called, $caller, $cache );
# spent 954µs making 16 calls to Carp::trusts, avg 60µs/call
674113µs11124µs redo if trusts( $caller, $called, $cache );
# spent 124µs making 11 calls to Carp::trusts, avg 11µs/call
675102µs redo unless 0 > --$lvl;
676 }
6771077µs return $i - 1;
678}
679
680sub shortmess_heavy {
681 return longmess_heavy(@_) if $Verbose;
682 return @_ if ref( $_[0] ); # don't break references as exceptions
683 my $i = short_error_loc();
684 if ($i) {
685 ret_summary( $i, @_ );
686 }
687 else {
688 longmess_heavy(@_);
689 }
690}
691
692# If a string is too long, trims it with ...
693sub str_len_trim {
694 my $str = shift;
695 my $max = shift || 0;
696 if ( 2 < $max and $max < length($str) ) {
697 substr( $str, $max - 3 ) = '...';
698 }
699 return $str;
700}
701
702# Takes two packages and an optional cache. Says whether the
703# first inherits from the second.
704#
705# Recursive versions of this have to work to avoid certain
706# possible endless loops, and when following long chains of
707# inheritance are less efficient.
708
# spent 1.08ms (400µs+678µs) within Carp::trusts which was called 27 times, avg 40µs/call: # 16 times (367µs+587µs) by Carp::short_error_loc at line 673, avg 60µs/call # 11 times (33µs+91µs) by Carp::short_error_loc at line 674, avg 11µs/call
sub trusts {
709274µs my $child = shift;
710273µs my $parent = shift;
711275µs my $cache = shift;
7122728µs27203µs my ( $known, $partial ) = get_status( $cache, $child );
# spent 203µs making 27 calls to Carp::get_status, avg 8µs/call
713
714 # Figure out consequences until we have an answer
7152719µs while ( @$partial and not exists $known->{$parent} ) {
71615623µs my $anc = shift @$partial;
71715622µs next if exists $known->{$anc};
7189640µs $known->{$anc}++;
7199658µs96475µs my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
# spent 475µs making 96 calls to Carp::get_status, avg 5µs/call
7209639µs my @found = keys %$anc_knows;
7219618µs @$known{@found} = ();
7229655µs push @$partial, @$anc_partial;
723 }
7242748µs return exists $known->{$parent};
725}
726
727# Takes a package and gives a list of those trusted directly
728
# spent 335µs within Carp::trusts_directly which was called 115 times, avg 3µs/call: # 115 times (335µs+0s) by Carp::get_status at line 499, avg 3µs/call
sub trusts_directly {
72911510µs my $class = shift;
730295µs227µs
# spent 19µs (11+8) within Carp::BEGIN@730 which was called: # once (11µs+8µs) by Moo::_Utils::BEGIN@37 at line 730
no strict 'refs';
# spent 19µs making 1 call to Carp::BEGIN@730 # spent 8µs making 1 call to strict::unimport
73111598µs my $stash = \%{"$class\::"};
73211521µs for my $var (qw/ CARP_NOT ISA /) {
733 # Don't try using the variable until we know it exists,
734 # to avoid polluting the caller's namespace.
735180218µs if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
736 && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
737 return @{$stash->{$var}}
738 }
739 }
7406052µs return;
741}
742
74310sif(!defined($warnings::VERSION) ||
744324µs242µs
# spent 24µs (6+18) within Carp::BEGIN@744 which was called: # once (6µs+18µs) by Moo::_Utils::BEGIN@37 at line 744
do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
# spent 24µs making 1 call to Carp::BEGIN@744 # spent 18µs making 1 call to warnings::unimport
745 # Very old versions of warnings.pm import from Carp. This can go
746 # wrong due to the circular dependency. If Carp is invoked before
747 # warnings, then Carp starts by loading warnings, then warnings
748 # tries to import from Carp, and gets nothing because Carp is in
749 # the process of loading and hasn't defined its import method yet.
750 # So we work around that by manually exporting to warnings here.
7512113µs29µs
# spent 7µs (5+2) within Carp::BEGIN@751 which was called: # once (5µs+2µs) by Moo::_Utils::BEGIN@37 at line 751
no strict "refs";
# spent 7µs making 1 call to Carp::BEGIN@751 # spent 2µs making 1 call to strict::unimport
752 *{"warnings::$_"} = \&$_ foreach @EXPORT;
753}
754
755110µs1;
756
757__END__
Report produced by the NYTProf 6.12 Perl profiler, developed by Tim Bunce based on work by Adam Kaplan and Salvador Fandiño García.