| Filename | /home/leont/perl5/perlbrew/perls/perl-5.32.0/lib/5.32.0/Carp.pm |
| Statements | Executed 77 statements in 2.76ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 1 | 1 | 1 | 238µs | 262µs | Carp::BEGIN@169 |
| 1 | 1 | 1 | 30µs | 30µs | Carp::BEGIN@95 |
| 1 | 1 | 1 | 14µs | 22µs | Carp::BEGIN@6 |
| 1 | 1 | 1 | 14µs | 14µs | Carp::BEGIN@574 |
| 3 | 3 | 1 | 9µs | 9µs | Carp::_fetch_sub |
| 1 | 1 | 1 | 7µs | 7µs | Carp::BEGIN@3 |
| 1 | 1 | 1 | 6µs | 11µs | Carp::BEGIN@137 |
| 1 | 1 | 1 | 4µs | 10µs | Carp::BEGIN@730 |
| 1 | 1 | 1 | 4µs | 6µs | Carp::BEGIN@73 |
| 1 | 1 | 1 | 4µs | 9µs | Carp::BEGIN@256 |
| 1 | 1 | 1 | 4µs | 4µs | Carp::BEGIN@296 |
| 1 | 1 | 1 | 3µs | 8µs | Carp::BEGIN@188 |
| 1 | 1 | 1 | 3µs | 3µs | Carp::BEGIN@49 |
| 1 | 1 | 1 | 3µs | 7µs | Carp::BEGIN@61 |
| 1 | 1 | 1 | 3µs | 10µs | Carp::BEGIN@744 |
| 1 | 1 | 1 | 3µs | 3µs | Carp::_univ_mod_loaded |
| 1 | 1 | 1 | 2µs | 4µs | Carp::BEGIN@4 |
| 1 | 1 | 1 | 2µs | 6µs | Carp::BEGIN@751 |
| 1 | 1 | 1 | 2µs | 11µs | Carp::BEGIN@5 |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:103] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:115] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:139] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:185] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:189] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:191] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:193] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:209] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:408] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:419] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:66] |
| 0 | 0 | 0 | 0s | 0s | Carp::__ANON__[:86] |
| 0 | 0 | 0 | 0s | 0s | Carp::_cgc |
| 0 | 0 | 0 | 0s | 0s | Carp::caller_info |
| 0 | 0 | 0 | 0s | 0s | Carp::carp |
| 0 | 0 | 0 | 0s | 0s | Carp::cluck |
| 0 | 0 | 0 | 0s | 0s | Carp::confess |
| 0 | 0 | 0 | 0s | 0s | Carp::croak |
| 0 | 0 | 0 | 0s | 0s | Carp::export_fail |
| 0 | 0 | 0 | 0s | 0s | Carp::format_arg |
| 0 | 0 | 0 | 0s | 0s | Carp::get_status |
| 0 | 0 | 0 | 0s | 0s | Carp::get_subname |
| 0 | 0 | 0 | 0s | 0s | Carp::long_error_loc |
| 0 | 0 | 0 | 0s | 0s | Carp::longmess |
| 0 | 0 | 0 | 0s | 0s | Carp::longmess_heavy |
| 0 | 0 | 0 | 0s | 0s | Carp::ret_backtrace |
| 0 | 0 | 0 | 0s | 0s | Carp::ret_summary |
| 0 | 0 | 0 | 0s | 0s | Carp::short_error_loc |
| 0 | 0 | 0 | 0s | 0s | Carp::shortmess |
| 0 | 0 | 0 | 0s | 0s | Carp::shortmess_heavy |
| 0 | 0 | 0 | 0s | 0s | Carp::str_len_trim |
| 0 | 0 | 0 | 0s | 0s | Carp::trusts |
| 0 | 0 | 0 | 0s | 0s | Carp::trusts_directly |
| 0 | 0 | 0 | 0s | 0s | Regexp::CARP_TRACE |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Carp; | ||||
| 2 | |||||
| 3 | 2 | 22µs | 1 | 7µs | # spent 7µs within Carp::BEGIN@3 which was called:
# once (7µs+0s) by experimental::BEGIN@8 at line 3 # spent 7µs making 1 call to Carp::BEGIN@3 |
| 4 | 3 | 10µs | 2 | 5µs | # spent 4µs (2+1) within Carp::BEGIN@4 which was called:
# once (2µs+1µs) by experimental::BEGIN@8 at line 4 # spent 4µs making 1 call to Carp::BEGIN@4
# spent 1µs making 1 call to strict::import |
| 5 | 2 | 31µs | 2 | 20µs | # spent 11µs (2+9) within Carp::BEGIN@5 which was called:
# once (2µs+9µs) by experimental::BEGIN@8 at line 5 # spent 11µs making 1 call to Carp::BEGIN@5
# spent 9µs making 1 call to warnings::import |
| 6 | # spent 22µs (14+7) within Carp::BEGIN@6 which was called:
# once (14µs+7µs) by experimental::BEGIN@8 at line 26 | ||||
| 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 | 12µs | if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) { # spent 1µs executing statements in string eval | ||
| 22 | ${^WARNING_BITS} = ""; | ||||
| 23 | } else { | ||||
| 24 | 1 | 900ns | 1 | 7µs | "warnings"->unimport("utf8"); # spent 7µs making 1 call to warnings::unimport |
| 25 | } | ||||
| 26 | 1 | 87µs | 1 | 22µs | } # spent 22µs making 1 call to Carp::BEGIN@6 |
| 27 | |||||
| 28 | sub _fetch_sub { # fetch sub without autovivifying | ||||
| 29 | 3 | 1µs | my($pack, $sub) = @_; | ||
| 30 | 3 | 700ns | $pack .= '::'; | ||
| 31 | # only works with top-level packages | ||||
| 32 | 3 | 700ns | return unless exists($::{$pack}); | ||
| 33 | 3 | 800ns | for ($::{$pack}) { | ||
| 34 | 3 | 2µs | return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub}; | ||
| 35 | 3 | 400ns | for ($$_{$sub}) { | ||
| 36 | return ref \$_ eq 'GLOB' ? *$_{CODE} : undef | ||||
| 37 | 3 | 6µ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 3µs within Carp::BEGIN@49 which was called:
# once (3µs+0s) by experimental::BEGIN@8 at line 55 | ||||
| 50 | 1 | 3µs | if("$]" < 5.013011) { | ||
| 51 | *UTF8_REGEXP_PROBLEM = sub () { 1 }; | ||||
| 52 | } else { | ||||
| 53 | 1 | 500ns | *UTF8_REGEXP_PROBLEM = sub () { 0 }; | ||
| 54 | } | ||||
| 55 | 1 | 40µs | 1 | 3µs | } # spent 3µ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 7µs (3+4) within Carp::BEGIN@61 which was called:
# once (3µs+4µs) by experimental::BEGIN@8 at line 68 | ||||
| 62 | 1 | 2µs | 1 | 4µs | if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) { # spent 4µ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 | 62µs | 1 | 7µs | } # spent 7µ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 6µs (4+2) within Carp::BEGIN@73 which was called:
# once (4µs+2µs) by experimental::BEGIN@8 at line 88 | ||||
| 74 | 1 | 2µs | 1 | 2µs | if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) { # spent 2µ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 | 61µs | 1 | 6µs | } # spent 6µ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 30µs within Carp::BEGIN@95 which was called:
# once (30µs+0s) by experimental::BEGIN@8 at line 117 | ||||
| 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 | 28µs | ; # spent 3µs executing statements in string eval | ||
| 117 | 1 | 100µs | 1 | 30µs | } # spent 30µs making 1 call to Carp::BEGIN@95 |
| 118 | |||||
| 119 | # spent 3µs within Carp::_univ_mod_loaded which was called:
# once (3µs+0s) by Carp::BEGIN@137 at line 138 | ||||
| 120 | 1 | 300ns | return 0 unless exists($::{"UNIVERSAL::"}); | ||
| 121 | 1 | 300ns | for ($::{"UNIVERSAL::"}) { | ||
| 122 | 1 | 4µ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 11µs (6+5) within Carp::BEGIN@137 which was called:
# once (6µs+5µs) by experimental::BEGIN@8 at line 146 | ||||
| 138 | 1 | 2µs | 1 | 3µs | if (_univ_mod_loaded('isa')) { # spent 3µ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 | 2µs | *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa"); # spent 2µs making 1 call to Carp::_fetch_sub |
| 145 | } | ||||
| 146 | 1 | 70µs | 1 | 11µs | } # spent 11µ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 262µs (238+24) within Carp::BEGIN@169 which was called:
# once (238µs+24µs) by experimental::BEGIN@8 at line 211 | ||||
| 170 | 2 | 42µs | if (eval { require "overloading.pm" }) { | ||
| 171 | 1 | 19µs | *_StrVal = eval 'sub { no overloading; "$_[0]" }' # spent 18µ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 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; | ||||
| 188 | 2 | 98µs | 2 | 14µs | # spent 8µs (3+5) within Carp::BEGIN@188 which was called:
# once (3µs+5µs) by experimental::BEGIN@8 at line 188 # 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 | } | ||||
| 211 | 1 | 112µs | 1 | 262µs | } # spent 262µs making 1 call to Carp::BEGIN@169 |
| 212 | |||||
| 213 | |||||
| 214 | 1 | 300ns | our $VERSION = '1.50'; | ||
| 215 | 1 | 1µs | $VERSION =~ tr/_//d; | ||
| 216 | |||||
| 217 | 1 | 100ns | our $MaxEvalLen = 0; | ||
| 218 | 1 | 100ns | our $Verbose = 0; | ||
| 219 | 1 | 100ns | our $CarpLevel = 0; | ||
| 220 | 1 | 0s | 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 | 342µs | require Exporter; | ||
| 225 | 1 | 3µs | our @ISA = ('Exporter'); | ||
| 226 | 1 | 400ns | our @EXPORT = qw(confess croak carp); | ||
| 227 | 1 | 300ns | 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 | 100ns | $CarpInternal{warnings}++; | ||
| 245 | 1 | 100ns | $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 | 175µs | 2 | 14µs | # spent 9µs (4+5) within Carp::BEGIN@256 which was called:
# once (4µs+5µs) by experimental::BEGIN@8 at line 256 # spent 9µ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 = $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 4µs within Carp::BEGIN@296 which was called:
# once (4µs+0s) by experimental::BEGIN@8 at line 303 | ||||
| 297 | 1 | 5µ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 | 831µs | 1 | 4µs | } # spent 4µ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 14µs within Carp::BEGIN@574 which was called:
# once (14µs+0s) by experimental::BEGIN@8 at line 581 | ||||
| 575 | 1 | 5µs | if("$]" >= 5.017004) { | ||
| 576 | # The LAST_FH constant is a reference to the variable. | ||||
| 577 | 1 | 9µ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 | 432µs | 1 | 14µs | } # spent 14µ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 | 60µs | 2 | 16µs | # spent 10µs (4+6) within Carp::BEGIN@730 which was called:
# once (4µs+6µs) by experimental::BEGIN@8 at line 730 # spent 10µs making 1 call to Carp::BEGIN@730
# spent 6µ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 | 19µs | 2 | 16µs | # spent 10µs (3+7) within Carp::BEGIN@744 which was called:
# once (3µs+7µs) by experimental::BEGIN@8 at line 744 # spent 10µs making 1 call to Carp::BEGIN@744
# spent 6µ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 | 43µs | 2 | 10µs | # spent 6µs (2+4) within Carp::BEGIN@751 which was called:
# once (2µs+4µs) by experimental::BEGIN@8 at line 751 # spent 6µ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 | 6µs | 1; | ||
| 756 | |||||
| 757 | __END__ |