Commit | Line | Data |
---|---|---|
a0d0e21e | 1 | package Carp; |
8c3d9721 | 2 | |
634ff085 | 3 | { use 5.006; } |
01ca8b68 DR |
4 | use strict; |
5 | use warnings; | |
d5dcec3a Z |
6 | 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 | if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) { | |
22 | ${^WARNING_BITS} = ""; | |
23 | } else { | |
24 | "warnings"->unimport("utf8"); | |
25 | } | |
26 | } | |
01ca8b68 | 27 | |
f2ea7462 FC |
28 | sub _fetch_sub { # fetch sub without autovivifying |
29 | my($pack, $sub) = @_; | |
30 | $pack .= '::'; | |
31 | # only works with top-level packages | |
32 | return unless exists($::{$pack}); | |
33 | for ($::{$pack}) { | |
34 | return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub}; | |
35 | for ($$_{$sub}) { | |
36 | return ref \$_ eq 'GLOB' ? *$_{CODE} : undef | |
37 | } | |
38 | } | |
39 | } | |
40 | ||
6ffbec2c Z |
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 | BEGIN { | |
50 | if("$]" < 5.013011) { | |
51 | *UTF8_REGEXP_PROBLEM = sub () { 1 }; | |
52 | } else { | |
53 | *UTF8_REGEXP_PROBLEM = sub () { 0 }; | |
54 | } | |
55 | } | |
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. | |
40c2103f | 61 | BEGIN { |
f2ea7462 FC |
62 | if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) { |
63 | *is_utf8 = $sub; | |
40c2103f | 64 | } else { |
6ffbec2c Z |
65 | # black magic for perl 5.6 |
66 | *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 }; | |
40c2103f Z |
67 | } |
68 | } | |
69 | ||
6ffbec2c Z |
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. | |
40c2103f | 73 | BEGIN { |
f2ea7462 | 74 | if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) { |
40c2103f Z |
75 | *downgrade = \&{"utf8::downgrade"}; |
76 | } else { | |
6ffbec2c Z |
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 | }; | |
40c2103f Z |
87 | } |
88 | } | |
89 | ||
a18468ad | 90 | our $VERSION = '1.34'; |
b75c8c73 | 91 | |
8c3d9721 DM |
92 | our $MaxEvalLen = 0; |
93 | our $Verbose = 0; | |
94 | our $CarpLevel = 0; | |
d38ea511 DR |
95 | our $MaxArgLen = 64; # How much of each argument to print. 0 = all. |
96 | our $MaxArgNums = 8; # How many arguments to print. 0 = all. | |
b4bf645b | 97 | our $RefArgFormatter = undef; # allow caller to format reference arguments |
748a9306 | 98 | |
a0d0e21e | 99 | require Exporter; |
d38ea511 DR |
100 | our @ISA = ('Exporter'); |
101 | our @EXPORT = qw(confess croak carp); | |
8c3d9721 | 102 | our @EXPORT_OK = qw(cluck verbose longmess shortmess); |
d38ea511 | 103 | our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode |
af80c6a7 | 104 | |
ba7a4549 RGS |
105 | # The members of %Internal are packages that are internal to perl. |
106 | # Carp will not report errors from within these packages if it | |
107 | # can. The members of %CarpInternal are internal to Perl's warning | |
108 | # system. Carp will not report errors from within these packages | |
109 | # either, and will not report calls *to* these packages for carp and | |
110 | # croak. They replace $CarpLevel, which is deprecated. The | |
111 | # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval | |
112 | # text and function arguments should be formatted when printed. | |
113 | ||
01ca8b68 DR |
114 | our %CarpInternal; |
115 | our %Internal; | |
116 | ||
ba7a4549 RGS |
117 | # disable these by default, so they can live w/o require Carp |
118 | $CarpInternal{Carp}++; | |
119 | $CarpInternal{warnings}++; | |
120 | $Internal{Exporter}++; | |
121 | $Internal{'Exporter::Heavy'}++; | |
122 | ||
af80c6a7 JH |
123 | # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl") |
124 | # then the following method will be called by the Exporter which knows | |
125 | # to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word | |
126 | # 'verbose'. | |
127 | ||
29ddba3b | 128 | sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ } |
7b8d334a | 129 | |
01ca8b68 DR |
130 | sub _cgc { |
131 | no strict 'refs'; | |
132 | return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"}; | |
133 | return; | |
134 | } | |
135 | ||
ba7a4549 | 136 | sub longmess { |
cbd58baf | 137 | local($!, $^E); |
ba7a4549 RGS |
138 | # Icky backwards compatibility wrapper. :-( |
139 | # | |
140 | # The story is that the original implementation hard-coded the | |
141 | # number of call levels to go back, so calls to longmess were off | |
142 | # by one. Other code began calling longmess and expecting this | |
143 | # behaviour, so the replacement has to emulate that behaviour. | |
01ca8b68 DR |
144 | my $cgc = _cgc(); |
145 | my $call_pack = $cgc ? $cgc->() : caller(); | |
d38ea511 DR |
146 | if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) { |
147 | return longmess_heavy(@_); | |
ba7a4549 RGS |
148 | } |
149 | else { | |
d38ea511 DR |
150 | local $CarpLevel = $CarpLevel + 1; |
151 | return longmess_heavy(@_); | |
ba7a4549 | 152 | } |
d38ea511 | 153 | } |
ba7a4549 | 154 | |
01ca8b68 | 155 | our @CARP_NOT; |
d38ea511 | 156 | |
ba7a4549 | 157 | sub shortmess { |
cbd58baf | 158 | local($!, $^E); |
01ca8b68 | 159 | my $cgc = _cgc(); |
d38ea511 | 160 | |
ba7a4549 | 161 | # Icky backwards compatibility wrapper. :-( |
01ca8b68 | 162 | local @CARP_NOT = $cgc ? $cgc->() : caller(); |
ba7a4549 | 163 | shortmess_heavy(@_); |
d38ea511 | 164 | } |
7b8d334a | 165 | |
d38ea511 DR |
166 | sub croak { die shortmess @_ } |
167 | sub confess { die longmess @_ } | |
7b8d334a | 168 | sub carp { warn shortmess @_ } |
d38ea511 | 169 | sub cluck { warn longmess @_ } |
a0d0e21e | 170 | |
40c2103f Z |
171 | BEGIN { |
172 | if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) || | |
173 | ("$]" >= 5.012005 && "$]" < 5.013)) { | |
174 | *CALLER_OVERRIDE_CHECK_OK = sub () { 1 }; | |
175 | } else { | |
176 | *CALLER_OVERRIDE_CHECK_OK = sub () { 0 }; | |
177 | } | |
178 | } | |
179 | ||
ba7a4549 | 180 | sub caller_info { |
d38ea511 DR |
181 | my $i = shift(@_) + 1; |
182 | my %call_info; | |
183 | my $cgc = _cgc(); | |
184 | { | |
40c2103f Z |
185 | # Some things override caller() but forget to implement the |
186 | # @DB::args part of it, which we need. We check for this by | |
187 | # pre-populating @DB::args with a sentinel which no-one else | |
188 | # has the address of, so that we can detect whether @DB::args | |
189 | # has been properly populated. However, on earlier versions | |
190 | # of perl this check tickles a bug in CORE::caller() which | |
191 | # leaks memory. So we only check on fixed perls. | |
192 | @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK; | |
d38ea511 | 193 | package DB; |
d38ea511 DR |
194 | @call_info{ |
195 | qw(pack file line sub has_args wantarray evaltext is_require) } | |
196 | = $cgc ? $cgc->($i) : caller($i); | |
eff7e72c | 197 | } |
d38ea511 | 198 | |
5bbc4d5d | 199 | unless ( defined $call_info{file} ) { |
d38ea511 DR |
200 | return (); |
201 | } | |
202 | ||
203 | my $sub_name = Carp::get_subname( \%call_info ); | |
204 | if ( $call_info{has_args} ) { | |
205 | my @args; | |
40c2103f | 206 | if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1 |
d38ea511 DR |
207 | && ref $DB::args[0] eq ref \$i |
208 | && $DB::args[0] == \$i ) { | |
209 | @DB::args = (); # Don't let anyone see the address of $i | |
210 | local $@; | |
211 | my $where = eval { | |
212 | my $func = $cgc or return ''; | |
1a6d5308 | 213 | my $gv = |
f2ea7462 | 214 | (_fetch_sub B => 'svref_2object' or return '') |
1a6d5308 | 215 | ->($func)->GV; |
d38ea511 DR |
216 | my $package = $gv->STASH->NAME; |
217 | my $subname = $gv->NAME; | |
218 | return unless defined $package && defined $subname; | |
219 | ||
220 | # returning CORE::GLOBAL::caller isn't useful for tracing the cause: | |
221 | return if $package eq 'CORE::GLOBAL' && $subname eq 'caller'; | |
222 | " in &${package}::$subname"; | |
634ff085 | 223 | } || ''; |
d38ea511 DR |
224 | @args |
225 | = "** Incomplete caller override detected$where; \@DB::args were not set **"; | |
226 | } | |
227 | else { | |
e7eb9d6b JL |
228 | @args = @DB::args; |
229 | my $overflow; | |
230 | if ( $MaxArgNums and @args > $MaxArgNums ) | |
231 | { # More than we want to show? | |
232 | $#args = $MaxArgNums; | |
233 | $overflow = 1; | |
234 | } | |
235 | ||
236 | @args = map { Carp::format_arg($_) } @args; | |
237 | ||
238 | if ($overflow) { | |
239 | push @args, '...'; | |
240 | } | |
d38ea511 DR |
241 | } |
242 | ||
243 | # Push the args onto the subroutine | |
244 | $sub_name .= '(' . join( ', ', @args ) . ')'; | |
ba7a4549 | 245 | } |
d38ea511 DR |
246 | $call_info{sub_name} = $sub_name; |
247 | return wantarray() ? %call_info : \%call_info; | |
ba7a4549 RGS |
248 | } |
249 | ||
250 | # Transform an argument to a function into a string. | |
fdf5fcde | 251 | our $in_recurse; |
ba7a4549 | 252 | sub format_arg { |
d38ea511 | 253 | my $arg = shift; |
b4bf645b | 254 | |
d38ea511 | 255 | if ( ref($arg) ) { |
fdf5fcde TC |
256 | # legitimate, let's not leak it. |
257 | if (!$in_recurse && | |
258 | do { | |
259 | local $@; | |
260 | local $in_recurse = 1; | |
261 | local $SIG{__DIE__} = sub{}; | |
b4bf645b DM |
262 | eval {$arg->can('CARP_TRACE') } |
263 | }) | |
264 | { | |
6ffbec2c | 265 | return $arg->CARP_TRACE(); |
b4bf645b | 266 | } |
fdf5fcde | 267 | elsif (!$in_recurse && |
3bcf54a5 | 268 | defined($RefArgFormatter) && |
fdf5fcde | 269 | do { |
b4bf645b | 270 | local $@; |
fdf5fcde TC |
271 | local $in_recurse = 1; |
272 | local $SIG{__DIE__} = sub{}; | |
b4bf645b DM |
273 | eval {$arg = $RefArgFormatter->($arg); 1} |
274 | }) | |
275 | { | |
6ffbec2c | 276 | return $arg; |
b4bf645b | 277 | } |
b4bf645b DM |
278 | else |
279 | { | |
f2ea7462 | 280 | my $sub = _fetch_sub(overload => 'StrVal'); |
6ffbec2c | 281 | return $sub ? &$sub($arg) : "$arg"; |
b4bf645b | 282 | } |
d38ea511 | 283 | } |
6ffbec2c Z |
284 | return "undef" if !defined($arg); |
285 | downgrade($arg, 1); | |
286 | return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) && | |
287 | $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/; | |
288 | my $suffix = ""; | |
289 | if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) { | |
290 | substr ( $arg, $MaxArgLen - 3 ) = ""; | |
291 | $suffix = "..."; | |
634ff085 | 292 | } |
6ffbec2c | 293 | if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) { |
6ffbec2c Z |
294 | for(my $i = length($arg); $i--; ) { |
295 | my $c = substr($arg, $i, 1); | |
296 | my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2} | |
297 | if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") { | |
298 | substr $arg, $i, 0, "\\"; | |
299 | next; | |
300 | } | |
301 | my $o = ord($c); | |
6ffbec2c Z |
302 | substr $arg, $i, 1, sprintf("\\x{%x}", $o) |
303 | if $o < 0x20 || $o > 0x7f; | |
6ffbec2c Z |
304 | } |
305 | } else { | |
306 | $arg =~ s/([\"\\\$\@])/\\$1/g; | |
307 | $arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg; | |
d38ea511 | 308 | } |
6ffbec2c Z |
309 | downgrade($arg, 1); |
310 | return "\"".$arg."\"".$suffix; | |
ba7a4549 RGS |
311 | } |
312 | ||
e94bb470 Z |
313 | sub Regexp::CARP_TRACE { |
314 | my $arg = "$_[0]"; | |
315 | downgrade($arg, 1); | |
316 | if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) { | |
317 | for(my $i = length($arg); $i--; ) { | |
318 | my $o = ord(substr($arg, $i, 1)); | |
319 | my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2} | |
320 | substr $arg, $i, 1, sprintf("\\x{%x}", $o) | |
321 | if $o < 0x20 || $o > 0x7f; | |
322 | } | |
323 | } else { | |
324 | $arg =~ s/([^ -~])/sprintf("\\x{%x}",ord($1))/eg; | |
325 | } | |
326 | downgrade($arg, 1); | |
327 | my $suffix = ""; | |
328 | if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) { | |
329 | ($suffix, $arg) = ($1, $2); | |
330 | } | |
331 | if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) { | |
332 | substr ( $arg, $MaxArgLen - 3 ) = ""; | |
333 | $suffix = "...".$suffix; | |
334 | } | |
335 | return "qr($arg)$suffix"; | |
336 | } | |
337 | ||
ba7a4549 RGS |
338 | # Takes an inheritance cache and a package and returns |
339 | # an anon hash of known inheritances and anon array of | |
340 | # inheritances which consequences have not been figured | |
341 | # for. | |
342 | sub get_status { | |
343 | my $cache = shift; | |
d38ea511 DR |
344 | my $pkg = shift; |
345 | $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ]; | |
346 | return @{ $cache->{$pkg} }; | |
ba7a4549 RGS |
347 | } |
348 | ||
349 | # Takes the info from caller() and figures out the name of | |
350 | # the sub/require/eval | |
351 | sub get_subname { | |
d38ea511 DR |
352 | my $info = shift; |
353 | if ( defined( $info->{evaltext} ) ) { | |
354 | my $eval = $info->{evaltext}; | |
355 | if ( $info->{is_require} ) { | |
356 | return "require $eval"; | |
357 | } | |
358 | else { | |
359 | $eval =~ s/([\\\'])/\\$1/g; | |
360 | return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'"; | |
361 | } | |
ba7a4549 | 362 | } |
ba7a4549 | 363 | |
5bbc4d5d JL |
364 | # this can happen on older perls when the sub (or the stash containing it) |
365 | # has been deleted | |
366 | if ( !defined( $info->{sub} ) ) { | |
367 | return '__ANON__::__ANON__'; | |
368 | } | |
369 | ||
d38ea511 | 370 | return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub}; |
ba7a4549 RGS |
371 | } |
372 | ||
373 | # Figures out what call (from the point of view of the caller) | |
374 | # the long error backtrace should start at. | |
375 | sub long_error_loc { | |
d38ea511 DR |
376 | my $i; |
377 | my $lvl = $CarpLevel; | |
378 | { | |
379 | ++$i; | |
380 | my $cgc = _cgc(); | |
c541cacf RS |
381 | my @caller = $cgc ? $cgc->($i) : caller($i); |
382 | my $pkg = $caller[0]; | |
d38ea511 DR |
383 | unless ( defined($pkg) ) { |
384 | ||
385 | # This *shouldn't* happen. | |
386 | if (%Internal) { | |
387 | local %Internal; | |
388 | $i = long_error_loc(); | |
389 | last; | |
390 | } | |
c541cacf | 391 | elsif (defined $caller[2]) { |
5bbc4d5d JL |
392 | # this can happen when the stash has been deleted |
393 | # in that case, just assume that it's a reasonable place to | |
394 | # stop (the file and line data will still be intact in any | |
395 | # case) - the only issue is that we can't detect if the | |
396 | # deleted package was internal (so don't do that then) | |
397 | # -doy | |
398 | redo unless 0 > --$lvl; | |
399 | last; | |
d38ea511 | 400 | } |
c541cacf RS |
401 | else { |
402 | return 2; | |
403 | } | |
d38ea511 DR |
404 | } |
405 | redo if $CarpInternal{$pkg}; | |
406 | redo unless 0 > --$lvl; | |
407 | redo if $Internal{$pkg}; | |
ba7a4549 | 408 | } |
d38ea511 | 409 | return $i - 1; |
ba7a4549 RGS |
410 | } |
411 | ||
ba7a4549 | 412 | sub longmess_heavy { |
d38ea511 DR |
413 | return @_ if ref( $_[0] ); # don't break references as exceptions |
414 | my $i = long_error_loc(); | |
415 | return ret_backtrace( $i, @_ ); | |
ba7a4549 RGS |
416 | } |
417 | ||
418 | # Returns a full stack backtrace starting from where it is | |
419 | # told. | |
420 | sub ret_backtrace { | |
d38ea511 DR |
421 | my ( $i, @error ) = @_; |
422 | my $mess; | |
423 | my $err = join '', @error; | |
424 | $i++; | |
425 | ||
426 | my $tid_msg = ''; | |
427 | if ( defined &threads::tid ) { | |
428 | my $tid = threads->tid; | |
429 | $tid_msg = " thread $tid" if $tid; | |
430 | } | |
431 | ||
432 | my %i = caller_info($i); | |
89988fbd TL |
433 | $mess = "$err at $i{file} line $i{line}$tid_msg"; |
434 | if( defined $. ) { | |
435 | local $@ = ''; | |
63a756fa | 436 | local $SIG{__DIE__}; |
89988fbd | 437 | eval { |
781fa0f4 | 438 | CORE::die; |
89988fbd TL |
439 | }; |
440 | if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) { | |
441 | $mess .= $1; | |
442 | } | |
443 | } | |
879b0cab | 444 | $mess .= "\.\n"; |
d38ea511 DR |
445 | |
446 | while ( my %i = caller_info( ++$i ) ) { | |
447 | $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; | |
448 | } | |
449 | ||
450 | return $mess; | |
ba7a4549 RGS |
451 | } |
452 | ||
453 | sub ret_summary { | |
d38ea511 DR |
454 | my ( $i, @error ) = @_; |
455 | my $err = join '', @error; | |
456 | $i++; | |
ba7a4549 | 457 | |
d38ea511 DR |
458 | my $tid_msg = ''; |
459 | if ( defined &threads::tid ) { | |
460 | my $tid = threads->tid; | |
461 | $tid_msg = " thread $tid" if $tid; | |
462 | } | |
ba7a4549 | 463 | |
d38ea511 | 464 | my %i = caller_info($i); |
879b0cab | 465 | return "$err at $i{file} line $i{line}$tid_msg\.\n"; |
ba7a4549 RGS |
466 | } |
467 | ||
d38ea511 DR |
468 | sub short_error_loc { |
469 | # You have to create your (hash)ref out here, rather than defaulting it | |
470 | # inside trusts *on a lexical*, as you want it to persist across calls. | |
471 | # (You can default it on $_[2], but that gets messy) | |
472 | my $cache = {}; | |
473 | my $i = 1; | |
474 | my $lvl = $CarpLevel; | |
475 | { | |
476 | my $cgc = _cgc(); | |
477 | my $called = $cgc ? $cgc->($i) : caller($i); | |
478 | $i++; | |
479 | my $caller = $cgc ? $cgc->($i) : caller($i); | |
480 | ||
5bbc4d5d JL |
481 | if (!defined($caller)) { |
482 | my @caller = $cgc ? $cgc->($i) : caller($i); | |
483 | if (@caller) { | |
484 | # if there's no package but there is other caller info, then | |
485 | # the package has been deleted - treat this as a valid package | |
486 | # in this case | |
487 | redo if defined($called) && $CarpInternal{$called}; | |
488 | redo unless 0 > --$lvl; | |
489 | last; | |
490 | } | |
491 | else { | |
492 | return 0; | |
493 | } | |
494 | } | |
d38ea511 DR |
495 | redo if $Internal{$caller}; |
496 | redo if $CarpInternal{$caller}; | |
497 | redo if $CarpInternal{$called}; | |
498 | redo if trusts( $called, $caller, $cache ); | |
499 | redo if trusts( $caller, $called, $cache ); | |
500 | redo unless 0 > --$lvl; | |
501 | } | |
502 | return $i - 1; | |
503 | } | |
ba7a4549 RGS |
504 | |
505 | sub shortmess_heavy { | |
d38ea511 DR |
506 | return longmess_heavy(@_) if $Verbose; |
507 | return @_ if ref( $_[0] ); # don't break references as exceptions | |
508 | my $i = short_error_loc(); | |
509 | if ($i) { | |
510 | ret_summary( $i, @_ ); | |
511 | } | |
512 | else { | |
513 | longmess_heavy(@_); | |
514 | } | |
ba7a4549 RGS |
515 | } |
516 | ||
517 | # If a string is too long, trims it with ... | |
518 | sub str_len_trim { | |
d38ea511 DR |
519 | my $str = shift; |
520 | my $max = shift || 0; | |
521 | if ( 2 < $max and $max < length($str) ) { | |
522 | substr( $str, $max - 3 ) = '...'; | |
523 | } | |
524 | return $str; | |
ba7a4549 RGS |
525 | } |
526 | ||
527 | # Takes two packages and an optional cache. Says whether the | |
528 | # first inherits from the second. | |
529 | # | |
530 | # Recursive versions of this have to work to avoid certain | |
531 | # possible endless loops, and when following long chains of | |
532 | # inheritance are less efficient. | |
533 | sub trusts { | |
d38ea511 | 534 | my $child = shift; |
ba7a4549 | 535 | my $parent = shift; |
d38ea511 DR |
536 | my $cache = shift; |
537 | my ( $known, $partial ) = get_status( $cache, $child ); | |
538 | ||
ba7a4549 | 539 | # Figure out consequences until we have an answer |
d38ea511 | 540 | while ( @$partial and not exists $known->{$parent} ) { |
ba7a4549 RGS |
541 | my $anc = shift @$partial; |
542 | next if exists $known->{$anc}; | |
543 | $known->{$anc}++; | |
d38ea511 | 544 | my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc ); |
ba7a4549 RGS |
545 | my @found = keys %$anc_knows; |
546 | @$known{@found} = (); | |
547 | push @$partial, @$anc_partial; | |
548 | } | |
549 | return exists $known->{$parent}; | |
550 | } | |
551 | ||
552 | # Takes a package and gives a list of those trusted directly | |
553 | sub trusts_directly { | |
554 | my $class = shift; | |
555 | no strict 'refs'; | |
1a4f8f41 BF |
556 | my $stash = \%{"$class\::"}; |
557 | for my $var (qw/ CARP_NOT ISA /) { | |
558 | # Don't try using the variable until we know it exists, | |
559 | # to avoid polluting the caller's namespace. | |
79f8d0e8 BF |
560 | if ( $stash->{$var} && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) { |
561 | return @{$stash->{$var}} | |
1a4f8f41 BF |
562 | } |
563 | } | |
564 | return; | |
ba7a4549 RGS |
565 | } |
566 | ||
1104801e Z |
567 | if(!defined($warnings::VERSION) || |
568 | do { no warnings "numeric"; $warnings::VERSION < 1.03 }) { | |
edda670c Z |
569 | # Very old versions of warnings.pm import from Carp. This can go |
570 | # wrong due to the circular dependency. If Carp is invoked before | |
571 | # warnings, then Carp starts by loading warnings, then warnings | |
572 | # tries to import from Carp, and gets nothing because Carp is in | |
573 | # the process of loading and hasn't defined its import method yet. | |
574 | # So we work around that by manually exporting to warnings here. | |
575 | no strict "refs"; | |
576 | *{"warnings::$_"} = \&$_ foreach @EXPORT; | |
577 | } | |
578 | ||
748a9306 | 579 | 1; |
ba7a4549 | 580 | |
0cda2667 DM |
581 | __END__ |
582 | ||
583 | =head1 NAME | |
584 | ||
aaca3d9d | 585 | Carp - alternative warn and die for modules |
0cda2667 | 586 | |
0cda2667 DM |
587 | =head1 SYNOPSIS |
588 | ||
589 | use Carp; | |
aaca3d9d MS |
590 | |
591 | # warn user (from perspective of caller) | |
592 | carp "string trimmed to 80 chars"; | |
593 | ||
594 | # die of errors (from perspective of caller) | |
0cda2667 DM |
595 | croak "We're outta here!"; |
596 | ||
aaca3d9d MS |
597 | # die of errors with stack backtrace |
598 | confess "not implemented"; | |
599 | ||
ed504453 JK |
600 | # cluck, longmess and shortmess not exported by default |
601 | use Carp qw(cluck longmess shortmess); | |
0cda2667 | 602 | cluck "This is how we got here!"; |
ed504453 JK |
603 | $long_message = longmess( "message from cluck() or confess()" ); |
604 | $short_message = shortmess( "message from carp() or croak()" ); | |
0cda2667 | 605 | |
0cda2667 DM |
606 | =head1 DESCRIPTION |
607 | ||
608 | The Carp routines are useful in your own modules because | |
ed504453 | 609 | they act like C<die()> or C<warn()>, but with a message which is more |
0cda2667 | 610 | likely to be useful to a user of your module. In the case of |
ed504453 JK |
611 | C<cluck()> and C<confess()>, that context is a summary of every |
612 | call in the call-stack; C<longmess()> returns the contents of the error | |
613 | message. | |
614 | ||
615 | For a shorter message you can use C<carp()> or C<croak()> which report the | |
616 | error as being from where your module was called. C<shortmess()> returns the | |
617 | contents of this error message. There is no guarantee that that is where the | |
618 | error was, but it is a good educated guess. | |
0cda2667 | 619 | |
cbd58baf Z |
620 | C<Carp> takes care not to clobber the status variables C<$!> and C<$^E> |
621 | in the course of assembling its error messages. This means that a | |
622 | C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error | |
623 | information held in those variables, if it is required to augment the | |
624 | error message, and if the code calling C<Carp> left useful values there. | |
625 | Of course, C<Carp> can't guarantee the latter. | |
626 | ||
0cda2667 DM |
627 | You can also alter the way the output and logic of C<Carp> works, by |
628 | changing some global variables in the C<Carp> namespace. See the | |
629 | section on C<GLOBAL VARIABLES> below. | |
630 | ||
3b46207f | 631 | Here is a more complete description of how C<carp> and C<croak> work. |
d735c2ef BT |
632 | What they do is search the call-stack for a function call stack where |
633 | they have not been told that there shouldn't be an error. If every | |
634 | call is marked safe, they give up and give a full stack backtrace | |
635 | instead. In other words they presume that the first likely looking | |
636 | potential suspect is guilty. Their rules for telling whether | |
0cda2667 DM |
637 | a call shouldn't generate errors work as follows: |
638 | ||
639 | =over 4 | |
640 | ||
641 | =item 1. | |
642 | ||
643 | Any call from a package to itself is safe. | |
644 | ||
645 | =item 2. | |
646 | ||
647 | Packages claim that there won't be errors on calls to or from | |
d735c2ef BT |
648 | packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or |
649 | (if that array is empty) C<@ISA>. The ability to override what | |
0cda2667 DM |
650 | @ISA says is new in 5.8. |
651 | ||
652 | =item 3. | |
653 | ||
654 | The trust in item 2 is transitive. If A trusts B, and B | |
d735c2ef BT |
655 | trusts C, then A trusts C. So if you do not override C<@ISA> |
656 | with C<@CARP_NOT>, then this trust relationship is identical to, | |
0cda2667 DM |
657 | "inherits from". |
658 | ||
659 | =item 4. | |
660 | ||
661 | Any call from an internal Perl module is safe. (Nothing keeps | |
662 | user modules from marking themselves as internal to Perl, but | |
663 | this practice is discouraged.) | |
664 | ||
665 | =item 5. | |
666 | ||
d735c2ef BT |
667 | Any call to Perl's warning system (eg Carp itself) is safe. |
668 | (This rule is what keeps it from reporting the error at the | |
669 | point where you call C<carp> or C<croak>.) | |
670 | ||
671 | =item 6. | |
672 | ||
673 | C<$Carp::CarpLevel> can be set to skip a fixed number of additional | |
674 | call levels. Using this is not recommended because it is very | |
675 | difficult to get it to behave correctly. | |
0cda2667 DM |
676 | |
677 | =back | |
678 | ||
679 | =head2 Forcing a Stack Trace | |
680 | ||
681 | As a debugging aid, you can force Carp to treat a croak as a confess | |
682 | and a carp as a cluck across I<all> modules. In other words, force a | |
683 | detailed stack trace to be given. This can be very helpful when trying | |
684 | to understand why, or from where, a warning or error is being generated. | |
685 | ||
686 | This feature is enabled by 'importing' the non-existent symbol | |
687 | 'verbose'. You would typically enable it by saying | |
688 | ||
689 | perl -MCarp=verbose script.pl | |
690 | ||
11ed4d01 | 691 | or by including the string C<-MCarp=verbose> in the PERL5OPT |
0cda2667 DM |
692 | environment variable. |
693 | ||
694 | Alternately, you can set the global variable C<$Carp::Verbose> to true. | |
695 | See the C<GLOBAL VARIABLES> section below. | |
696 | ||
b4bf645b DM |
697 | =head2 Stack Trace formatting |
698 | ||
699 | At each stack level, the subroutine's name is displayed along with | |
700 | its parameters. For simple scalars, this is sufficient. For complex | |
701 | data types, such as objects and other references, this can simply | |
702 | display C<'HASH(0x1ab36d8)'>. | |
703 | ||
f7c3eab3 | 704 | Carp gives two ways to control this. |
b4bf645b DM |
705 | |
706 | =over 4 | |
707 | ||
708 | =item 1. | |
709 | ||
710 | For objects, a method, C<CARP_TRACE>, will be called, if it exists. If | |
711 | this method doesn't exist, or it recurses into C<Carp>, or it otherwise | |
712 | throws an exception, this is skipped, and Carp moves on to the next option, | |
713 | otherwise checking stops and the string returned is used. It is recommended | |
714 | that the object's type is part of the string to make debugging easier. | |
715 | ||
716 | =item 2. | |
717 | ||
718 | For any type of reference, C<$Carp::RefArgFormatter> is checked (see below). | |
719 | This variable is expected to be a code reference, and the current parameter | |
720 | is passed in. If this function doesn't exist (the variable is undef), or | |
721 | it recurses into C<Carp>, or it otherwise throws an exception, this is | |
f7c3eab3 | 722 | skipped, and Carp moves on to the next option, otherwise checking stops |
b4bf645b DM |
723 | and the string returned is used. |
724 | ||
05e287df | 725 | =item 3. |
b4bf645b | 726 | |
f7c3eab3 TC |
727 | Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is |
728 | available, stringify the value ignoring any overloading. | |
b4bf645b DM |
729 | |
730 | =back | |
731 | ||
0cda2667 DM |
732 | =head1 GLOBAL VARIABLES |
733 | ||
0cda2667 DM |
734 | =head2 $Carp::MaxEvalLen |
735 | ||
736 | This variable determines how many characters of a string-eval are to | |
737 | be shown in the output. Use a value of C<0> to show all text. | |
738 | ||
739 | Defaults to C<0>. | |
740 | ||
741 | =head2 $Carp::MaxArgLen | |
742 | ||
743 | This variable determines how many characters of each argument to a | |
744 | function to print. Use a value of C<0> to show the full length of the | |
745 | argument. | |
746 | ||
747 | Defaults to C<64>. | |
748 | ||
749 | =head2 $Carp::MaxArgNums | |
750 | ||
751 | This variable determines how many arguments to each function to show. | |
752 | Use a value of C<0> to show all arguments to a function call. | |
753 | ||
754 | Defaults to C<8>. | |
755 | ||
756 | =head2 $Carp::Verbose | |
757 | ||
ed504453 JK |
758 | This variable makes C<carp()> and C<croak()> generate stack backtraces |
759 | just like C<cluck()> and C<confess()>. This is how C<use Carp 'verbose'> | |
d735c2ef BT |
760 | is implemented internally. |
761 | ||
762 | Defaults to C<0>. | |
763 | ||
b4bf645b DM |
764 | =head2 $Carp::RefArgFormatter |
765 | ||
766 | This variable sets a general argument formatter to display references. | |
767 | Plain scalars and objects that implement C<CARP_TRACE> will not go through | |
768 | this formatter. Calling C<Carp> from within this function is not supported. | |
769 | ||
770 | local $Carp::RefArgFormatter = sub { | |
771 | require Data::Dumper; | |
772 | Data::Dumper::Dump($_[0]); # not necessarily safe | |
773 | }; | |
774 | ||
b60d6605 AG |
775 | =head2 @CARP_NOT |
776 | ||
777 | This variable, I<in your package>, says which packages are I<not> to be | |
778 | considered as the location of an error. The C<carp()> and C<cluck()> | |
779 | functions will skip over callers when reporting where an error occurred. | |
780 | ||
781 | NB: This variable must be in the package's symbol table, thus: | |
782 | ||
783 | # These work | |
784 | our @CARP_NOT; # file scope | |
785 | use vars qw(@CARP_NOT); # package scope | |
786 | @My::Package::CARP_NOT = ... ; # explicit package variable | |
787 | ||
788 | # These don't work | |
789 | sub xyz { ... @CARP_NOT = ... } # w/o declarations above | |
790 | my @CARP_NOT; # even at top-level | |
791 | ||
792 | Example of use: | |
793 | ||
794 | package My::Carping::Package; | |
795 | use Carp; | |
796 | our @CARP_NOT; | |
797 | sub bar { .... or _error('Wrong input') } | |
798 | sub _error { | |
799 | # temporary control of where'ness, __PACKAGE__ is implicit | |
800 | local @CARP_NOT = qw(My::Friendly::Caller); | |
801 | carp(@_) | |
802 | } | |
803 | ||
804 | This would make C<Carp> report the error as coming from a caller not | |
805 | in C<My::Carping::Package>, nor from C<My::Friendly::Caller>. | |
806 | ||
345e2394 | 807 | Also read the L</DESCRIPTION> section above, about how C<Carp> decides |
b60d6605 AG |
808 | where the error is reported from. |
809 | ||
810 | Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>. | |
811 | ||
812 | Overrides C<Carp>'s use of C<@ISA>. | |
813 | ||
d735c2ef BT |
814 | =head2 %Carp::Internal |
815 | ||
816 | This says what packages are internal to Perl. C<Carp> will never | |
817 | report an error as being from a line in a package that is internal to | |
818 | Perl. For example: | |
819 | ||
2a6a7022 | 820 | $Carp::Internal{ (__PACKAGE__) }++; |
d735c2ef BT |
821 | # time passes... |
822 | sub foo { ... or confess("whatever") }; | |
823 | ||
824 | would give a full stack backtrace starting from the first caller | |
825 | outside of __PACKAGE__. (Unless that package was also internal to | |
826 | Perl.) | |
827 | ||
828 | =head2 %Carp::CarpInternal | |
829 | ||
830 | This says which packages are internal to Perl's warning system. For | |
831 | generating a full stack backtrace this is the same as being internal | |
832 | to Perl, the stack backtrace will not start inside packages that are | |
833 | listed in C<%Carp::CarpInternal>. But it is slightly different for | |
834 | the summary message generated by C<carp> or C<croak>. There errors | |
835 | will not be reported on any lines that are calling packages in | |
836 | C<%Carp::CarpInternal>. | |
837 | ||
838 | For example C<Carp> itself is listed in C<%Carp::CarpInternal>. | |
839 | Therefore the full stack backtrace from C<confess> will not start | |
840 | inside of C<Carp>, and the short message from calling C<croak> is | |
841 | not placed on the line where C<croak> was called. | |
842 | ||
843 | =head2 $Carp::CarpLevel | |
0cda2667 | 844 | |
d735c2ef BT |
845 | This variable determines how many additional call frames are to be |
846 | skipped that would not otherwise be when reporting where an error | |
847 | occurred on a call to one of C<Carp>'s functions. It is fairly easy | |
848 | to count these call frames on calls that generate a full stack | |
849 | backtrace. However it is much harder to do this accounting for calls | |
850 | that generate a short message. Usually people skip too many call | |
851 | frames. If they are lucky they skip enough that C<Carp> goes all of | |
852 | the way through the call stack, realizes that something is wrong, and | |
853 | then generates a full stack backtrace. If they are unlucky then the | |
854 | error is reported from somewhere misleading very high in the call | |
855 | stack. | |
856 | ||
857 | Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use | |
3b46207f | 858 | C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>. |
0cda2667 DM |
859 | |
860 | Defaults to C<0>. | |
861 | ||
0cda2667 DM |
862 | =head1 BUGS |
863 | ||
864 | The Carp routines don't handle exception objects currently. | |
865 | If called with a first argument that is a reference, they simply | |
866 | call die() or warn(), as appropriate. | |
867 | ||
6ffbec2c Z |
868 | Some of the Carp code assumes that Perl's basic character encoding is |
869 | ASCII, and will go wrong on an EBCDIC platform. | |
870 | ||
634ff085 Z |
871 | =head1 SEE ALSO |
872 | ||
873 | L<Carp::Always>, | |
874 | L<Carp::Clan> | |
875 | ||
876 | =head1 AUTHOR | |
877 | ||
878 | The Carp module first appeared in Larry Wall's perl 5.000 distribution. | |
879 | Since then it has been modified by several of the perl 5 porters. | |
880 | Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent | |
881 | distribution. | |
882 | ||
883 | =head1 COPYRIGHT | |
884 | ||
3f2a9fa3 | 885 | Copyright (C) 1994-2013 Larry Wall |
634ff085 | 886 | |
3f2a9fa3 | 887 | Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org> |
634ff085 Z |
888 | |
889 | =head1 LICENSE | |
890 | ||
891 | This module is free software; you can redistribute it and/or modify it | |
892 | under the same terms as Perl itself. |