File | /usr/share/perl/5.10/Carp/Heavy.pm |
Statements Executed | 77 |
Total Time | 0.0019599 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
2 | 2 | 1 | 38µs | 104µs | trusts | Carp::
3 | 2 | 1 | 33µs | 66µs | get_status | Carp::
3 | 1 | 1 | 33µs | 33µs | trusts_directly | Carp::
0 | 0 | 0 | 0s | 0s | BEGIN | Carp::
0 | 0 | 0 | 0s | 0s | caller_info | Carp::
0 | 0 | 0 | 0s | 0s | format_arg | Carp::
0 | 0 | 0 | 0s | 0s | get_subname | Carp::
0 | 0 | 0 | 0s | 0s | long_error_loc | Carp::
0 | 0 | 0 | 0s | 0s | longmess_heavy | Carp::
0 | 0 | 0 | 0s | 0s | longmess_real | Carp::
0 | 0 | 0 | 0s | 0s | ret_backtrace | Carp::
0 | 0 | 0 | 0s | 0s | ret_summary | Carp::
0 | 0 | 0 | 0s | 0s | short_error_loc | Carp::
0 | 0 | 0 | 0s | 0s | shortmess_heavy | Carp::
0 | 0 | 0 | 0s | 0s | shortmess_real | Carp::
0 | 0 | 0 | 0s | 0s | str_len_trim | Carp::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | # Carp::Heavy uses some variables in common with Carp. | |||
2 | package Carp; | |||
3 | ||||
4 | # On one line so MakeMaker will see it. | |||
5 | 4 | 1.69ms | 422µs | use Carp; our $VERSION = $Carp::VERSION; # spent 48µs making 1 call to Exporter::import |
6 | # use strict; # not yet | |||
7 | ||||
8 | # 'use Carp' just installs some very lightweight stubs; the first time | |||
9 | # these are called, they require Carp::Heavy which installs the real | |||
10 | # routines. | |||
11 | ||||
12 | # The members of %Internal are packages that are internal to perl. | |||
13 | # Carp will not report errors from within these packages if it | |||
14 | # can. The members of %CarpInternal are internal to Perl's warning | |||
15 | # system. Carp will not report errors from within these packages | |||
16 | # either, and will not report calls *to* these packages for carp and | |||
17 | # croak. They replace $CarpLevel, which is deprecated. The | |||
18 | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval | |||
19 | # text and function arguments should be formatted when printed. | |||
20 | ||||
21 | # disable these by default, so they can live w/o require Carp | |||
22 | 1 | 2µs | 2µs | $CarpInternal{Carp}++; |
23 | 1 | 900ns | 900ns | $CarpInternal{warnings}++; |
24 | 1 | 900ns | 900ns | $Internal{Exporter}++; |
25 | 1 | 1µs | 1µs | $Internal{'Exporter::Heavy'}++; |
26 | ||||
27 | 1 | 500ns | 500ns | our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose); |
28 | ||||
29 | # XXX longmess_real and shortmess_real should really be merged into | |||
30 | # XXX {long|sort}mess_heavy at some point | |||
31 | ||||
32 | sub longmess_real { | |||
33 | # Icky backwards compatibility wrapper. :-( | |||
34 | # | |||
35 | # The story is that the original implementation hard-coded the | |||
36 | # number of call levels to go back, so calls to longmess were off | |||
37 | # by one. Other code began calling longmess and expecting this | |||
38 | # behaviour, so the replacement has to emulate that behaviour. | |||
39 | my $call_pack = caller(); | |||
40 | if ($Internal{$call_pack} or $CarpInternal{$call_pack}) { | |||
41 | return longmess_heavy(@_); | |||
42 | } | |||
43 | else { | |||
44 | local $CarpLevel = $CarpLevel + 1; | |||
45 | return longmess_heavy(@_); | |||
46 | } | |||
47 | }; | |||
48 | ||||
49 | sub shortmess_real { | |||
50 | # Icky backwards compatibility wrapper. :-( | |||
51 | local @CARP_NOT = caller(); | |||
52 | shortmess_heavy(@_); | |||
53 | }; | |||
54 | ||||
55 | # replace the two hooks added by Carp | |||
56 | ||||
57 | # aliasing the whole glob rather than just the CV slot avoids 'redefined' | |||
58 | # warnings, even in the presence of perl -W (as used by lib/warnings.t !) | |||
59 | # However it has the potential to create infinite loops, if somehow Carp | |||
60 | # is forcibly reloaded, but $INC{"Carp/Heavy.pm"} remains true. | |||
61 | # Hence the extra hack of deleting the previous typeglob first. | |||
62 | ||||
63 | 1 | 2µs | 2µs | delete $Carp::{shortmess_jmp}; |
64 | 1 | 600ns | 600ns | delete $Carp::{longmess_jmp}; |
65 | 1 | 8µs | 8µs | *longmess_jmp = *longmess_real; |
66 | 1 | 6µs | 6µs | *shortmess_jmp = *shortmess_real; |
67 | ||||
68 | sub caller_info { | |||
69 | my $i = shift(@_) + 1; | |||
70 | package DB; | |||
71 | my %call_info; | |||
72 | @call_info{ | |||
73 | qw(pack file line sub has_args wantarray evaltext is_require) | |||
74 | } = caller($i); | |||
75 | ||||
76 | unless (defined $call_info{pack}) { | |||
77 | return (); | |||
78 | } | |||
79 | ||||
80 | my $sub_name = Carp::get_subname(\%call_info); | |||
81 | if ($call_info{has_args}) { | |||
82 | my @args = map {Carp::format_arg($_)} @DB::args; | |||
83 | if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? | |||
84 | $#args = $MaxArgNums; | |||
85 | push @args, '...'; | |||
86 | } | |||
87 | # Push the args onto the subroutine | |||
88 | $sub_name .= '(' . join (', ', @args) . ')'; | |||
89 | } | |||
90 | $call_info{sub_name} = $sub_name; | |||
91 | return wantarray() ? %call_info : \%call_info; | |||
92 | } | |||
93 | ||||
94 | # Transform an argument to a function into a string. | |||
95 | sub format_arg { | |||
96 | my $arg = shift; | |||
97 | if (ref($arg)) { | |||
98 | $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg"; | |||
99 | } | |||
100 | if (defined($arg)) { | |||
101 | $arg =~ s/'/\\'/g; | |||
102 | $arg = str_len_trim($arg, $MaxArgLen); | |||
103 | ||||
104 | # Quote it? | |||
105 | $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; | |||
106 | } else { | |||
107 | $arg = 'undef'; | |||
108 | } | |||
109 | ||||
110 | # The following handling of "control chars" is direct from | |||
111 | # the original code - it is broken on Unicode though. | |||
112 | # Suggestions? | |||
113 | utf8::is_utf8($arg) | |||
114 | or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg; | |||
115 | return $arg; | |||
116 | } | |||
117 | ||||
118 | # Takes an inheritance cache and a package and returns | |||
119 | # an anon hash of known inheritances and anon array of | |||
120 | # inheritances which consequences have not been figured | |||
121 | # for. | |||
122 | sub get_status { | |||
123 | 12 | 26µs | 2µs | my $cache = shift; |
124 | my $pkg = shift; | |||
125 | $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; # spent 33µs making 3 calls to Carp::trusts_directly, avg 11µs/call | |||
126 | return @{$cache->{$pkg}}; | |||
127 | } | |||
128 | ||||
129 | # Takes the info from caller() and figures out the name of | |||
130 | # the sub/require/eval | |||
131 | sub get_subname { | |||
132 | my $info = shift; | |||
133 | if (defined($info->{evaltext})) { | |||
134 | my $eval = $info->{evaltext}; | |||
135 | if ($info->{is_require}) { | |||
136 | return "require $eval"; | |||
137 | } | |||
138 | else { | |||
139 | $eval =~ s/([\\\'])/\\$1/g; | |||
140 | return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'"; | |||
141 | } | |||
142 | } | |||
143 | ||||
144 | return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; | |||
145 | } | |||
146 | ||||
147 | # Figures out what call (from the point of view of the caller) | |||
148 | # the long error backtrace should start at. | |||
149 | sub long_error_loc { | |||
150 | my $i; | |||
151 | my $lvl = $CarpLevel; | |||
152 | { | |||
153 | my $pkg = caller(++$i); | |||
154 | unless(defined($pkg)) { | |||
155 | # This *shouldn't* happen. | |||
156 | if (%Internal) { | |||
157 | local %Internal; | |||
158 | $i = long_error_loc(); | |||
159 | last; | |||
160 | } | |||
161 | else { | |||
162 | # OK, now I am irritated. | |||
163 | return 2; | |||
164 | } | |||
165 | } | |||
166 | redo if $CarpInternal{$pkg}; | |||
167 | redo unless 0 > --$lvl; | |||
168 | redo if $Internal{$pkg}; | |||
169 | } | |||
170 | return $i - 1; | |||
171 | } | |||
172 | ||||
173 | sub longmess_heavy { | |||
174 | return @_ if ref($_[0]); # don't break references as exceptions | |||
175 | my $i = long_error_loc(); | |||
176 | return ret_backtrace($i, @_); | |||
177 | } | |||
178 | ||||
179 | # Returns a full stack backtrace starting from where it is | |||
180 | # told. | |||
181 | sub ret_backtrace { | |||
182 | my ($i, @error) = @_; | |||
183 | my $mess; | |||
184 | my $err = join '', @error; | |||
185 | $i++; | |||
186 | ||||
187 | my $tid_msg = ''; | |||
188 | if (defined &threads::tid) { | |||
189 | my $tid = threads->tid; | |||
190 | $tid_msg = " thread $tid" if $tid; | |||
191 | } | |||
192 | ||||
193 | my %i = caller_info($i); | |||
194 | $mess = "$err at $i{file} line $i{line}$tid_msg\n"; | |||
195 | ||||
196 | while (my %i = caller_info(++$i)) { | |||
197 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; | |||
198 | } | |||
199 | ||||
200 | return $mess; | |||
201 | } | |||
202 | ||||
203 | sub ret_summary { | |||
204 | my ($i, @error) = @_; | |||
205 | my $err = join '', @error; | |||
206 | $i++; | |||
207 | ||||
208 | my $tid_msg = ''; | |||
209 | if (defined &threads::tid) { | |||
210 | my $tid = threads->tid; | |||
211 | $tid_msg = " thread $tid" if $tid; | |||
212 | } | |||
213 | ||||
214 | my %i = caller_info($i); | |||
215 | return "$err at $i{file} line $i{line}$tid_msg\n"; | |||
216 | } | |||
217 | ||||
218 | sub short_error_loc { | |||
219 | # You have to create your (hash)ref out here, rather than defaulting it | |||
220 | # inside trusts *on a lexical*, as you want it to persist across calls. | |||
221 | # (You can default it on $_[2], but that gets messy) | |||
222 | 5 | 9µs | 2µs | my $cache = {}; |
223 | my $i = 1; | |||
224 | my $lvl = $CarpLevel; | |||
225 | { | |||
226 | 15 | 27µs | 2µs | my $called = caller($i++); |
227 | my $caller = caller($i); | |||
228 | ||||
229 | return 0 unless defined($caller); # What happened? | |||
230 | redo if $Internal{$caller}; | |||
231 | redo if $CarpInternal{$caller}; | |||
232 | redo if $CarpInternal{$called}; | |||
233 | redo if trusts($called, $caller, $cache); # spent 43µs making 1 call to Carp::trusts | |||
234 | redo if trusts($caller, $called, $cache); # spent 62µs making 1 call to Carp::trusts | |||
235 | redo unless 0 > --$lvl; | |||
236 | } | |||
237 | return $i - 1; | |||
238 | } | |||
239 | ||||
240 | sub shortmess_heavy { | |||
241 | return longmess_heavy(@_) if $Verbose; | |||
242 | return @_ if ref($_[0]); # don't break references as exceptions | |||
243 | my $i = short_error_loc(); | |||
244 | if ($i) { | |||
245 | ret_summary($i, @_); | |||
246 | } | |||
247 | else { | |||
248 | longmess_heavy(@_); | |||
249 | } | |||
250 | } | |||
251 | ||||
252 | # If a string is too long, trims it with ... | |||
253 | sub str_len_trim { | |||
254 | my $str = shift; | |||
255 | my $max = shift || 0; | |||
256 | if (2 < $max and $max < length($str)) { | |||
257 | substr($str, $max - 3) = '...'; | |||
258 | } | |||
259 | return $str; | |||
260 | } | |||
261 | ||||
262 | # Takes two packages and an optional cache. Says whether the | |||
263 | # first inherits from the second. | |||
264 | # | |||
265 | # Recursive versions of this have to work to avoid certain | |||
266 | # possible endless loops, and when following long chains of | |||
267 | # inheritance are less efficient. | |||
268 | sub trusts { | |||
269 | 12 | 27µs | 2µs | my $child = shift; |
270 | my $parent = shift; | |||
271 | my $cache = shift; | |||
272 | my ($known, $partial) = get_status($cache, $child); # spent 47µs making 2 calls to Carp::get_status, avg 23µs/call | |||
273 | # Figure out consequences until we have an answer | |||
274 | while (@$partial and not exists $known->{$parent}) { | |||
275 | 7 | 14µs | 2µs | my $anc = shift @$partial; |
276 | next if exists $known->{$anc}; | |||
277 | $known->{$anc}++; | |||
278 | my ($anc_knows, $anc_partial) = get_status($cache, $anc); # spent 19µs making 1 call to Carp::get_status | |||
279 | my @found = keys %$anc_knows; | |||
280 | @$known{@found} = (); | |||
281 | push @$partial, @$anc_partial; | |||
282 | } | |||
283 | return exists $known->{$parent}; | |||
284 | } | |||
285 | ||||
286 | # Takes a package and gives a list of those trusted directly | |||
287 | # spent 33µs within Carp::trusts_directly which was called 3 times, avg 11µs/call:
# 3 times (33µs+0s) by Carp::get_status at line 125, avg 11µs/call | |||
288 | 6 | 26µs | 4µs | my $class = shift; |
289 | 3 | 35µs | 12µs | no strict 'refs'; # spent 27µs making 1 call to strict::unimport |
290 | 3 | 79µs | 26µs | no warnings 'once'; # spent 19µs making 1 call to warnings::unimport |
291 | return @{"$class\::CARP_NOT"} | |||
292 | ? @{"$class\::CARP_NOT"} | |||
293 | : @{"$class\::ISA"}; | |||
294 | } | |||
295 | ||||
296 | 1 | 8µs | 8µs | 1; |
297 |