Filename | /usr/share/perl5/vendor_perl/Carp.pm |
Statements | Executed 3470 statements in 9.87ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
84 | 3 | 1 | 1.77ms | 3.97ms | caller_info | Carp::
104 | 1 | 1 | 1.47ms | 1.82ms | format_arg | Carp::
5 | 1 | 1 | 553µs | 4.45ms | ret_backtrace | Carp::
111 | 5 | 1 | 259µs | 259µs | _cgc | Carp::
79 | 1 | 1 | 175µs | 184µs | get_subname | Carp::
104 | 2 | 1 | 173µs | 173µs | str_len_trim | Carp::
5 | 1 | 1 | 81µs | 111µs | long_error_loc | Carp::
5 | 3 | 3 | 49µs | 4.70ms | confess | Carp::
1 | 1 | 1 | 46µs | 105µs | short_error_loc | Carp::
5 | 1 | 1 | 43µs | 4.65ms | longmess | Carp::
5 | 1 | 1 | 33µs | 4.59ms | longmess_heavy | Carp::
1 | 1 | 1 | 33µs | 60µs | BEGIN@398 | Carp::
1 | 1 | 1 | 32µs | 32µs | BEGIN@3 | Carp::
1 | 1 | 1 | 23µs | 35µs | BEGIN@5 | Carp::
4 | 2 | 1 | 21µs | 49µs | trusts | Carp::
1 | 1 | 1 | 21µs | 45µs | BEGIN@8 | Carp::
1 | 1 | 1 | 18µs | 229µs | shortmess | Carp::
1 | 1 | 1 | 18µs | 39µs | BEGIN@399 | Carp::
1 | 1 | 1 | 17µs | 34µs | BEGIN@406 | Carp::
4 | 1 | 1 | 17µs | 28µs | get_status | Carp::
1 | 1 | 1 | 17µs | 40µs | BEGIN@67 | Carp::
1 | 1 | 1 | 16µs | 47µs | BEGIN@4 | Carp::
1 | 1 | 1 | 16µs | 91µs | ret_summary | Carp::
1 | 1 | 1 | 16µs | 16µs | BEGIN@7 | Carp::
1 | 1 | 1 | 15µs | 1.28ms | croak | Carp::
1 | 1 | 1 | 15µs | 35µs | BEGIN@18 | Carp::
1 | 1 | 1 | 15µs | 35µs | BEGIN@413 | Carp::
1 | 1 | 1 | 14µs | 14µs | BEGIN@105 | Carp::
1 | 1 | 1 | 13µs | 13µs | BEGIN@17 | Carp::
1 | 1 | 1 | 11µs | 207µs | shortmess_heavy | Carp::
2 | 1 | 1 | 11µs | 11µs | trusts_directly | Carp::
0 | 0 | 0 | 0s | 0s | __ANON__[:13] | Carp::
0 | 0 | 0 | 0s | 0s | __ANON__[:23] | Carp::
0 | 0 | 0 | 0s | 0s | carp | Carp::
0 | 0 | 0 | 0s | 0s | cluck | Carp::
0 | 0 | 0 | 0s | 0s | export_fail | Carp::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Carp; | ||||
2 | |||||
3 | 3 | 100µs | 1 | 32µs | # spent 32µs within Carp::BEGIN@3 which was called:
# once (32µs+0s) by CGI::Carp::BEGIN@334 at line 3 # spent 32µs making 1 call to Carp::BEGIN@3 |
4 | 2 | 52µs | 2 | 78µs | # spent 47µs (16+31) within Carp::BEGIN@4 which was called:
# once (16µs+31µs) by CGI::Carp::BEGIN@334 at line 4 # spent 47µs making 1 call to Carp::BEGIN@4
# spent 31µs making 1 call to strict::import |
5 | 2 | 62µs | 2 | 47µs | # spent 35µs (23+12) within Carp::BEGIN@5 which was called:
# once (23µs+12µs) by CGI::Carp::BEGIN@334 at line 5 # spent 35µs making 1 call to Carp::BEGIN@5
# spent 12µs making 1 call to warnings::import |
6 | |||||
7 | # spent 16µs within Carp::BEGIN@7 which was called:
# once (16µs+0s) by CGI::Carp::BEGIN@334 at line 15 | ||||
8 | 2 | 172µs | 2 | 70µs | # spent 45µs (21+25) within Carp::BEGIN@8 which was called:
# once (21µs+25µs) by CGI::Carp::BEGIN@334 at line 8 # spent 45µs making 1 call to Carp::BEGIN@8
# spent 25µs making 1 call to strict::unimport |
9 | 1 | 16µs | if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"is_utf8"}) && | ||
10 | defined(*{*{$::{"utf8::"}}{HASH}->{"is_utf8"}}{CODE})) { | ||||
11 | *is_utf8 = \&{"utf8::is_utf8"}; | ||||
12 | } else { | ||||
13 | *is_utf8 = sub { 0 }; | ||||
14 | } | ||||
15 | 1 | 56µs | 1 | 16µs | } # spent 16µs making 1 call to Carp::BEGIN@7 |
16 | |||||
17 | # spent 13µs within Carp::BEGIN@17 which was called:
# once (13µs+0s) by CGI::Carp::BEGIN@334 at line 25 | ||||
18 | 2 | 169µs | 2 | 56µs | # spent 35µs (15+21) within Carp::BEGIN@18 which was called:
# once (15µs+21µs) by CGI::Carp::BEGIN@334 at line 18 # spent 35µs making 1 call to Carp::BEGIN@18
# spent 21µs making 1 call to strict::unimport |
19 | 1 | 17µs | if(exists($::{"utf8::"}) && exists(*{$::{"utf8::"}}{HASH}->{"downgrade"}) && | ||
20 | defined(*{*{$::{"utf8::"}}{HASH}->{"downgrade"}}{CODE})) { | ||||
21 | *downgrade = \&{"utf8::downgrade"}; | ||||
22 | } else { | ||||
23 | *downgrade = sub {}; | ||||
24 | } | ||||
25 | 1 | 360µs | 1 | 13µs | } # spent 13µs making 1 call to Carp::BEGIN@17 |
26 | |||||
27 | 1 | 1µs | our $VERSION = '1.26'; | ||
28 | |||||
29 | 1 | 300ns | our $MaxEvalLen = 0; | ||
30 | 1 | 200ns | our $Verbose = 0; | ||
31 | 1 | 200ns | our $CarpLevel = 0; | ||
32 | 1 | 300ns | our $MaxArgLen = 64; # How much of each argument to print. 0 = all. | ||
33 | 1 | 200ns | our $MaxArgNums = 8; # How many arguments to print. 0 = all. | ||
34 | |||||
35 | 1 | 800ns | require Exporter; | ||
36 | 1 | 13µs | our @ISA = ('Exporter'); | ||
37 | 1 | 2µs | our @EXPORT = qw(confess croak carp); | ||
38 | 1 | 1µs | our @EXPORT_OK = qw(cluck verbose longmess shortmess); | ||
39 | 1 | 1µs | our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode | ||
40 | |||||
41 | # The members of %Internal are packages that are internal to perl. | ||||
42 | # Carp will not report errors from within these packages if it | ||||
43 | # can. The members of %CarpInternal are internal to Perl's warning | ||||
44 | # system. Carp will not report errors from within these packages | ||||
45 | # either, and will not report calls *to* these packages for carp and | ||||
46 | # croak. They replace $CarpLevel, which is deprecated. The | ||||
47 | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval | ||||
48 | # text and function arguments should be formatted when printed. | ||||
49 | |||||
50 | 1 | 300ns | our %CarpInternal; | ||
51 | 1 | 100ns | our %Internal; | ||
52 | |||||
53 | # disable these by default, so they can live w/o require Carp | ||||
54 | 1 | 3µs | $CarpInternal{Carp}++; | ||
55 | 1 | 700ns | $CarpInternal{warnings}++; | ||
56 | 1 | 800ns | $Internal{Exporter}++; | ||
57 | 1 | 400ns | $Internal{'Exporter::Heavy'}++; | ||
58 | |||||
59 | # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") | ||||
60 | # then the following method will be called by the Exporter which knows | ||||
61 | # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word | ||||
62 | # 'verbose'. | ||||
63 | |||||
64 | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } | ||||
65 | |||||
66 | # spent 259µs within Carp::_cgc which was called 111 times, avg 2µs/call:
# 84 times (198µs+0s) by Carp::caller_info at line 117, avg 2µs/call
# 16 times (30µs+0s) by Carp::long_error_loc at line 245, avg 2µs/call
# 5 times (17µs+0s) by Carp::longmess at line 79, avg 3µs/call
# 5 times (10µs+0s) by Carp::short_error_loc at line 332, avg 2µs/call
# once (4µs+0s) by Carp::shortmess at line 93 | ||||
67 | 2 | 621µs | 2 | 64µs | # spent 40µs (17+24) within Carp::BEGIN@67 which was called:
# once (17µs+24µs) by CGI::Carp::BEGIN@334 at line 67 # spent 40µs making 1 call to Carp::BEGIN@67
# spent 24µs making 1 call to strict::unimport |
68 | 111 | 194µs | return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"}; | ||
69 | 111 | 188µs | return; | ||
70 | } | ||||
71 | |||||
72 | # spent 4.65ms (43µs+4.61) within Carp::longmess which was called 5 times, avg 931µs/call:
# 5 times (43µs+4.61ms) by Carp::confess at line 101, avg 931µs/call | ||||
73 | # Icky backwards compatibility wrapper. :-( | ||||
74 | # | ||||
75 | # The story is that the original implementation hard-coded the | ||||
76 | # number of call levels to go back, so calls to longmess were off | ||||
77 | # by one. Other code began calling longmess and expecting this | ||||
78 | # behaviour, so the replacement has to emulate that behaviour. | ||||
79 | 5 | 5µs | 5 | 17µs | my $cgc = _cgc(); # spent 17µs making 5 calls to Carp::_cgc, avg 3µs/call |
80 | 5 | 9µs | my $call_pack = $cgc ? $cgc->() : caller(); | ||
81 | 5 | 21µs | 5 | 4.59ms | if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) { # spent 4.59ms making 5 calls to Carp::longmess_heavy, avg 919µs/call |
82 | return longmess_heavy(@_); | ||||
83 | } | ||||
84 | else { | ||||
85 | local $CarpLevel = $CarpLevel + 1; | ||||
86 | return longmess_heavy(@_); | ||||
87 | } | ||||
88 | } | ||||
89 | |||||
90 | 1 | 200ns | our @CARP_NOT; | ||
91 | |||||
92 | # spent 229µs (18+211) within Carp::shortmess which was called:
# once (18µs+211µs) by Carp::croak at line 100 | ||||
93 | 1 | 1µs | 1 | 4µs | my $cgc = _cgc(); # spent 4µs making 1 call to Carp::_cgc |
94 | |||||
95 | # Icky backwards compatibility wrapper. :-( | ||||
96 | 1 | 6µs | local @CARP_NOT = $cgc ? $cgc->() : caller(); | ||
97 | 1 | 5µs | 1 | 207µs | shortmess_heavy(@_); # spent 207µs making 1 call to Carp::shortmess_heavy |
98 | } | ||||
99 | |||||
100 | 1 | 8µs | 2 | 1.27ms | # spent 1.28ms (15µs+1.27) within Carp::croak which was called:
# once (15µs+1.27ms) by CGI::_compile at line 882 of CGI.pm # spent 1.04ms making 1 call to Carp::confess
# spent 229µs making 1 call to Carp::shortmess |
101 | 5 | 136µs | 5 | 4.65ms | # spent 4.70ms (49µs+4.65) within Carp::confess which was called 5 times, avg 941µs/call:
# 2 times (26µs+1.94ms) by Foswiki::Plugin::BEGIN@2.9 or Foswiki::Plugins::ConvertAttachmentPlugin::BEGIN@26 at line 26 of /var/www/foswiki11/lib/Foswiki/Plugins/ConvertAttachmentPlugin.pm, avg 985µs/call
# 2 times (16µs+1.68ms) by Foswiki::Plugin::BEGIN@2.9 or Foswiki::Plugin::load at line 2 of (eval 78)[/var/www/foswiki11/lib/Foswiki/Plugin.pm:121], avg 848µs/call
# once (6µs+1.03ms) by Carp::croak at line 100 # spent 4.65ms making 5 calls to Carp::longmess, avg 931µs/call |
102 | sub carp { warn shortmess @_ } | ||||
103 | sub cluck { warn longmess @_ } | ||||
104 | |||||
105 | # spent 14µs within Carp::BEGIN@105 which was called:
# once (14µs+0s) by CGI::Carp::BEGIN@334 at line 112 | ||||
106 | 1 | 15µs | if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) || | ||
107 | ("$]" >= 5.012005 && "$]" < 5.013)) { | ||||
108 | *CALLER_OVERRIDE_CHECK_OK = sub () { 1 }; | ||||
109 | } else { | ||||
110 | *CALLER_OVERRIDE_CHECK_OK = sub () { 0 }; | ||||
111 | } | ||||
112 | 1 | 2.85ms | 1 | 14µs | } # spent 14µs making 1 call to Carp::BEGIN@105 |
113 | |||||
114 | # spent 3.97ms (1.77+2.20) within Carp::caller_info which was called 84 times, avg 47µs/call:
# 78 times (1.59ms+1.89ms) by Carp::ret_backtrace at line 302, avg 45µs/call
# 5 times (150µs+266µs) by Carp::ret_backtrace at line 288, avg 83µs/call
# once (35µs+40µs) by Carp::ret_summary at line 320 | ||||
115 | 84 | 40µs | my $i = shift(@_) + 1; | ||
116 | 84 | 9µs | my %call_info; | ||
117 | 84 | 62µs | 84 | 198µs | my $cgc = _cgc(); # spent 198µs making 84 calls to Carp::_cgc, avg 2µs/call |
118 | { | ||||
119 | # Some things override caller() but forget to implement the | ||||
120 | # @DB::args part of it, which we need. We check for this by | ||||
121 | # pre-populating @DB::args with a sentinel which no-one else | ||||
122 | # has the address of, so that we can detect whether @DB::args | ||||
123 | # has been properly populated. However, on earlier versions | ||||
124 | # of perl this check tickles a bug in CORE::caller() which | ||||
125 | # leaks memory. So we only check on fixed perls. | ||||
126 | 168 | 123µs | @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK; | ||
127 | package DB; | ||||
128 | |||||
129 | 84 | 492µs | |||
- - | |||||
133 | 84 | 33µs | unless ( defined $call_info{pack} ) { | ||
134 | return (); | ||||
135 | } | ||||
136 | |||||
137 | 79 | 96µs | 79 | 184µs | my $sub_name = Carp::get_subname( \%call_info ); # spent 184µs making 79 calls to Carp::get_subname, avg 2µs/call |
138 | 79 | 26µs | if ( $call_info{has_args} ) { | ||
139 | 58 | 7µs | my @args; | ||
140 | 58 | 42µs | if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1 | ||
141 | && ref $DB::args[0] eq ref \$i | ||||
142 | && $DB::args[0] == \$i ) { | ||||
143 | @DB::args = (); # Don't let anyone see the address of $i | ||||
144 | local $@; | ||||
145 | my $where = eval { | ||||
146 | my $func = $cgc or return ''; | ||||
147 | my $gv = | ||||
148 | *{ | ||||
149 | ( $::{"B::"} || return '') # B stash | ||||
150 | ->{svref_2object} || return '' # entry in stash | ||||
151 | }{CODE} # coderef in entry | ||||
152 | ->($func)->GV; | ||||
153 | my $package = $gv->STASH->NAME; | ||||
154 | my $subname = $gv->NAME; | ||||
155 | return unless defined $package && defined $subname; | ||||
156 | |||||
157 | # returning CORE::GLOBAL::caller isn't useful for tracing the cause: | ||||
158 | return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; | ||||
159 | " in &${package}::$subname"; | ||||
160 | } || ''; | ||||
161 | @args | ||||
162 | = "** Incomplete caller override detected$where; \@DB::args were not set **"; | ||||
163 | } | ||||
164 | else { | ||||
165 | 162 | 208µs | 104 | 1.82ms | @args = map { Carp::format_arg($_) } @DB::args; # spent 1.82ms making 104 calls to Carp::format_arg, avg 17µs/call |
166 | } | ||||
167 | 58 | 22µs | if ( $MaxArgNums and @args > $MaxArgNums ) | ||
168 | { # More than we want to show? | ||||
169 | $#args = $MaxArgNums; | ||||
170 | push @args, '...'; | ||||
171 | } | ||||
172 | |||||
173 | # Push the args onto the subroutine | ||||
174 | 58 | 64µs | $sub_name .= '(' . join( ', ', @args ) . ')'; | ||
175 | } | ||||
176 | 79 | 44µs | $call_info{sub_name} = $sub_name; | ||
177 | 79 | 348µs | return wantarray() ? %call_info : \%call_info; | ||
178 | } | ||||
179 | |||||
180 | # Transform an argument to a function into a string. | ||||
181 | # spent 1.82ms (1.47+345µs) within Carp::format_arg which was called 104 times, avg 17µs/call:
# 104 times (1.47ms+345µs) by Carp::caller_info at line 165, avg 17µs/call | ||||
182 | 104 | 44µs | my $arg = shift; | ||
183 | 104 | 81µs | 55 | 70µs | if ( ref($arg) ) { # spent 70µs making 55 calls to overload::AddrRef, avg 1µs/call |
184 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; | ||||
185 | } | ||||
186 | 104 | 28µs | if ( defined($arg) ) { | ||
187 | 99 | 131µs | $arg =~ s/'/\\'/g; | ||
188 | 99 | 96µs | 99 | 164µs | $arg = str_len_trim( $arg, $MaxArgLen ); # spent 164µs making 99 calls to Carp::str_len_trim, avg 2µs/call |
189 | |||||
190 | # Quote it? | ||||
191 | # Downgrade, and use [0-9] rather than \d, to avoid loading | ||||
192 | # Unicode tables, which would be liable to fail if we're | ||||
193 | # processing a syntax error. | ||||
194 | 99 | 199µs | 99 | 56µs | downgrade($arg, 1); # spent 56µs making 99 calls to utf8::downgrade, avg 569ns/call |
195 | 99 | 185µs | $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/; | ||
196 | } | ||||
197 | else { | ||||
198 | 5 | 2µs | $arg = 'undef'; | ||
199 | } | ||||
200 | |||||
201 | # The following handling of "control chars" is direct from | ||||
202 | # the original code - it is broken on Unicode though. | ||||
203 | # Suggestions? | ||||
204 | is_utf8($arg) | ||||
205 | 104 | 568µs | 104 | 55µs | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; # spent 55µs making 104 calls to utf8::is_utf8, avg 529ns/call |
206 | 104 | 190µs | return $arg; | ||
207 | } | ||||
208 | |||||
209 | # Takes an inheritance cache and a package and returns | ||||
210 | # an anon hash of known inheritances and anon array of | ||||
211 | # inheritances which consequences have not been figured | ||||
212 | # for. | ||||
213 | # spent 28µs (17+11) within Carp::get_status which was called 4 times, avg 7µs/call:
# 4 times (17µs+11µs) by Carp::trusts at line 380, avg 7µs/call | ||||
214 | 4 | 700ns | my $cache = shift; | ||
215 | 4 | 700ns | my $pkg = shift; | ||
216 | 4 | 6µs | 2 | 11µs | $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ]; # spent 11µs making 2 calls to Carp::trusts_directly, avg 6µs/call |
217 | 4 | 11µs | return @{ $cache->{$pkg} }; | ||
218 | } | ||||
219 | |||||
220 | # Takes the info from caller() and figures out the name of | ||||
221 | # the sub/require/eval | ||||
222 | # spent 184µs (175+9) within Carp::get_subname which was called 79 times, avg 2µs/call:
# 79 times (175µs+9µs) by Carp::caller_info at line 137, avg 2µs/call | ||||
223 | 79 | 17µs | my $info = shift; | ||
224 | 79 | 24µs | if ( defined( $info->{evaltext} ) ) { | ||
225 | 8 | 3µs | my $eval = $info->{evaltext}; | ||
226 | 8 | 10µs | if ( $info->{is_require} ) { | ||
227 | return "require $eval"; | ||||
228 | } | ||||
229 | else { | ||||
230 | 5 | 4µs | $eval =~ s/([\\\'])/\\$1/g; | ||
231 | 5 | 16µs | 5 | 9µs | return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'"; # spent 9µs making 5 calls to Carp::str_len_trim, avg 2µs/call |
232 | } | ||||
233 | } | ||||
234 | |||||
235 | 71 | 164µs | return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; | ||
236 | } | ||||
237 | |||||
238 | # Figures out what call (from the point of view of the caller) | ||||
239 | # the long error backtrace should start at. | ||||
240 | # spent 111µs (81+30) within Carp::long_error_loc which was called 5 times, avg 22µs/call:
# 5 times (81µs+30µs) by Carp::longmess_heavy at line 270, avg 22µs/call | ||||
241 | 5 | 1µs | my $i; | ||
242 | 5 | 2µs | my $lvl = $CarpLevel; | ||
243 | { | ||||
244 | 21 | 4µs | ++$i; | ||
245 | 16 | 13µs | 16 | 30µs | my $cgc = _cgc(); # spent 30µs making 16 calls to Carp::_cgc, avg 2µs/call |
246 | 16 | 22µs | my $pkg = $cgc ? $cgc->($i) : caller($i); | ||
247 | 16 | 2µs | unless ( defined($pkg) ) { | ||
248 | |||||
249 | # This *shouldn't* happen. | ||||
250 | if (%Internal) { | ||||
251 | local %Internal; | ||||
252 | $i = long_error_loc(); | ||||
253 | last; | ||||
254 | } | ||||
255 | else { | ||||
256 | |||||
257 | # OK, now I am irritated. | ||||
258 | return 2; | ||||
259 | } | ||||
260 | } | ||||
261 | 16 | 9µs | redo if $CarpInternal{$pkg}; | ||
262 | 5 | 2µs | redo unless 0 > --$lvl; | ||
263 | 5 | 3µs | redo if $Internal{$pkg}; | ||
264 | } | ||||
265 | 5 | 12µs | return $i - 1; | ||
266 | } | ||||
267 | |||||
268 | # spent 4.59ms (33µs+4.56) within Carp::longmess_heavy which was called 5 times, avg 919µs/call:
# 5 times (33µs+4.56ms) by Carp::longmess at line 81, avg 919µs/call | ||||
269 | 5 | 1µs | return @_ if ref( $_[0] ); # don't break references as exceptions | ||
270 | 5 | 8µs | 5 | 111µs | my $i = long_error_loc(); # spent 111µs making 5 calls to Carp::long_error_loc, avg 22µs/call |
271 | 5 | 17µs | 5 | 4.45ms | return ret_backtrace( $i, @_ ); # spent 4.45ms making 5 calls to Carp::ret_backtrace, avg 890µs/call |
272 | } | ||||
273 | |||||
274 | # Returns a full stack backtrace starting from where it is | ||||
275 | # told. | ||||
276 | # spent 4.45ms (553µs+3.90) within Carp::ret_backtrace which was called 5 times, avg 890µs/call:
# 5 times (553µs+3.90ms) by Carp::longmess_heavy at line 271, avg 890µs/call | ||||
277 | 5 | 9µs | my ( $i, @error ) = @_; | ||
278 | 5 | 900ns | my $mess; | ||
279 | 5 | 12µs | my $err = join '', @error; | ||
280 | 5 | 600ns | $i++; | ||
281 | |||||
282 | 5 | 1µs | my $tid_msg = ''; | ||
283 | 5 | 2µs | if ( defined &threads::tid ) { | ||
284 | my $tid = threads->tid; | ||||
285 | $tid_msg = " thread $tid" if $tid; | ||||
286 | } | ||||
287 | |||||
288 | 5 | 19µs | 5 | 416µs | my %i = caller_info($i); # spent 416µs making 5 calls to Carp::caller_info, avg 83µs/call |
289 | 5 | 20µs | $mess = "$err at $i{file} line $i{line}$tid_msg"; | ||
290 | 5 | 3µs | if( defined $. ) { | ||
291 | local $@ = ''; | ||||
292 | local $SIG{__DIE__}; | ||||
293 | eval { | ||||
294 | CORE::die; | ||||
295 | }; | ||||
296 | if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) { | ||||
297 | $mess .= $1; | ||||
298 | } | ||||
299 | } | ||||
300 | 5 | 1µs | $mess .= "\.\n"; | ||
301 | |||||
302 | 5 | 371µs | 78 | 3.48ms | while ( my %i = caller_info( ++$i ) ) { # spent 3.48ms making 78 calls to Carp::caller_info, avg 45µs/call |
303 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; | ||||
304 | } | ||||
305 | |||||
306 | 5 | 41µs | return $mess; | ||
307 | } | ||||
308 | |||||
309 | # spent 91µs (16+75) within Carp::ret_summary which was called:
# once (16µs+75µs) by Carp::shortmess_heavy at line 352 | ||||
310 | 1 | 1µs | my ( $i, @error ) = @_; | ||
311 | 1 | 2µs | my $err = join '', @error; | ||
312 | 1 | 200ns | $i++; | ||
313 | |||||
314 | 1 | 500ns | my $tid_msg = ''; | ||
315 | 1 | 400ns | if ( defined &threads::tid ) { | ||
316 | my $tid = threads->tid; | ||||
317 | $tid_msg = " thread $tid" if $tid; | ||||
318 | } | ||||
319 | |||||
320 | 1 | 5µs | 1 | 75µs | my %i = caller_info($i); # spent 75µs making 1 call to Carp::caller_info |
321 | 1 | 6µs | return "$err at $i{file} line $i{line}$tid_msg\.\n"; | ||
322 | } | ||||
323 | |||||
324 | # spent 105µs (46+60) within Carp::short_error_loc which was called:
# once (46µs+60µs) by Carp::shortmess_heavy at line 351 | ||||
325 | # You have to create your (hash)ref out here, rather than defaulting it | ||||
326 | # inside trusts *on a lexical*, as you want it to persist across calls. | ||||
327 | # (You can default it on $_[2], but that gets messy) | ||||
328 | 1 | 1µs | my $cache = {}; | ||
329 | 1 | 300ns | my $i = 1; | ||
330 | 1 | 300ns | my $lvl = $CarpLevel; | ||
331 | { | ||||
332 | 6 | 4µs | 5 | 10µs | my $cgc = _cgc(); # spent 10µs making 5 calls to Carp::_cgc, avg 2µs/call |
333 | 5 | 6µs | my $called = $cgc ? $cgc->($i) : caller($i); | ||
334 | 5 | 900ns | $i++; | ||
335 | 5 | 7µs | my $caller = $cgc ? $cgc->($i) : caller($i); | ||
336 | |||||
337 | 5 | 500ns | return 0 unless defined($caller); # What happened? | ||
338 | 5 | 1µs | redo if $Internal{$caller}; | ||
339 | 5 | 1µs | redo if $CarpInternal{$caller}; | ||
340 | 4 | 1µs | redo if $CarpInternal{$called}; | ||
341 | 3 | 5µs | 3 | 36µs | redo if trusts( $called, $caller, $cache ); # spent 36µs making 3 calls to Carp::trusts, avg 12µs/call |
342 | 1 | 900ns | 1 | 13µs | redo if trusts( $caller, $called, $cache ); # spent 13µs making 1 call to Carp::trusts |
343 | 1 | 900ns | redo unless 0 > --$lvl; | ||
344 | } | ||||
345 | 1 | 6µs | return $i - 1; | ||
346 | } | ||||
347 | |||||
348 | # spent 207µs (11+196) within Carp::shortmess_heavy which was called:
# once (11µs+196µs) by Carp::shortmess at line 97 | ||||
349 | 1 | 400ns | return longmess_heavy(@_) if $Verbose; | ||
350 | 1 | 400ns | return @_ if ref( $_[0] ); # don't break references as exceptions | ||
351 | 1 | 2µs | 1 | 105µs | my $i = short_error_loc(); # spent 105µs making 1 call to Carp::short_error_loc |
352 | 1 | 9µs | 1 | 91µs | if ($i) { # spent 91µs making 1 call to Carp::ret_summary |
353 | ret_summary( $i, @_ ); | ||||
354 | } | ||||
355 | else { | ||||
356 | longmess_heavy(@_); | ||||
357 | } | ||||
358 | } | ||||
359 | |||||
360 | # If a string is too long, trims it with ... | ||||
361 | sub str_len_trim { | ||||
362 | 104 | 24µs | my $str = shift; | ||
363 | 104 | 20µs | my $max = shift || 0; | ||
364 | 104 | 37µs | if ( 2 < $max and $max < length($str) ) { | ||
365 | substr( $str, $max - 3 ) = '...'; | ||||
366 | } | ||||
367 | 104 | 187µs | return $str; | ||
368 | } | ||||
369 | |||||
370 | # Takes two packages and an optional cache. Says whether the | ||||
371 | # first inherits from the second. | ||||
372 | # | ||||
373 | # Recursive versions of this have to work to avoid certain | ||||
374 | # possible endless loops, and when following long chains of | ||||
375 | # inheritance are less efficient. | ||||
376 | sub trusts { | ||||
377 | 4 | 1µs | my $child = shift; | ||
378 | 4 | 600ns | my $parent = shift; | ||
379 | 4 | 700ns | my $cache = shift; | ||
380 | 4 | 5µs | 4 | 28µs | my ( $known, $partial ) = get_status( $cache, $child ); # spent 28µs making 4 calls to Carp::get_status, avg 7µs/call |
381 | |||||
382 | # Figure out consequences until we have an answer | ||||
383 | 4 | 2µs | while ( @$partial and not exists $known->{$parent} ) { | ||
384 | my $anc = shift @$partial; | ||||
385 | next if exists $known->{$anc}; | ||||
386 | $known->{$anc}++; | ||||
387 | my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc ); | ||||
388 | my @found = keys %$anc_knows; | ||||
389 | @$known{@found} = (); | ||||
390 | push @$partial, @$anc_partial; | ||||
391 | } | ||||
392 | 4 | 12µs | return exists $known->{$parent}; | ||
393 | } | ||||
394 | |||||
395 | # Takes a package and gives a list of those trusted directly | ||||
396 | # spent 11µs within Carp::trusts_directly which was called 2 times, avg 6µs/call:
# 2 times (11µs+0s) by Carp::get_status at line 216, avg 6µs/call | ||||
397 | 2 | 700ns | my $class = shift; | ||
398 | 2 | 73µs | 2 | 86µs | # spent 60µs (33+27) within Carp::BEGIN@398 which was called:
# once (33µs+27µs) by CGI::Carp::BEGIN@334 at line 398 # spent 60µs making 1 call to Carp::BEGIN@398
# spent 27µs making 1 call to strict::unimport |
399 | 2 | 128µs | 2 | 61µs | # spent 39µs (18+21) within Carp::BEGIN@399 which was called:
# once (18µs+21µs) by CGI::Carp::BEGIN@334 at line 399 # spent 39µs making 1 call to Carp::BEGIN@399
# spent 21µs making 1 call to warnings::unimport |
400 | return @{"$class\::CARP_NOT"} | ||||
401 | ? @{"$class\::CARP_NOT"} | ||||
402 | 2 | 14µs | : @{"$class\::ISA"}; | ||
403 | } | ||||
404 | |||||
405 | 1 | 2µs | if(!defined($warnings::VERSION) || | ||
406 | 3 | 78µs | 2 | 51µs | # spent 34µs (17+17) within Carp::BEGIN@406 which was called:
# once (17µs+17µs) by CGI::Carp::BEGIN@334 at line 406 # spent 34µs making 1 call to Carp::BEGIN@406
# spent 17µs making 1 call to warnings::unimport |
407 | # Very old versions of warnings.pm import from Carp. This can go | ||||
408 | # wrong due to the circular dependency. If Carp is invoked before | ||||
409 | # warnings, then Carp starts by loading warnings, then warnings | ||||
410 | # tries to import from Carp, and gets nothing because Carp is in | ||||
411 | # the process of loading and hasn't defined its import method yet. | ||||
412 | # So we work around that by manually exporting to warnings here. | ||||
413 | 2 | 136µs | 2 | 55µs | # spent 35µs (15+20) within Carp::BEGIN@413 which was called:
# once (15µs+20µs) by CGI::Carp::BEGIN@334 at line 413 # spent 35µs making 1 call to Carp::BEGIN@413
# spent 20µs making 1 call to strict::unimport |
414 | *{"warnings::$_"} = \&$_ foreach @EXPORT; | ||||
415 | } | ||||
416 | |||||
417 | 1 | 22µs | 1; | ||
418 | |||||
419 | __END__ |