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