Profile of Carp.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/5.38.2/Carp.pm
Statements | Executed 77 statements in 3.11ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 331µs | 371µs | Carp::::BEGIN@169 Carp::BEGIN@169
1 | 1 | 1 | 43µs | 43µs | Carp::::BEGIN@95 Carp::BEGIN@95
1 | 1 | 1 | 21µs | 33µs | Carp::::BEGIN@6 Carp::BEGIN@6
1 | 1 | 1 | 20µs | 20µs | Carp::::BEGIN@574 Carp::BEGIN@574
3 | 3 | 1 | 15µs | 15µs | Carp::::_fetch_sub Carp::_fetch_sub
1 | 1 | 1 | 11µs | 11µs | Carp::::BEGIN@3 Carp::BEGIN@3
1 | 1 | 1 | 8µs | 14µs | Carp::::BEGIN@61 Carp::BEGIN@61
1 | 1 | 1 | 7µs | 15µs | Carp::::BEGIN@137 Carp::BEGIN@137
1 | 1 | 1 | 7µs | 12µs | Carp::::BEGIN@730 Carp::BEGIN@730
1 | 1 | 1 | 6µs | 11µs | Carp::::BEGIN@256 Carp::BEGIN@256
1 | 1 | 1 | 6µs | 11µs | Carp::::BEGIN@188 Carp::BEGIN@188
1 | 1 | 1 | 6µs | 8µs | Carp::::BEGIN@4 Carp::BEGIN@4
1 | 1 | 1 | 6µs | 11µs | Carp::::BEGIN@73 Carp::BEGIN@73
1 | 1 | 1 | 5µs | 5µs | Carp::::BEGIN@296 Carp::BEGIN@296
1 | 1 | 1 | 5µs | 5µs | Carp::::BEGIN@49 Carp::BEGIN@49
1 | 1 | 1 | 5µs | 8µs | Carp::::BEGIN@751 Carp::BEGIN@751
1 | 1 | 1 | 4µs | 16µs | Carp::::BEGIN@744 Carp::BEGIN@744
1 | 1 | 1 | 4µs | 4µs | Carp::::_univ_mod_loaded Carp::_univ_mod_loaded
1 | 1 | 1 | 3µs | 19µs | Carp::::BEGIN@5 Carp::BEGIN@5
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:103] Carp::__ANON__[:103]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:115] Carp::__ANON__[:115]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:139] Carp::__ANON__[:139]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:185] Carp::__ANON__[:185]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:189] Carp::__ANON__[:189]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:191] Carp::__ANON__[:191]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:193] Carp::__ANON__[:193]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:209] Carp::__ANON__[:209]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:408] Carp::__ANON__[:408]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:419] Carp::__ANON__[:419]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:66] Carp::__ANON__[:66]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:86] Carp::__ANON__[:86]
0 | 0 | 0 | 0s | 0s | Carp::::_cgc Carp::_cgc
0 | 0 | 0 | 0s | 0s | Carp::::caller_info Carp::caller_info
0 | 0 | 0 | 0s | 0s | Carp::::carp Carp::carp
0 | 0 | 0 | 0s | 0s | Carp::::cluck Carp::cluck
0 | 0 | 0 | 0s | 0s | Carp::::confess Carp::confess
0 | 0 | 0 | 0s | 0s | Carp::::croak Carp::croak
0 | 0 | 0 | 0s | 0s | Carp::::export_fail Carp::export_fail
0 | 0 | 0 | 0s | 0s | Carp::::format_arg Carp::format_arg
0 | 0 | 0 | 0s | 0s | Carp::::get_status Carp::get_status
0 | 0 | 0 | 0s | 0s | Carp::::get_subname Carp::get_subname
0 | 0 | 0 | 0s | 0s | Carp::::long_error_loc Carp::long_error_loc
0 | 0 | 0 | 0s | 0s | Carp::::longmess Carp::longmess
0 | 0 | 0 | 0s | 0s | Carp::::longmess_heavy Carp::longmess_heavy
0 | 0 | 0 | 0s | 0s | Carp::::ret_backtrace Carp::ret_backtrace
0 | 0 | 0 | 0s | 0s | Carp::::ret_summary Carp::ret_summary
0 | 0 | 0 | 0s | 0s | Carp::::short_error_loc Carp::short_error_loc
0 | 0 | 0 | 0s | 0s | Carp::::shortmess Carp::shortmess
0 | 0 | 0 | 0s | 0s | Carp::::shortmess_heavy Carp::shortmess_heavy
0 | 0 | 0 | 0s | 0s | Carp::::str_len_trim Carp::str_len_trim
0 | 0 | 0 | 0s | 0s | Carp::::trusts Carp::trusts
0 | 0 | 0 | 0s | 0s | Carp::::trusts_directly Carp::trusts_directly
0 | 0 | 0 | 0s | 0s | Regexp::::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
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Carp;
2 |  |  |  |  |
3 | 2 | 46µs | 1 | 11µs | # spent 11µs within Carp::BEGIN@3 which was called: # once (11µs+0s) by Tie::Hash::BEGIN@190 at line 3 { use 5.006; } # spent 11µs making 1 call to Carp::BEGIN@3
4 | 3 | 19µs | 2 | 10µs | # spent 8µs (6+2) within Carp::BEGIN@4 which was called: # once (6µs+2µs) by Tie::Hash::BEGIN@190 at line 4 use strict; # spent 8µs making 1 call to Carp::BEGIN@4 # spent 2µs making 1 call to strict::import
5 | 2 | 46µs | 2 | 35µs | # spent 19µs (3+16) within Carp::BEGIN@5 which was called: # once (3µs+16µs) by Tie::Hash::BEGIN@190 at line 5 use warnings; # spent 19µs making 1 call to Carp::BEGIN@5 # spent 16µs making 1 call to warnings::import
6 |  |  |  |  | # spent 33µs (21+12) within Carp::BEGIN@6 which was called: # once (21µs+12µs) by Tie::Hash::BEGIN@190 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.
21 | 1 | 17µs |  |  | if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) { # spent 2µs executing statements in string eval
22 |  |  |  |  | ${^WARNING_BITS} = "";
23 |  |  |  |  | } else {
24 | 1 | 2µs | 1 | 12µs | "warnings"->unimport("utf8"); # spent 12µs making 1 call to warnings::unimport
25 |  |  |  |  | }
26 | 1 | 111µs | 1 | 33µs | } # spent 33µs making 1 call to Carp::BEGIN@6
27 |  |  |  |  |
28 |  |  |  |  | # spent 15µs within Carp::_fetch_sub which was called 3 times, avg 5µs/call: # once (6µs+0s) by Carp::BEGIN@61 at line 62 # once (5µs+0s) by Carp::BEGIN@73 at line 74 # once (4µs+0s) by Carp::BEGIN@137 at line 144 sub _fetch_sub { # fetch sub without autovivifying
29 | 3 | 2µs |  |  | my($pack, $sub) = @_;
30 | 3 | 1µs |  |  | $pack .= '::';
31 |  |  |  |  | # only works with top-level packages
32 | 3 | 1µs |  |  | return unless exists($::{$pack});
33 | 3 | 1µs |  |  | for ($::{$pack}) {
34 | 3 | 4µs |  |  | return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
35 | 3 | 900ns |  |  | for ($$_{$sub}) {
36 |  |  |  |  | return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
37 | 3 | 11µ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 5µs within Carp::BEGIN@49 which was called: # once (5µs+0s) by Tie::Hash::BEGIN@190 at line 55 BEGIN {
50 | 1 | 5µs |  |  | if("$]" < 5.013011) {
51 |  |  |  |  | *UTF8_REGEXP_PROBLEM = sub () { 1 };
52 |  |  |  |  | } else {
53 | 1 | 800ns |  |  | *UTF8_REGEXP_PROBLEM = sub () { 0 };
54 |  |  |  |  | }
55 | 1 | 56µs | 1 | 5µs | } # spent 5µ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 14µs (8+6) within Carp::BEGIN@61 which was called: # once (8µs+6µs) by Tie::Hash::BEGIN@190 at line 68 BEGIN {
62 | 1 | 3µs | 1 | 6µ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 |  |  |  |  | }
68 | 1 | 93µs | 1 | 14µs | } # spent 14µ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 (6+5) within Carp::BEGIN@73 which was called: # once (6µs+5µs) by Tie::Hash::BEGIN@190 at line 88 BEGIN {
74 | 1 | 3µs | 1 | 5µs | if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) { # spent 5µ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 |  |  |  |  | }
88 | 1 | 72µs | 1 | 11µ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 43µs within Carp::BEGIN@95 which was called: # once (43µs+0s) by Tie::Hash::BEGIN@190 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 |  |  |  |  | }
116 | 1 | 41µs |  |  | ; # spent 3µs executing statements in string eval
117 | 1 | 121µs | 1 | 43µs | } # spent 43µs making 1 call to Carp::BEGIN@95
118 |  |  |  |  |
119 |  |  |  |  | # spent 4µs within Carp::_univ_mod_loaded which was called: # once (4µs+0s) by Carp::BEGIN@137 at line 138 sub _univ_mod_loaded {
120 | 1 | 400ns |  |  | return 0 unless exists($::{"UNIVERSAL::"});
121 | 1 | 600ns |  |  | for ($::{"UNIVERSAL::"}) {
122 | 1 | 5µ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.
136 | 1 | 200ns |  |  | my $isa;
137 |  |  |  |  | # spent 15µs (7+8) within Carp::BEGIN@137 which was called: # once (7µs+8µs) by Tie::Hash::BEGIN@190 at line 146 BEGIN {
138 | 1 | 2µs | 1 | 4µs | if (_univ_mod_loaded('isa')) { # spent 4µ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.
144 | 1 | 1µs | 1 | 4µs | *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa"); # spent 4µs making 1 call to Carp::_fetch_sub
145 |  |  |  |  | }
146 | 1 | 85µs | 1 | 15µs | } # spent 15µ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 371µs (331+40) within Carp::BEGIN@169 which was called: # once (331µs+40µs) by Tie::Hash::BEGIN@190 at line 211 BEGIN {
170 | 2 | 75µs |  |  | if (eval { require "overloading.pm" }) {
171 | 1 | 22µs |  |  | *_StrVal = eval 'sub { no overloading; "$_[0]" }' # spent 25µs executing statements in string eval # includes 7µ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 UNIVERSAL::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;
188 | 2 | 129µs | 2 | 15µs | # spent 11µs (6+5) within Carp::BEGIN@188 which was called: # once (6µs+5µs) by Tie::Hash::BEGIN@190 at line 188 no strict 'refs'; # spent 11µ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 |  |  |  |  | }
211 | 1 | 131µs | 1 | 371µs | } # spent 371µs making 1 call to Carp::BEGIN@169
212 |  |  |  |  |
213 |  |  |  |  |
214 | 1 | 400ns |  |  | our $VERSION = '1.54';
215 | 1 | 800ns |  |  | $VERSION =~ tr/_//d;
216 |  |  |  |  |
217 | 1 | 200ns |  |  | our $MaxEvalLen = 0;
218 | 1 | 0s |  |  | our $Verbose = 0;
219 | 1 | 0s |  |  | our $CarpLevel = 0;
220 | 1 | 100ns |  |  | our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
221 | 1 | 100ns |  |  | our $MaxArgNums = 8; # How many arguments to print. 0 = all.
222 | 1 | 200ns |  |  | our $RefArgFormatter = undef; # allow caller to format reference arguments
223 |  |  |  |  |
224 | 1 | 400ns |  |  | require Exporter;
225 | 1 | 6µs |  |  | our @ISA = ('Exporter');
226 | 1 | 500ns |  |  | our @EXPORT = qw(confess croak carp);
227 | 1 | 400ns |  |  | our @EXPORT_OK = qw(cluck verbose longmess shortmess);
228 | 1 | 200ns |  |  | our @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 |  |  |  |  |
239 |  |  |  |  | our %CarpInternal;
240 |  |  |  |  | our %Internal;
241 |  |  |  |  |
242 |  |  |  |  | # disable these by default, so they can live w/o require Carp
243 | 1 | 600ns |  |  | $CarpInternal{Carp}++;
244 | 1 | 200ns |  |  | $CarpInternal{warnings}++;
245 | 1 | 200ns |  |  | $Internal{Exporter}++;
246 | 1 | 100ns |  |  | $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 |  |  |  |  |
253 |  |  |  |  | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
254 |  |  |  |  |
255 |  |  |  |  | sub _cgc {
256 | 2 | 248µs | 2 | 16µs | # spent 11µs (6+5) within Carp::BEGIN@256 which was called: # once (6µs+5µs) by Tie::Hash::BEGIN@190 at line 256 no strict 'refs'; # spent 11µs making 1 call to Carp::BEGIN@256 # spent 5µs making 1 call to strict::unimport
257 |  |  |  |  | return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
258 |  |  |  |  | return;
259 |  |  |  |  | }
260 |  |  |  |  |
261 |  |  |  |  | sub 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 |  |  |  |  |
280 |  |  |  |  | our @CARP_NOT;
281 |  |  |  |  |
282 |  |  |  |  | sub 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 |  |  |  |  |
291 |  |  |  |  | sub croak { die shortmess @_ }
292 |  |  |  |  | sub confess { die longmess @_ }
293 |  |  |  |  | sub carp { warn shortmess @_ }
294 |  |  |  |  | sub cluck { warn longmess @_ }
295 |  |  |  |  |
296 |  |  |  |  | # spent 5µs within Carp::BEGIN@296 which was called: # once (5µs+0s) by Tie::Hash::BEGIN@190 at line 303 BEGIN {
297 | 1 | 6µ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 |  |  |  |  | }
303 | 1 | 1.01ms | 1 | 5µs | } # spent 5µs making 1 call to Carp::BEGIN@296
304 |  |  |  |  |
305 |  |  |  |  | sub 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.
397 |  |  |  |  | our $in_recurse;
398 |  |  |  |  | sub 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 |  |  |  |  |
466 |  |  |  |  | sub 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 |  |  |  |  | sub get_status {
497 |  |  |  |  | my $cache = shift;
498 |  |  |  |  | my $pkg = shift;
499 |  |  |  |  | $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
500 |  |  |  |  | return @{ $cache->{$pkg} };
501 |  |  |  |  | }
502 |  |  |  |  |
503 |  |  |  |  | # Takes the info from caller() and figures out the name of
504 |  |  |  |  | # the sub/require/eval
505 |  |  |  |  | sub 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.
529 |  |  |  |  | sub 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 |  |  |  |  |
566 |  |  |  |  | sub 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 Tie::Hash::BEGIN@190 at line 581 BEGIN {
575 | 1 | 6µs |  |  | if("$]" >= 5.017004) {
576 |  |  |  |  | # The LAST_FH constant is a reference to the variable.
577 | 1 | 14µs |  |  | $Carp::{LAST_FH} = \eval '\${^LAST_FH}'; # spent 2µs executing statements in string eval
578 |  |  |  |  | } else {
579 |  |  |  |  | eval '*LAST_FH = sub () { 0 }';
580 |  |  |  |  | }
581 | 1 | 514µs | 1 | 20µ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.
585 |  |  |  |  | sub 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 |  |  |  |  |
628 |  |  |  |  | sub 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 |  |  |  |  | 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)
647 |  |  |  |  | my $cache = {};
648 |  |  |  |  | my $i = 1;
649 |  |  |  |  | my $lvl = $CarpLevel;
650 |  |  |  |  | {
651 |  |  |  |  | my $cgc = _cgc();
652 |  |  |  |  | my $called = $cgc ? $cgc->($i) : caller($i);
653 |  |  |  |  | $i++;
654 |  |  |  |  | my $caller = $cgc ? $cgc->($i) : caller($i);
655 |  |  |  |  |
656 |  |  |  |  | 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 |  |  |  |  | }
670 |  |  |  |  | redo if $Internal{$caller};
671 |  |  |  |  | redo if $CarpInternal{$caller};
672 |  |  |  |  | redo if $CarpInternal{$called};
673 |  |  |  |  | redo if trusts( $called, $caller, $cache );
674 |  |  |  |  | redo if trusts( $caller, $called, $cache );
675 |  |  |  |  | redo unless 0 > --$lvl;
676 |  |  |  |  | }
677 |  |  |  |  | return $i - 1;
678 |  |  |  |  | }
679 |  |  |  |  |
680 |  |  |  |  | sub 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 ...
693 |  |  |  |  | sub 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 |  |  |  |  | sub trusts {
709 |  |  |  |  | my $child = shift;
710 |  |  |  |  | my $parent = shift;
711 |  |  |  |  | my $cache = shift;
712 |  |  |  |  | my ( $known, $partial ) = get_status( $cache, $child );
713 |  |  |  |  |
714 |  |  |  |  | # Figure out consequences until we have an answer
715 |  |  |  |  | while ( @$partial and not exists $known->{$parent} ) {
716 |  |  |  |  | my $anc = shift @$partial;
717 |  |  |  |  | next if exists $known->{$anc};
718 |  |  |  |  | $known->{$anc}++;
719 |  |  |  |  | my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
720 |  |  |  |  | my @found = keys %$anc_knows;
721 |  |  |  |  | @$known{@found} = ();
722 |  |  |  |  | push @$partial, @$anc_partial;
723 |  |  |  |  | }
724 |  |  |  |  | return exists $known->{$parent};
725 |  |  |  |  | }
726 |  |  |  |  |
727 |  |  |  |  | # Takes a package and gives a list of those trusted directly
728 |  |  |  |  | sub trusts_directly {
729 |  |  |  |  | my $class = shift;
730 | 2 | 94µs | 2 | 17µs | # spent 12µs (7+5) within Carp::BEGIN@730 which was called: # once (7µs+5µs) by Tie::Hash::BEGIN@190 at line 730 no strict 'refs'; # spent 12µs making 1 call to Carp::BEGIN@730 # spent 5µs making 1 call to strict::unimport
731 |  |  |  |  | my $stash = \%{"$class\::"};
732 |  |  |  |  | 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.
735 |  |  |  |  | if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
736 |  |  |  |  | && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
737 |  |  |  |  | return @{$stash->{$var}}
738 |  |  |  |  | }
739 |  |  |  |  | }
740 |  |  |  |  | return;
741 |  |  |  |  | }
742 |  |  |  |  |
743 | 1 | 500ns |  |  | if(!defined($warnings::VERSION) ||
744 | 3 | 27µs | 2 | 28µs | # spent 16µs (4+12) within Carp::BEGIN@744 which was called: # once (4µs+12µs) by Tie::Hash::BEGIN@190 at line 744 do { no warnings "numeric"; $warnings::VERSION < 1.03 }) { # spent 16µs making 1 call to Carp::BEGIN@744 # spent 12µ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.
751 | 2 | 61µs | 2 | 12µs | # spent 8µs (5+4) within Carp::BEGIN@751 which was called: # once (5µs+4µs) by Tie::Hash::BEGIN@190 at line 751 no strict "refs"; # spent 8µs making 1 call to Carp::BEGIN@751 # spent 4µs making 1 call to strict::unimport
752 |  |  |  |  | *{"warnings::$_"} = \&$_ foreach @EXPORT;
753 |  |  |  |  | }
754 |  |  |  |  |
755 | 1 | 7µs |  |  | 1;
756 |  |  |  |  |
757 |  |  |  |  | __END__