Profile of Carp.pm

← Index
NYTProf Performance Profile «line view»
For -e
Run on Thu Jun 30 16:16:00 2016
Reported on Thu Jun 30 16:16:08 2016

Filename | /home/s1/perl5/perlbrew/perls/perl-5.22.1/lib/site_perl/5.22.1/Carp.pm
Statements | Executed 56 statements in 5.59ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
1 | 1 | 1 | 42µs | 42µs | Carp::::BEGIN@3 Carp::BEGIN@3
1 | 1 | 1 | 38µs | 57µs | Carp::::BEGIN@6 Carp::BEGIN@6
2 | 2 | 1 | 23µs | 23µs | Carp::::_fetch_sub Carp::_fetch_sub
1 | 1 | 1 | 15µs | 28µs | Carp::::BEGIN@61 Carp::BEGIN@61
1 | 1 | 1 | 15µs | 28µs | Carp::::BEGIN@603 Carp::BEGIN@603
1 | 1 | 1 | 14µs | 19µs | Carp::::BEGIN@4 Carp::BEGIN@4
1 | 1 | 1 | 13µs | 31µs | Carp::::BEGIN@132 Carp::BEGIN@132
1 | 1 | 1 | 13µs | 31µs | Carp::::BEGIN@590 Carp::BEGIN@590
1 | 1 | 1 | 12µs | 22µs | Carp::::BEGIN@73 Carp::BEGIN@73
1 | 1 | 1 | 12µs | 21µs | Carp::::BEGIN@5 Carp::BEGIN@5
1 | 1 | 1 | 12µs | 27µs | Carp::::BEGIN@610 Carp::BEGIN@610
1 | 1 | 1 | 12µs | 12µs | Carp::::BEGIN@49 Carp::BEGIN@49
1 | 1 | 1 | 10µs | 10µs | Carp::::BEGIN@172 Carp::BEGIN@172
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:262] Carp::__ANON__[:262]
0 | 0 | 0 | 0s | 0s | Carp::::__ANON__[:273] Carp::__ANON__[:273]
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 | 86µs | 1 | 42µs | # spent 42µs within Carp::BEGIN@3 which was called: # once (42µs+0s) by experimental::BEGIN@8 at line 3 { use 5.006; } # spent 42µs making 1 call to Carp::BEGIN@3
4 | 3 | 41µs | 2 | 24µs | # spent 19µs (14+5) within Carp::BEGIN@4 which was called: # once (14µs+5µs) by experimental::BEGIN@8 at line 4 use strict; # spent 19µs making 1 call to Carp::BEGIN@4 # spent 5µs making 1 call to strict::import
5 | 2 | 99µs | 2 | 30µs | # spent 21µs (12+9) within Carp::BEGIN@5 which was called: # once (12µs+9µs) by experimental::BEGIN@8 at line 5 use warnings; # spent 21µs making 1 call to Carp::BEGIN@5 # spent 9µs making 1 call to warnings::import
6 |  |  |  |  | # spent 57µs (38+19) within Carp::BEGIN@6 which was called: # once (38µs+19µs) by experimental::BEGIN@8 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 | 24µs |  |  | if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) { # spent 4µs executing statements in string eval
22 |  |  |  |  | ${^WARNING_BITS} = "";
23 |  |  |  |  | } else {
24 | 1 | 3µs | 1 | 19µs | "warnings"->unimport("utf8"); # spent 19µs making 1 call to warnings::unimport
25 |  |  |  |  | }
26 | 1 | 272µs | 1 | 57µs | } # spent 57µs making 1 call to Carp::BEGIN@6
27 |  |  |  |  |
28 |  |  |  |  | # spent 23µs within Carp::_fetch_sub which was called 2 times, avg 11µs/call: # once (14µs+0s) by Carp::BEGIN@61 at line 62 # once (9µs+0s) by Carp::BEGIN@73 at line 74 sub _fetch_sub { # fetch sub without autovivifying
29 | 2 | 2µs |  |  | my($pack, $sub) = @_;
30 | 2 | 2µs |  |  | $pack .= '::';
31 |  |  |  |  | # only works with top-level packages
32 | 2 | 2µs |  |  | return unless exists($::{$pack});
33 | 2 | 3µs |  |  | for ($::{$pack}) {
34 | 2 | 5µs |  |  | return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
35 | 2 | 2µs |  |  | for ($$_{$sub}) {
36 |  |  |  |  | return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
37 | 2 | 16µ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 12µs within Carp::BEGIN@49 which was called: # once (12µs+0s) by experimental::BEGIN@8 at line 55 BEGIN {
50 | 1 | 10µs |  |  | if("$]" < 5.013011) {
51 |  |  |  |  | *UTF8_REGEXP_PROBLEM = sub () { 1 };
52 |  |  |  |  | } else {
53 | 1 | 2µs |  |  | *UTF8_REGEXP_PROBLEM = sub () { 0 };
54 |  |  |  |  | }
55 | 1 | 128µs | 1 | 12µs | } # spent 12µ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 28µs (15+14) within Carp::BEGIN@61 which was called: # once (15µs+14µs) by experimental::BEGIN@8 at line 68 BEGIN {
62 | 1 | 8µs | 1 | 14µs | if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) { # spent 14µ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 | 202µs | 1 | 28µs | } # spent 28µ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 22µs (12+9) within Carp::BEGIN@73 which was called: # once (12µs+9µs) by experimental::BEGIN@8 at line 88 BEGIN {
74 | 1 | 7µs | 1 | 9µs | if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) { # spent 9µ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 | 314µs | 1 | 22µs | } # spent 22µs making 1 call to Carp::BEGIN@73
89 |  |  |  |  |
90 | 1 | 700ns |  |  | our $VERSION = '1.38';
91 | 1 | 2µs |  |  | $VERSION =~ tr/_//d;
92 |  |  |  |  |
93 | 1 | 300ns |  |  | our $MaxEvalLen = 0;
94 | 1 | 100ns |  |  | our $Verbose = 0;
95 | 1 | 100ns |  |  | our $CarpLevel = 0;
96 | 1 | 200ns |  |  | our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
97 | 1 | 100ns |  |  | our $MaxArgNums = 8; # How many arguments to print. 0 = all.
98 | 1 | 300ns |  |  | our $RefArgFormatter = undef; # allow caller to format reference arguments
99 |  |  |  |  |
100 | 1 | 800ns |  |  | require Exporter;
101 | 1 | 8µs |  |  | our @ISA = ('Exporter');
102 | 1 | 1µs |  |  | our @EXPORT = qw(confess croak carp);
103 | 1 | 700ns |  |  | our @EXPORT_OK = qw(cluck verbose longmess shortmess);
104 | 1 | 300ns |  |  | our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
105 |  |  |  |  |
106 |  |  |  |  | # The members of %Internal are packages that are internal to perl.
107 |  |  |  |  | # Carp will not report errors from within these packages if it
108 |  |  |  |  | # can. The members of %CarpInternal are internal to Perl's warning
109 |  |  |  |  | # system. Carp will not report errors from within these packages
110 |  |  |  |  | # either, and will not report calls *to* these packages for carp and
111 |  |  |  |  | # croak. They replace $CarpLevel, which is deprecated. The
112 |  |  |  |  | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
113 |  |  |  |  | # text and function arguments should be formatted when printed.
114 |  |  |  |  |
115 |  |  |  |  | our %CarpInternal;
116 |  |  |  |  | our %Internal;
117 |  |  |  |  |
118 |  |  |  |  | # disable these by default, so they can live w/o require Carp
119 | 1 | 1µs |  |  | $CarpInternal{Carp}++;
120 | 1 | 300ns |  |  | $CarpInternal{warnings}++;
121 | 1 | 300ns |  |  | $Internal{Exporter}++;
122 | 1 | 300ns |  |  | $Internal{'Exporter::Heavy'}++;
123 |  |  |  |  |
124 |  |  |  |  | # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
125 |  |  |  |  | # then the following method will be called by the Exporter which knows
126 |  |  |  |  | # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
127 |  |  |  |  | # 'verbose'.
128 |  |  |  |  |
129 |  |  |  |  | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
130 |  |  |  |  |
131 |  |  |  |  | sub _cgc {
132 | 2 | 544µs | 2 | 49µs | # spent 31µs (13+18) within Carp::BEGIN@132 which was called: # once (13µs+18µs) by experimental::BEGIN@8 at line 132 no strict 'refs'; # spent 31µs making 1 call to Carp::BEGIN@132 # spent 18µs making 1 call to strict::unimport
133 |  |  |  |  | return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
134 |  |  |  |  | return;
135 |  |  |  |  | }
136 |  |  |  |  |
137 |  |  |  |  | sub longmess {
138 |  |  |  |  | local($!, $^E);
139 |  |  |  |  | # Icky backwards compatibility wrapper. :-(
140 |  |  |  |  | #
141 |  |  |  |  | # The story is that the original implementation hard-coded the
142 |  |  |  |  | # number of call levels to go back, so calls to longmess were off
143 |  |  |  |  | # by one. Other code began calling longmess and expecting this
144 |  |  |  |  | # behaviour, so the replacement has to emulate that behaviour.
145 |  |  |  |  | my $cgc = _cgc();
146 |  |  |  |  | my $call_pack = $cgc ? $cgc->() : caller();
147 |  |  |  |  | if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
148 |  |  |  |  | return longmess_heavy(@_);
149 |  |  |  |  | }
150 |  |  |  |  | else {
151 |  |  |  |  | local $CarpLevel = $CarpLevel + 1;
152 |  |  |  |  | return longmess_heavy(@_);
153 |  |  |  |  | }
154 |  |  |  |  | }
155 |  |  |  |  |
156 |  |  |  |  | our @CARP_NOT;
157 |  |  |  |  |
158 |  |  |  |  | sub shortmess {
159 |  |  |  |  | local($!, $^E);
160 |  |  |  |  | my $cgc = _cgc();
161 |  |  |  |  |
162 |  |  |  |  | # Icky backwards compatibility wrapper. :-(
163 |  |  |  |  | local @CARP_NOT = $cgc ? $cgc->() : caller();
164 |  |  |  |  | shortmess_heavy(@_);
165 |  |  |  |  | }
166 |  |  |  |  |
167 |  |  |  |  | sub croak { die shortmess @_ }
168 |  |  |  |  | sub confess { die longmess @_ }
169 |  |  |  |  | sub carp { warn shortmess @_ }
170 |  |  |  |  | sub cluck { warn longmess @_ }
171 |  |  |  |  |
172 |  |  |  |  | # spent 10µs within Carp::BEGIN@172 which was called: # once (10µs+0s) by experimental::BEGIN@8 at line 179 BEGIN {
173 | 1 | 11µs |  |  | if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
174 |  |  |  |  | ("$]" >= 5.012005 && "$]" < 5.013)) {
175 |  |  |  |  | *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
176 |  |  |  |  | } else {
177 |  |  |  |  | *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
178 |  |  |  |  | }
179 | 1 | 3.42ms | 1 | 10µs | } # spent 10µs making 1 call to Carp::BEGIN@172
180 |  |  |  |  |
181 |  |  |  |  | sub caller_info {
182 |  |  |  |  | my $i = shift(@_) + 1;
183 |  |  |  |  | my %call_info;
184 |  |  |  |  | my $cgc = _cgc();
185 |  |  |  |  | {
186 |  |  |  |  | # Some things override caller() but forget to implement the
187 |  |  |  |  | # @DB::args part of it, which we need. We check for this by
188 |  |  |  |  | # pre-populating @DB::args with a sentinel which no-one else
189 |  |  |  |  | # has the address of, so that we can detect whether @DB::args
190 |  |  |  |  | # has been properly populated. However, on earlier versions
191 |  |  |  |  | # of perl this check tickles a bug in CORE::caller() which
192 |  |  |  |  | # leaks memory. So we only check on fixed perls.
193 |  |  |  |  | @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
194 |  |  |  |  | package DB;
195 |  |  |  |  |
- - |  |  |  |  |
200 |  |  |  |  | unless ( defined $call_info{file} ) {
201 |  |  |  |  | return ();
202 |  |  |  |  | }
203 |  |  |  |  |
204 |  |  |  |  | my $sub_name = Carp::get_subname( \%call_info );
205 |  |  |  |  | if ( $call_info{has_args} ) {
206 |  |  |  |  | my @args;
207 |  |  |  |  | if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
208 |  |  |  |  | && ref $DB::args[0] eq ref \$i
209 |  |  |  |  | && $DB::args[0] == \$i ) {
210 |  |  |  |  | @DB::args = (); # Don't let anyone see the address of $i
211 |  |  |  |  | local $@;
212 |  |  |  |  | my $where = eval {
213 |  |  |  |  | my $func = $cgc or return '';
214 |  |  |  |  | my $gv =
215 |  |  |  |  | (_fetch_sub B => 'svref_2object' or return '')
216 |  |  |  |  | ->($func)->GV;
217 |  |  |  |  | my $package = $gv->STASH->NAME;
218 |  |  |  |  | my $subname = $gv->NAME;
219 |  |  |  |  | return unless defined $package && defined $subname;
220 |  |  |  |  |
221 |  |  |  |  | # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
222 |  |  |  |  | return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
223 |  |  |  |  | " in &${package}::$subname";
224 |  |  |  |  | } || '';
225 |  |  |  |  | @args
226 |  |  |  |  | = "** Incomplete caller override detected$where; \@DB::args were not set **";
227 |  |  |  |  | }
228 |  |  |  |  | else {
229 |  |  |  |  | @args = @DB::args;
230 |  |  |  |  | my $overflow;
231 |  |  |  |  | if ( $MaxArgNums and @args > $MaxArgNums )
232 |  |  |  |  | { # More than we want to show?
233 |  |  |  |  | $#args = $MaxArgNums - 1;
234 |  |  |  |  | $overflow = 1;
235 |  |  |  |  | }
236 |  |  |  |  |
237 |  |  |  |  | @args = map { Carp::format_arg($_) } @args;
238 |  |  |  |  |
239 |  |  |  |  | if ($overflow) {
240 |  |  |  |  | push @args, '...';
241 |  |  |  |  | }
242 |  |  |  |  | }
243 |  |  |  |  |
244 |  |  |  |  | # Push the args onto the subroutine
245 |  |  |  |  | $sub_name .= '(' . join( ', ', @args ) . ')';
246 |  |  |  |  | }
247 |  |  |  |  | $call_info{sub_name} = $sub_name;
248 |  |  |  |  | return wantarray() ? %call_info : \%call_info;
249 |  |  |  |  | }
250 |  |  |  |  |
251 |  |  |  |  | # Transform an argument to a function into a string.
252 |  |  |  |  | our $in_recurse;
253 |  |  |  |  | sub format_arg {
254 |  |  |  |  | my $arg = shift;
255 |  |  |  |  |
256 |  |  |  |  | if ( ref($arg) ) {
257 |  |  |  |  | # legitimate, let's not leak it.
258 |  |  |  |  | if (!$in_recurse &&
259 |  |  |  |  | do {
260 |  |  |  |  | local $@;
261 |  |  |  |  | local $in_recurse = 1;
262 |  |  |  |  | local $SIG{__DIE__} = sub{};
263 |  |  |  |  | eval {$arg->can('CARP_TRACE') }
264 |  |  |  |  | })
265 |  |  |  |  | {
266 |  |  |  |  | return $arg->CARP_TRACE();
267 |  |  |  |  | }
268 |  |  |  |  | elsif (!$in_recurse &&
269 |  |  |  |  | defined($RefArgFormatter) &&
270 |  |  |  |  | do {
271 |  |  |  |  | local $@;
272 |  |  |  |  | local $in_recurse = 1;
273 |  |  |  |  | local $SIG{__DIE__} = sub{};
274 |  |  |  |  | eval {$arg = $RefArgFormatter->($arg); 1}
275 |  |  |  |  | })
276 |  |  |  |  | {
277 |  |  |  |  | return $arg;
278 |  |  |  |  | }
279 |  |  |  |  | else
280 |  |  |  |  | {
281 |  |  |  |  | my $sub = _fetch_sub(overload => 'StrVal');
282 |  |  |  |  | return $sub ? &$sub($arg) : "$arg";
283 |  |  |  |  | }
284 |  |  |  |  | }
285 |  |  |  |  | return "undef" if !defined($arg);
286 |  |  |  |  | downgrade($arg, 1);
287 |  |  |  |  | return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
288 |  |  |  |  | $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
289 |  |  |  |  | my $suffix = "";
290 |  |  |  |  | if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
291 |  |  |  |  | substr ( $arg, $MaxArgLen - 3 ) = "";
292 |  |  |  |  | $suffix = "...";
293 |  |  |  |  | }
294 |  |  |  |  | if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
295 |  |  |  |  | for(my $i = length($arg); $i--; ) {
296 |  |  |  |  | my $c = substr($arg, $i, 1);
297 |  |  |  |  | my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
298 |  |  |  |  | if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
299 |  |  |  |  | substr $arg, $i, 0, "\\";
300 |  |  |  |  | next;
301 |  |  |  |  | }
302 |  |  |  |  | my $o = ord($c);
303 |  |  |  |  |
304 |  |  |  |  | # This code is repeated in Regexp::CARP_TRACE()
305 |  |  |  |  | if ($] ge 5.007_003) {
306 |  |  |  |  | substr $arg, $i, 1, sprintf("\\x{%x}", $o)
307 |  |  |  |  | if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
308 |  |  |  |  | || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
309 |  |  |  |  | } elsif (ord("A") == 65) {
310 |  |  |  |  | substr $arg, $i, 1, sprintf("\\x{%x}", $o)
311 |  |  |  |  | if $o < 0x20 || $o > 0x7e;
312 |  |  |  |  | } else { # Early EBCDIC
313 |  |  |  |  |
314 |  |  |  |  | # 3 EBCDIC code pages supported then; all controls but one
315 |  |  |  |  | # are the code points below SPACE. The other one is 0x5F on
316 |  |  |  |  | # POSIX-BC; FF on the other two.
317 |  |  |  |  | substr $arg, $i, 1, sprintf("\\x{%x}", $o)
318 |  |  |  |  | if $o < ord(" ") || ((ord ("^") == 106)
319 |  |  |  |  | ? $o == 0x5f
320 |  |  |  |  | : $o == 0xff);
321 |  |  |  |  | }
322 |  |  |  |  | }
323 |  |  |  |  | } else {
324 |  |  |  |  | $arg =~ s/([\"\\\$\@])/\\$1/g;
325 |  |  |  |  | # This is all the ASCII printables spelled-out. It is portable to all
326 |  |  |  |  | # Perl versions and platforms (such as EBCDIC). There are other more
327 |  |  |  |  | # compact ways to do this, but may not work everywhere every version.
328 |  |  |  |  | $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
329 |  |  |  |  | }
330 |  |  |  |  | downgrade($arg, 1);
331 |  |  |  |  | return "\"".$arg."\"".$suffix;
332 |  |  |  |  | }
333 |  |  |  |  |
334 |  |  |  |  | sub Regexp::CARP_TRACE {
335 |  |  |  |  | my $arg = "$_[0]";
336 |  |  |  |  | downgrade($arg, 1);
337 |  |  |  |  | if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
338 |  |  |  |  | for(my $i = length($arg); $i--; ) {
339 |  |  |  |  | my $o = ord(substr($arg, $i, 1));
340 |  |  |  |  | my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
341 |  |  |  |  |
342 |  |  |  |  | # This code is repeated in format_arg()
343 |  |  |  |  | if ($] ge 5.007_003) {
344 |  |  |  |  | substr $arg, $i, 1, sprintf("\\x{%x}", $o)
345 |  |  |  |  | if utf8::native_to_unicode($o) < utf8::native_to_unicode(0x20)
346 |  |  |  |  | || utf8::native_to_unicode($o) > utf8::native_to_unicode(0x7e);
347 |  |  |  |  | } elsif (ord("A") == 65) {
348 |  |  |  |  | substr $arg, $i, 1, sprintf("\\x{%x}", $o)
349 |  |  |  |  | if $o < 0x20 || $o > 0x7e;
350 |  |  |  |  | } else { # Early EBCDIC
351 |  |  |  |  | substr $arg, $i, 1, sprintf("\\x{%x}", $o)
352 |  |  |  |  | if $o < ord(" ") || ((ord ("^") == 106)
353 |  |  |  |  | ? $o == 0x5f
354 |  |  |  |  | : $o == 0xff);
355 |  |  |  |  | }
356 |  |  |  |  | }
357 |  |  |  |  | } else {
358 |  |  |  |  | # See comment in format_arg() about this same regex.
359 |  |  |  |  | $arg =~ s/([^ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
360 |  |  |  |  | }
361 |  |  |  |  | downgrade($arg, 1);
362 |  |  |  |  | my $suffix = "";
363 |  |  |  |  | if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
364 |  |  |  |  | ($suffix, $arg) = ($1, $2);
365 |  |  |  |  | }
366 |  |  |  |  | if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
367 |  |  |  |  | substr ( $arg, $MaxArgLen - 3 ) = "";
368 |  |  |  |  | $suffix = "...".$suffix;
369 |  |  |  |  | }
370 |  |  |  |  | return "qr($arg)$suffix";
371 |  |  |  |  | }
372 |  |  |  |  |
373 |  |  |  |  | # Takes an inheritance cache and a package and returns
374 |  |  |  |  | # an anon hash of known inheritances and anon array of
375 |  |  |  |  | # inheritances which consequences have not been figured
376 |  |  |  |  | # for.
377 |  |  |  |  | sub get_status {
378 |  |  |  |  | my $cache = shift;
379 |  |  |  |  | my $pkg = shift;
380 |  |  |  |  | $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
381 |  |  |  |  | return @{ $cache->{$pkg} };
382 |  |  |  |  | }
383 |  |  |  |  |
384 |  |  |  |  | # Takes the info from caller() and figures out the name of
385 |  |  |  |  | # the sub/require/eval
386 |  |  |  |  | sub get_subname {
387 |  |  |  |  | my $info = shift;
388 |  |  |  |  | if ( defined( $info->{evaltext} ) ) {
389 |  |  |  |  | my $eval = $info->{evaltext};
390 |  |  |  |  | if ( $info->{is_require} ) {
391 |  |  |  |  | return "require $eval";
392 |  |  |  |  | }
393 |  |  |  |  | else {
394 |  |  |  |  | $eval =~ s/([\\\'])/\\$1/g;
395 |  |  |  |  | return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
396 |  |  |  |  | }
397 |  |  |  |  | }
398 |  |  |  |  |
399 |  |  |  |  | # this can happen on older perls when the sub (or the stash containing it)
400 |  |  |  |  | # has been deleted
401 |  |  |  |  | if ( !defined( $info->{sub} ) ) {
402 |  |  |  |  | return '__ANON__::__ANON__';
403 |  |  |  |  | }
404 |  |  |  |  |
405 |  |  |  |  | return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
406 |  |  |  |  | }
407 |  |  |  |  |
408 |  |  |  |  | # Figures out what call (from the point of view of the caller)
409 |  |  |  |  | # the long error backtrace should start at.
410 |  |  |  |  | sub long_error_loc {
411 |  |  |  |  | my $i;
412 |  |  |  |  | my $lvl = $CarpLevel;
413 |  |  |  |  | {
414 |  |  |  |  | ++$i;
415 |  |  |  |  | my $cgc = _cgc();
416 |  |  |  |  | my @caller = $cgc ? $cgc->($i) : caller($i);
417 |  |  |  |  | my $pkg = $caller[0];
418 |  |  |  |  | unless ( defined($pkg) ) {
419 |  |  |  |  |
420 |  |  |  |  | # This *shouldn't* happen.
421 |  |  |  |  | if (%Internal) {
422 |  |  |  |  | local %Internal;
423 |  |  |  |  | $i = long_error_loc();
424 |  |  |  |  | last;
425 |  |  |  |  | }
426 |  |  |  |  | elsif (defined $caller[2]) {
427 |  |  |  |  | # this can happen when the stash has been deleted
428 |  |  |  |  | # in that case, just assume that it's a reasonable place to
429 |  |  |  |  | # stop (the file and line data will still be intact in any
430 |  |  |  |  | # case) - the only issue is that we can't detect if the
431 |  |  |  |  | # deleted package was internal (so don't do that then)
432 |  |  |  |  | # -doy
433 |  |  |  |  | redo unless 0 > --$lvl;
434 |  |  |  |  | last;
435 |  |  |  |  | }
436 |  |  |  |  | else {
437 |  |  |  |  | return 2;
438 |  |  |  |  | }
439 |  |  |  |  | }
440 |  |  |  |  | redo if $CarpInternal{$pkg};
441 |  |  |  |  | redo unless 0 > --$lvl;
442 |  |  |  |  | redo if $Internal{$pkg};
443 |  |  |  |  | }
444 |  |  |  |  | return $i - 1;
445 |  |  |  |  | }
446 |  |  |  |  |
447 |  |  |  |  | sub longmess_heavy {
448 |  |  |  |  | return @_ if ref( $_[0] ); # don't break references as exceptions
449 |  |  |  |  | my $i = long_error_loc();
450 |  |  |  |  | return ret_backtrace( $i, @_ );
451 |  |  |  |  | }
452 |  |  |  |  |
453 |  |  |  |  | # Returns a full stack backtrace starting from where it is
454 |  |  |  |  | # told.
455 |  |  |  |  | sub ret_backtrace {
456 |  |  |  |  | my ( $i, @error ) = @_;
457 |  |  |  |  | my $mess;
458 |  |  |  |  | my $err = join '', @error;
459 |  |  |  |  | $i++;
460 |  |  |  |  |
461 |  |  |  |  | my $tid_msg = '';
462 |  |  |  |  | if ( defined &threads::tid ) {
463 |  |  |  |  | my $tid = threads->tid;
464 |  |  |  |  | $tid_msg = " thread $tid" if $tid;
465 |  |  |  |  | }
466 |  |  |  |  |
467 |  |  |  |  | my %i = caller_info($i);
468 |  |  |  |  | $mess = "$err at $i{file} line $i{line}$tid_msg";
469 |  |  |  |  | if( defined $. ) {
470 |  |  |  |  | local $@ = '';
471 |  |  |  |  | local $SIG{__DIE__};
472 |  |  |  |  | eval {
473 |  |  |  |  | CORE::die;
474 |  |  |  |  | };
475 |  |  |  |  | if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
476 |  |  |  |  | $mess .= $1;
477 |  |  |  |  | }
478 |  |  |  |  | }
479 |  |  |  |  | $mess .= "\.\n";
480 |  |  |  |  |
481 |  |  |  |  | while ( my %i = caller_info( ++$i ) ) {
482 |  |  |  |  | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
483 |  |  |  |  | }
484 |  |  |  |  |
485 |  |  |  |  | return $mess;
486 |  |  |  |  | }
487 |  |  |  |  |
488 |  |  |  |  | sub ret_summary {
489 |  |  |  |  | my ( $i, @error ) = @_;
490 |  |  |  |  | my $err = join '', @error;
491 |  |  |  |  | $i++;
492 |  |  |  |  |
493 |  |  |  |  | my $tid_msg = '';
494 |  |  |  |  | if ( defined &threads::tid ) {
495 |  |  |  |  | my $tid = threads->tid;
496 |  |  |  |  | $tid_msg = " thread $tid" if $tid;
497 |  |  |  |  | }
498 |  |  |  |  |
499 |  |  |  |  | my %i = caller_info($i);
500 |  |  |  |  | return "$err at $i{file} line $i{line}$tid_msg\.\n";
501 |  |  |  |  | }
502 |  |  |  |  |
503 |  |  |  |  | sub short_error_loc {
504 |  |  |  |  | # You have to create your (hash)ref out here, rather than defaulting it
505 |  |  |  |  | # inside trusts *on a lexical*, as you want it to persist across calls.
506 |  |  |  |  | # (You can default it on $_[2], but that gets messy)
507 |  |  |  |  | my $cache = {};
508 |  |  |  |  | my $i = 1;
509 |  |  |  |  | my $lvl = $CarpLevel;
510 |  |  |  |  | {
511 |  |  |  |  | my $cgc = _cgc();
512 |  |  |  |  | my $called = $cgc ? $cgc->($i) : caller($i);
513 |  |  |  |  | $i++;
514 |  |  |  |  | my $caller = $cgc ? $cgc->($i) : caller($i);
515 |  |  |  |  |
516 |  |  |  |  | if (!defined($caller)) {
517 |  |  |  |  | my @caller = $cgc ? $cgc->($i) : caller($i);
518 |  |  |  |  | if (@caller) {
519 |  |  |  |  | # if there's no package but there is other caller info, then
520 |  |  |  |  | # the package has been deleted - treat this as a valid package
521 |  |  |  |  | # in this case
522 |  |  |  |  | redo if defined($called) && $CarpInternal{$called};
523 |  |  |  |  | redo unless 0 > --$lvl;
524 |  |  |  |  | last;
525 |  |  |  |  | }
526 |  |  |  |  | else {
527 |  |  |  |  | return 0;
528 |  |  |  |  | }
529 |  |  |  |  | }
530 |  |  |  |  | redo if $Internal{$caller};
531 |  |  |  |  | redo if $CarpInternal{$caller};
532 |  |  |  |  | redo if $CarpInternal{$called};
533 |  |  |  |  | redo if trusts( $called, $caller, $cache );
534 |  |  |  |  | redo if trusts( $caller, $called, $cache );
535 |  |  |  |  | redo unless 0 > --$lvl;
536 |  |  |  |  | }
537 |  |  |  |  | return $i - 1;
538 |  |  |  |  | }
539 |  |  |  |  |
540 |  |  |  |  | sub shortmess_heavy {
541 |  |  |  |  | return longmess_heavy(@_) if $Verbose;
542 |  |  |  |  | return @_ if ref( $_[0] ); # don't break references as exceptions
543 |  |  |  |  | my $i = short_error_loc();
544 |  |  |  |  | if ($i) {
545 |  |  |  |  | ret_summary( $i, @_ );
546 |  |  |  |  | }
547 |  |  |  |  | else {
548 |  |  |  |  | longmess_heavy(@_);
549 |  |  |  |  | }
550 |  |  |  |  | }
551 |  |  |  |  |
552 |  |  |  |  | # If a string is too long, trims it with ...
553 |  |  |  |  | sub str_len_trim {
554 |  |  |  |  | my $str = shift;
555 |  |  |  |  | my $max = shift || 0;
556 |  |  |  |  | if ( 2 < $max and $max < length($str) ) {
557 |  |  |  |  | substr( $str, $max - 3 ) = '...';
558 |  |  |  |  | }
559 |  |  |  |  | return $str;
560 |  |  |  |  | }
561 |  |  |  |  |
562 |  |  |  |  | # Takes two packages and an optional cache. Says whether the
563 |  |  |  |  | # first inherits from the second.
564 |  |  |  |  | #
565 |  |  |  |  | # Recursive versions of this have to work to avoid certain
566 |  |  |  |  | # possible endless loops, and when following long chains of
567 |  |  |  |  | # inheritance are less efficient.
568 |  |  |  |  | sub trusts {
569 |  |  |  |  | my $child = shift;
570 |  |  |  |  | my $parent = shift;
571 |  |  |  |  | my $cache = shift;
572 |  |  |  |  | my ( $known, $partial ) = get_status( $cache, $child );
573 |  |  |  |  |
574 |  |  |  |  | # Figure out consequences until we have an answer
575 |  |  |  |  | while ( @$partial and not exists $known->{$parent} ) {
576 |  |  |  |  | my $anc = shift @$partial;
577 |  |  |  |  | next if exists $known->{$anc};
578 |  |  |  |  | $known->{$anc}++;
579 |  |  |  |  | my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
580 |  |  |  |  | my @found = keys %$anc_knows;
581 |  |  |  |  | @$known{@found} = ();
582 |  |  |  |  | push @$partial, @$anc_partial;
583 |  |  |  |  | }
584 |  |  |  |  | return exists $known->{$parent};
585 |  |  |  |  | }
586 |  |  |  |  |
587 |  |  |  |  | # Takes a package and gives a list of those trusted directly
588 |  |  |  |  | sub trusts_directly {
589 |  |  |  |  | my $class = shift;
590 | 2 | 161µs | 2 | 48µs | # spent 31µs (13+18) within Carp::BEGIN@590 which was called: # once (13µs+18µs) by experimental::BEGIN@8 at line 590 no strict 'refs'; # spent 31µs making 1 call to Carp::BEGIN@590 # spent 18µs making 1 call to strict::unimport
591 |  |  |  |  | my $stash = \%{"$class\::"};
592 |  |  |  |  | for my $var (qw/ CARP_NOT ISA /) {
593 |  |  |  |  | # Don't try using the variable until we know it exists,
594 |  |  |  |  | # to avoid polluting the caller's namespace.
595 |  |  |  |  | if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
596 |  |  |  |  | return @{$stash->{$var}}
597 |  |  |  |  | }
598 |  |  |  |  | }
599 |  |  |  |  | return;
600 |  |  |  |  | }
601 |  |  |  |  |
602 | 1 | 900ns |  |  | if(!defined($warnings::VERSION) ||
603 | 3 | 79µs | 2 | 42µs | # spent 28µs (15+14) within Carp::BEGIN@603 which was called: # once (15µs+14µs) by experimental::BEGIN@8 at line 603 do { no warnings "numeric"; $warnings::VERSION < 1.03 }) { # spent 28µs making 1 call to Carp::BEGIN@603 # spent 14µs making 1 call to warnings::unimport
604 |  |  |  |  | # Very old versions of warnings.pm import from Carp. This can go
605 |  |  |  |  | # wrong due to the circular dependency. If Carp is invoked before
606 |  |  |  |  | # warnings, then Carp starts by loading warnings, then warnings
607 |  |  |  |  | # tries to import from Carp, and gets nothing because Carp is in
608 |  |  |  |  | # the process of loading and hasn't defined its import method yet.
609 |  |  |  |  | # So we work around that by manually exporting to warnings here.
610 | 2 | 117µs | 2 | 43µs | # spent 27µs (12+15) within Carp::BEGIN@610 which was called: # once (12µs+15µs) by experimental::BEGIN@8 at line 610 no strict "refs"; # spent 27µs making 1 call to Carp::BEGIN@610 # spent 15µs making 1 call to strict::unimport
611 |  |  |  |  | *{"warnings::$_"} = \&$_ foreach @EXPORT;
612 |  |  |  |  | }
613 |  |  |  |  |
614 | 1 | 14µs |  |  | 1;
615 |  |  |  |  |
616 |  |  |  |  | __END__