This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Revert "Introduce a "declaration after statement" into inline.h"
[perl5.git] / dist / Carp / lib / Carp.pm
CommitLineData
a0d0e21e 1package Carp;
8c3d9721 2
634ff085 3{ use 5.006; }
01ca8b68
DR
4use strict;
5use warnings;
d5dcec3a
Z
6BEGIN {
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
28sub _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.
49BEGIN {
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 61BEGIN {
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 73BEGIN {
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
285ac8e2
Z
90# is_safe_printable_codepoint() indicates whether a character, specified
91# by integer codepoint, is OK to output literally in a trace. Generally
92# this is if it is a printable character in the ancestral character set
93# (ASCII or EBCDIC). This is used on some Perls in situations where a
94# regexp can't be used.
95BEGIN {
96 *is_safe_printable_codepoint =
97 "$]" >= 5.007_003 ?
98 eval(q(sub ($) {
99 my $u = utf8::native_to_unicode($_[0]);
100 $u >= 0x20 && $u <= 0x7e;
101 }))
102 : ord("A") == 65 ?
103 sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e }
104 :
105 sub ($) {
106 # Early EBCDIC
107 # 3 EBCDIC code pages supported then; all controls but one
108 # are the code points below SPACE. The other one is 0x5F on
109 # POSIX-BC; FF on the other two.
110 # FIXME: there are plenty of unprintable codepoints other
111 # than those that this code and the comment above identifies
112 # as "controls".
113 $_[0] >= ord(" ") && $_[0] <= 0xff &&
114 $_[0] != (ord ("^") == 106 ? 0x5f : 0xff);
115 }
116 ;
117}
118
4efd247d
FC
119sub _univ_mod_loaded {
120 return 0 unless exists($::{"UNIVERSAL::"});
121 for ($::{"UNIVERSAL::"}) {
122 return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"};
123 for ($$_{"$_[0]::"}) {
124 return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"};
125 for ($$_{"VERSION"}) {
126 return 0 unless ref \$_ eq "GLOB";
127 return ${*$_{SCALAR}};
128 }
129 }
130 }
131}
132
7276ff5b
FC
133# _maybe_isa() is usually the UNIVERSAL::isa function. We have to avoid
134# the latter if the UNIVERSAL::isa module has been loaded, to avoid infi-
135# nite recursion; in that case _maybe_isa simply returns true.
136my $isa;
137BEGIN {
138 if (_univ_mod_loaded('isa')) {
139 *_maybe_isa = sub { 1 }
140 }
141 else {
142 # Since we have already done the check, record $isa for use below
143 # when defining _StrVal.
144 *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa");
145 }
146}
147
148
5c8d1071
FC
149# We need an overload::StrVal or equivalent function, but we must avoid
150# loading any modules on demand, as Carp is used from __DIE__ handlers and
151# may be invoked after a syntax error.
152# We can copy recent implementations of overload::StrVal and use
153# overloading.pm, which is the fastest implementation, so long as
154# overloading is available. If it is not available, we use our own pure-
155# Perl StrVal. We never actually use overload::StrVal, for various rea-
156# sons described below.
157# overload versions are as follows:
158# undef-1.00 (up to perl 5.8.0) uses bless (avoid!)
159# 1.01-1.17 (perl 5.8.1 to 5.14) uses Scalar::Util
160# 1.18+ (perl 5.16+) uses overloading
161# The ancient 'bless' implementation (that inspires our pure-Perl version)
162# blesses unblessed references and must be avoided. Those using
163# Scalar::Util use refaddr, possibly the pure-Perl implementation, which
164# has the same blessing bug, and must be avoided. Also, Scalar::Util is
165# loaded on demand. Since we avoid the Scalar::Util implementations, we
166# end up having to implement our own overloading.pm-based version for perl
167# 5.10.1 to 5.14. Since it also works just as well in more recent ver-
168# sions, we use it there, too.
4efd247d 169BEGIN {
5c8d1071
FC
170 if (eval { require "overloading.pm" }) {
171 *_StrVal = eval 'sub { no overloading; "$_[0]" }'
172 }
173 else {
174 # Work around the UNIVERSAL::can/isa modules to avoid recursion.
175
176 # _mycan is either UNIVERSAL::can, or, in the presence of an
177 # override, overload::mycan.
178 *_mycan = _univ_mod_loaded('can')
179 ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
180 : \&UNIVERSAL::can;
181
182 # _blessed is either UNIVERAL::isa(...), or, in the presence of an
183 # override, a hideous, but fairly reliable, workaround.
7276ff5b
FC
184 *_blessed = $isa
185 ? sub { &$isa($_[0], "UNIVERSAL") }
186 : sub {
5c8d1071
FC
187 my $probe = "UNIVERSAL::Carp_probe_" . rand;
188 no strict 'refs';
189 local *$probe = sub { "unlikely string" };
190 local $@;
191 local $SIG{__DIE__} = sub{};
192 (eval { $_[0]->$probe } || '') eq 'unlikely string'
5c8d1071
FC
193 };
194
195 *_StrVal = sub {
196 my $pack = ref $_[0];
197 # Perl's overload mechanism uses the presence of a special
198 # "method" named "((" or "()" to signal it is in effect.
199 # This test seeks to see if it has been set up. "((" post-
200 # dates overloading.pm, so we can skip it.
201 return "$_[0]" unless _mycan($pack, "()");
202 # Even at this point, the invocant may not be blessed, so
203 # check for that.
204 return "$_[0]" if not _blessed($_[0]);
205 bless $_[0], "Carp";
206 my $str = "$_[0]";
207 bless $_[0], $pack;
208 $pack . substr $str, index $str, "=";
209 }
210 }
4efd247d
FC
211}
212
213
fecc0102 214our $VERSION = '1.52';
1d532a9b 215$VERSION =~ tr/_//d;
b75c8c73 216
8c3d9721
DM
217our $MaxEvalLen = 0;
218our $Verbose = 0;
219our $CarpLevel = 0;
d38ea511
DR
220our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
221our $MaxArgNums = 8; # How many arguments to print. 0 = all.
b4bf645b 222our $RefArgFormatter = undef; # allow caller to format reference arguments
748a9306 223
a0d0e21e 224require Exporter;
d38ea511
DR
225our @ISA = ('Exporter');
226our @EXPORT = qw(confess croak carp);
8c3d9721 227our @EXPORT_OK = qw(cluck verbose longmess shortmess);
d38ea511 228our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
af80c6a7 229
ba7a4549
RGS
230# The members of %Internal are packages that are internal to perl.
231# Carp will not report errors from within these packages if it
232# can. The members of %CarpInternal are internal to Perl's warning
233# system. Carp will not report errors from within these packages
234# either, and will not report calls *to* these packages for carp and
235# croak. They replace $CarpLevel, which is deprecated. The
236# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
237# text and function arguments should be formatted when printed.
238
01ca8b68
DR
239our %CarpInternal;
240our %Internal;
241
ba7a4549
RGS
242# disable these by default, so they can live w/o require Carp
243$CarpInternal{Carp}++;
244$CarpInternal{warnings}++;
245$Internal{Exporter}++;
246$Internal{'Exporter::Heavy'}++;
247
af80c6a7
JH
248# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
249# then the following method will be called by the Exporter which knows
250# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
251# 'verbose'.
252
29ddba3b 253sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
7b8d334a 254
01ca8b68
DR
255sub _cgc {
256 no strict 'refs';
0ebeacde
Z
257 return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
258 return;
01ca8b68
DR
259}
260
ba7a4549 261sub longmess {
cbd58baf 262 local($!, $^E);
ba7a4549
RGS
263 # Icky backwards compatibility wrapper. :-(
264 #
265 # The story is that the original implementation hard-coded the
266 # number of call levels to go back, so calls to longmess were off
267 # by one. Other code began calling longmess and expecting this
268 # behaviour, so the replacement has to emulate that behaviour.
01ca8b68
DR
269 my $cgc = _cgc();
270 my $call_pack = $cgc ? $cgc->() : caller();
d38ea511
DR
271 if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
272 return longmess_heavy(@_);
ba7a4549
RGS
273 }
274 else {
d38ea511
DR
275 local $CarpLevel = $CarpLevel + 1;
276 return longmess_heavy(@_);
ba7a4549 277 }
d38ea511 278}
ba7a4549 279
01ca8b68 280our @CARP_NOT;
d38ea511 281
ba7a4549 282sub shortmess {
cbd58baf 283 local($!, $^E);
01ca8b68 284 my $cgc = _cgc();
d38ea511 285
ba7a4549 286 # Icky backwards compatibility wrapper. :-(
42f8d732 287 local @CARP_NOT = scalar( $cgc ? $cgc->() : caller() );
ba7a4549 288 shortmess_heavy(@_);
d38ea511 289}
7b8d334a 290
d38ea511
DR
291sub croak { die shortmess @_ }
292sub confess { die longmess @_ }
7b8d334a 293sub carp { warn shortmess @_ }
d38ea511 294sub cluck { warn longmess @_ }
a0d0e21e 295
40c2103f
Z
296BEGIN {
297 if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
298 ("$]" >= 5.012005 && "$]" < 5.013)) {
299 *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
300 } else {
301 *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
302 }
303}
304
ba7a4549 305sub caller_info {
d38ea511
DR
306 my $i = shift(@_) + 1;
307 my %call_info;
308 my $cgc = _cgc();
309 {
40c2103f
Z
310 # Some things override caller() but forget to implement the
311 # @DB::args part of it, which we need. We check for this by
312 # pre-populating @DB::args with a sentinel which no-one else
313 # has the address of, so that we can detect whether @DB::args
314 # has been properly populated. However, on earlier versions
315 # of perl this check tickles a bug in CORE::caller() which
316 # leaks memory. So we only check on fixed perls.
317 @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
d38ea511 318 package DB;
d38ea511
DR
319 @call_info{
320 qw(pack file line sub has_args wantarray evaltext is_require) }
321 = $cgc ? $cgc->($i) : caller($i);
eff7e72c 322 }
d38ea511 323
5bbc4d5d 324 unless ( defined $call_info{file} ) {
d38ea511
DR
325 return ();
326 }
327
328 my $sub_name = Carp::get_subname( \%call_info );
329 if ( $call_info{has_args} ) {
02c84d7f
YO
330 # Guard our serialization of the stack from stack refcounting bugs
331 # NOTE this is NOT a complete solution, we cannot 100% guard against
332 # these bugs. However in many cases Perl *is* capable of detecting
333 # them and throws an error when it does. Unfortunately serializing
334 # the arguments on the stack is a perfect way of finding these bugs,
335 # even when they would not affect normal program flow that did not
336 # poke around inside the stack. Inside of Carp.pm it makes little
337 # sense reporting these bugs, as Carp's job is to report the callers
338 # errors, not the ones it might happen to tickle while doing so.
339 # See: https://rt.perl.org/Public/Bug/Display.html?id=131046
340 # and: https://rt.perl.org/Public/Bug/Display.html?id=52610
341 # for more details and discussion. - Yves
4764858c
P
342 my @args = map {
343 my $arg;
344 local $@= $@;
345 eval {
346 $arg = $_;
347 1;
348 } or do {
349 $arg = '** argument not available anymore **';
350 };
351 $arg;
352 } @DB::args;
353 if (CALLER_OVERRIDE_CHECK_OK && @args == 1
354 && ref $args[0] eq ref \$i
355 && $args[0] == \$i ) {
356 @args = (); # Don't let anyone see the address of $i
d38ea511
DR
357 local $@;
358 my $where = eval {
359 my $func = $cgc or return '';
1a6d5308 360 my $gv =
f2ea7462 361 (_fetch_sub B => 'svref_2object' or return '')
1a6d5308 362 ->($func)->GV;
d38ea511
DR
363 my $package = $gv->STASH->NAME;
364 my $subname = $gv->NAME;
365 return unless defined $package && defined $subname;
366
367 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
368 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
369 " in &${package}::$subname";
634ff085 370 } || '';
d38ea511
DR
371 @args
372 = "** Incomplete caller override detected$where; \@DB::args were not set **";
373 }
374 else {
e7eb9d6b
JL
375 my $overflow;
376 if ( $MaxArgNums and @args > $MaxArgNums )
377 { # More than we want to show?
bc150b6c 378 $#args = $MaxArgNums - 1;
e7eb9d6b
JL
379 $overflow = 1;
380 }
381
382 @args = map { Carp::format_arg($_) } @args;
383
384 if ($overflow) {
385 push @args, '...';
386 }
d38ea511
DR
387 }
388
389 # Push the args onto the subroutine
390 $sub_name .= '(' . join( ', ', @args ) . ')';
ba7a4549 391 }
d38ea511
DR
392 $call_info{sub_name} = $sub_name;
393 return wantarray() ? %call_info : \%call_info;
ba7a4549
RGS
394}
395
396# Transform an argument to a function into a string.
fdf5fcde 397our $in_recurse;
ba7a4549 398sub format_arg {
0ebeacde 399 my $arg = shift;
b4bf645b 400
c99363aa 401 if ( my $pack= ref($arg) ) {
915a6810 402
fdf5fcde 403 # legitimate, let's not leak it.
7276ff5b 404 if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) &&
fdf5fcde
TC
405 do {
406 local $@;
407 local $in_recurse = 1;
408 local $SIG{__DIE__} = sub{};
b4bf645b
DM
409 eval {$arg->can('CARP_TRACE') }
410 })
411 {
6ffbec2c 412 return $arg->CARP_TRACE();
b4bf645b 413 }
fdf5fcde 414 elsif (!$in_recurse &&
3bcf54a5 415 defined($RefArgFormatter) &&
fdf5fcde 416 do {
b4bf645b 417 local $@;
fdf5fcde
TC
418 local $in_recurse = 1;
419 local $SIG{__DIE__} = sub{};
b4bf645b
DM
420 eval {$arg = $RefArgFormatter->($arg); 1}
421 })
422 {
6ffbec2c 423 return $arg;
b4bf645b 424 }
b4bf645b
DM
425 else
426 {
5c8d1071
FC
427 # Argument may be blessed into a class with overloading, and so
428 # might have an overloaded stringification. We don't want to
429 # risk getting the overloaded stringification, so we need to
430 # use _StrVal, our overload::StrVal()-equivalent.
431 return _StrVal $arg;
b4bf645b 432 }
d38ea511 433 }
6ffbec2c
Z
434 return "undef" if !defined($arg);
435 downgrade($arg, 1);
436 return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
437 $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
438 my $suffix = "";
439 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
440 substr ( $arg, $MaxArgLen - 3 ) = "";
441 $suffix = "...";
634ff085 442 }
6ffbec2c 443 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
6ffbec2c
Z
444 for(my $i = length($arg); $i--; ) {
445 my $c = substr($arg, $i, 1);
446 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
447 if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
448 substr $arg, $i, 0, "\\";
449 next;
450 }
451 my $o = ord($c);
285ac8e2
Z
452 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
453 unless is_safe_printable_codepoint($o);
6ffbec2c 454 }
0ebeacde 455 } else {
6ffbec2c 456 $arg =~ s/([\"\\\$\@])/\\$1/g;
975fe854
KW
457 # This is all the ASCII printables spelled-out. It is portable to all
458 # Perl versions and platforms (such as EBCDIC). There are other more
459 # compact ways to do this, but may not work everywhere every version.
285ac8e2 460 $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
d38ea511 461 }
0ebeacde 462 downgrade($arg, 1);
6ffbec2c 463 return "\"".$arg."\"".$suffix;
ba7a4549
RGS
464}
465
e94bb470
Z
466sub Regexp::CARP_TRACE {
467 my $arg = "$_[0]";
468 downgrade($arg, 1);
469 if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
470 for(my $i = length($arg); $i--; ) {
471 my $o = ord(substr($arg, $i, 1));
472 my $x = substr($arg, 0, 0); # work around bug on Perl 5.8.{1,2}
285ac8e2
Z
473 substr $arg, $i, 1, sprintf("\\x{%x}", $o)
474 unless is_safe_printable_codepoint($o);
e94bb470
Z
475 }
476 } else {
975fe854 477 # See comment in format_arg() about this same regex.
285ac8e2 478 $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
e94bb470
Z
479 }
480 downgrade($arg, 1);
481 my $suffix = "";
482 if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
483 ($suffix, $arg) = ($1, $2);
484 }
485 if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
486 substr ( $arg, $MaxArgLen - 3 ) = "";
487 $suffix = "...".$suffix;
488 }
489 return "qr($arg)$suffix";
490}
491
ba7a4549
RGS
492# Takes an inheritance cache and a package and returns
493# an anon hash of known inheritances and anon array of
494# inheritances which consequences have not been figured
495# for.
496sub get_status {
497 my $cache = shift;
d38ea511
DR
498 my $pkg = shift;
499 $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
500 return @{ $cache->{$pkg} };
ba7a4549
RGS
501}
502
503# Takes the info from caller() and figures out the name of
504# the sub/require/eval
505sub get_subname {
0ebeacde 506 my $info = shift;
d38ea511
DR
507 if ( defined( $info->{evaltext} ) ) {
508 my $eval = $info->{evaltext};
509 if ( $info->{is_require} ) {
510 return "require $eval";
511 }
512 else {
513 $eval =~ s/([\\\'])/\\$1/g;
514 return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
515 }
ba7a4549 516 }
ba7a4549 517
5bbc4d5d
JL
518 # this can happen on older perls when the sub (or the stash containing it)
519 # has been deleted
0ebeacde 520 if ( !defined( $info->{sub} ) ) {
5bbc4d5d
JL
521 return '__ANON__::__ANON__';
522 }
523
d38ea511 524 return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
ba7a4549
RGS
525}
526
527# Figures out what call (from the point of view of the caller)
528# the long error backtrace should start at.
529sub long_error_loc {
d38ea511
DR
530 my $i;
531 my $lvl = $CarpLevel;
532 {
533 ++$i;
0ebeacde 534 my $cgc = _cgc();
c541cacf
RS
535 my @caller = $cgc ? $cgc->($i) : caller($i);
536 my $pkg = $caller[0];
d38ea511
DR
537 unless ( defined($pkg) ) {
538
539 # This *shouldn't* happen.
540 if (%Internal) {
541 local %Internal;
542 $i = long_error_loc();
543 last;
544 }
c541cacf 545 elsif (defined $caller[2]) {
5bbc4d5d
JL
546 # this can happen when the stash has been deleted
547 # in that case, just assume that it's a reasonable place to
548 # stop (the file and line data will still be intact in any
549 # case) - the only issue is that we can't detect if the
550 # deleted package was internal (so don't do that then)
551 # -doy
552 redo unless 0 > --$lvl;
553 last;
d38ea511 554 }
c541cacf
RS
555 else {
556 return 2;
557 }
d38ea511
DR
558 }
559 redo if $CarpInternal{$pkg};
560 redo unless 0 > --$lvl;
561 redo if $Internal{$pkg};
ba7a4549 562 }
d38ea511 563 return $i - 1;
ba7a4549
RGS
564}
565
ba7a4549 566sub longmess_heavy {
6ca94a7e
SF
567 if ( ref( $_[0] ) ) { # don't break references as exceptions
568 return wantarray ? @_ : $_[0];
569 }
d38ea511
DR
570 my $i = long_error_loc();
571 return ret_backtrace( $i, @_ );
ba7a4549
RGS
572}
573
5d70f8f9
FC
574BEGIN {
575 if("$]" >= 5.017004) {
576 # The LAST_FH constant is a reference to the variable.
577 $Carp::{LAST_FH} = \eval '\${^LAST_FH}';
578 } else {
579 eval '*LAST_FH = sub () { 0 }';
580 }
581}
582
ba7a4549
RGS
583# Returns a full stack backtrace starting from where it is
584# told.
585sub ret_backtrace {
d38ea511
DR
586 my ( $i, @error ) = @_;
587 my $mess;
588 my $err = join '', @error;
589 $i++;
590
591 my $tid_msg = '';
592 if ( defined &threads::tid ) {
593 my $tid = threads->tid;
594 $tid_msg = " thread $tid" if $tid;
595 }
596
597 my %i = caller_info($i);
89988fbd 598 $mess = "$err at $i{file} line $i{line}$tid_msg";
5d70f8f9
FC
599 if( $. ) {
600 # Use ${^LAST_FH} if available.
601 if (LAST_FH) {
602 if (${+LAST_FH}) {
603 $mess .= sprintf ", <%s> %s %d",
604 *${+LAST_FH}{NAME},
605 ($/ eq "\n" ? "line" : "chunk"), $.
606 }
607 }
608 else {
89988fbd 609 local $@ = '';
63a756fa 610 local $SIG{__DIE__};
89988fbd 611 eval {
781fa0f4 612 CORE::die;
89988fbd 613 };
2f7a15bf 614 if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
89988fbd 615 $mess .= $1;
616 }
5d70f8f9 617 }
89988fbd 618 }
879b0cab 619 $mess .= "\.\n";
d38ea511
DR
620
621 while ( my %i = caller_info( ++$i ) ) {
622 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
623 }
624
625 return $mess;
ba7a4549
RGS
626}
627
628sub ret_summary {
d38ea511
DR
629 my ( $i, @error ) = @_;
630 my $err = join '', @error;
631 $i++;
ba7a4549 632
d38ea511
DR
633 my $tid_msg = '';
634 if ( defined &threads::tid ) {
635 my $tid = threads->tid;
636 $tid_msg = " thread $tid" if $tid;
637 }
ba7a4549 638
d38ea511 639 my %i = caller_info($i);
879b0cab 640 return "$err at $i{file} line $i{line}$tid_msg\.\n";
ba7a4549
RGS
641}
642
d38ea511
DR
643sub short_error_loc {
644 # You have to create your (hash)ref out here, rather than defaulting it
645 # inside trusts *on a lexical*, as you want it to persist across calls.
646 # (You can default it on $_[2], but that gets messy)
647 my $cache = {};
648 my $i = 1;
649 my $lvl = $CarpLevel;
650 {
0ebeacde 651 my $cgc = _cgc();
d38ea511
DR
652 my $called = $cgc ? $cgc->($i) : caller($i);
653 $i++;
654 my $caller = $cgc ? $cgc->($i) : caller($i);
655
5bbc4d5d
JL
656 if (!defined($caller)) {
657 my @caller = $cgc ? $cgc->($i) : caller($i);
658 if (@caller) {
659 # if there's no package but there is other caller info, then
660 # the package has been deleted - treat this as a valid package
661 # in this case
662 redo if defined($called) && $CarpInternal{$called};
663 redo unless 0 > --$lvl;
664 last;
665 }
666 else {
667 return 0;
668 }
669 }
d38ea511
DR
670 redo if $Internal{$caller};
671 redo if $CarpInternal{$caller};
672 redo if $CarpInternal{$called};
673 redo if trusts( $called, $caller, $cache );
674 redo if trusts( $caller, $called, $cache );
675 redo unless 0 > --$lvl;
676 }
677 return $i - 1;
678}
ba7a4549
RGS
679
680sub shortmess_heavy {
d38ea511
DR
681 return longmess_heavy(@_) if $Verbose;
682 return @_ if ref( $_[0] ); # don't break references as exceptions
683 my $i = short_error_loc();
684 if ($i) {
685 ret_summary( $i, @_ );
686 }
687 else {
688 longmess_heavy(@_);
689 }
ba7a4549
RGS
690}
691
692# If a string is too long, trims it with ...
693sub str_len_trim {
d38ea511
DR
694 my $str = shift;
695 my $max = shift || 0;
696 if ( 2 < $max and $max < length($str) ) {
697 substr( $str, $max - 3 ) = '...';
698 }
699 return $str;
ba7a4549
RGS
700}
701
702# Takes two packages and an optional cache. Says whether the
703# first inherits from the second.
704#
705# Recursive versions of this have to work to avoid certain
706# possible endless loops, and when following long chains of
707# inheritance are less efficient.
708sub trusts {
d38ea511 709 my $child = shift;
ba7a4549 710 my $parent = shift;
d38ea511
DR
711 my $cache = shift;
712 my ( $known, $partial ) = get_status( $cache, $child );
713
ba7a4549 714 # Figure out consequences until we have an answer
d38ea511 715 while ( @$partial and not exists $known->{$parent} ) {
ba7a4549
RGS
716 my $anc = shift @$partial;
717 next if exists $known->{$anc};
718 $known->{$anc}++;
d38ea511 719 my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
ba7a4549
RGS
720 my @found = keys %$anc_knows;
721 @$known{@found} = ();
722 push @$partial, @$anc_partial;
723 }
724 return exists $known->{$parent};
725}
726
727# Takes a package and gives a list of those trusted directly
728sub trusts_directly {
729 my $class = shift;
730 no strict 'refs';
1a4f8f41
BF
731 my $stash = \%{"$class\::"};
732 for my $var (qw/ CARP_NOT ISA /) {
733 # Don't try using the variable until we know it exists,
734 # to avoid polluting the caller's namespace.
b3937e20
FC
735 if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
736 && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
79f8d0e8 737 return @{$stash->{$var}}
1a4f8f41
BF
738 }
739 }
740 return;
ba7a4549
RGS
741}
742
1104801e
Z
743if(!defined($warnings::VERSION) ||
744 do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
edda670c
Z
745 # Very old versions of warnings.pm import from Carp. This can go
746 # wrong due to the circular dependency. If Carp is invoked before
747 # warnings, then Carp starts by loading warnings, then warnings
748 # tries to import from Carp, and gets nothing because Carp is in
749 # the process of loading and hasn't defined its import method yet.
750 # So we work around that by manually exporting to warnings here.
751 no strict "refs";
752 *{"warnings::$_"} = \&$_ foreach @EXPORT;
753}
754
748a9306 7551;
ba7a4549 756
0cda2667
DM
757__END__
758
759=head1 NAME
760
aaca3d9d 761Carp - alternative warn and die for modules
0cda2667 762
0cda2667
DM
763=head1 SYNOPSIS
764
765 use Carp;
aaca3d9d
MS
766
767 # warn user (from perspective of caller)
768 carp "string trimmed to 80 chars";
769
770 # die of errors (from perspective of caller)
0cda2667
DM
771 croak "We're outta here!";
772
aaca3d9d
MS
773 # die of errors with stack backtrace
774 confess "not implemented";
775
ed504453
JK
776 # cluck, longmess and shortmess not exported by default
777 use Carp qw(cluck longmess shortmess);
403e0607 778 cluck "This is how we got here!"; # warn with stack backtrace
ed504453
JK
779 $long_message = longmess( "message from cluck() or confess()" );
780 $short_message = shortmess( "message from carp() or croak()" );
0cda2667 781
0cda2667
DM
782=head1 DESCRIPTION
783
784The Carp routines are useful in your own modules because
ed504453 785they act like C<die()> or C<warn()>, but with a message which is more
0cda2667 786likely to be useful to a user of your module. In the case of
ed504453
JK
787C<cluck()> and C<confess()>, that context is a summary of every
788call in the call-stack; C<longmess()> returns the contents of the error
789message.
790
791For a shorter message you can use C<carp()> or C<croak()> which report the
792error as being from where your module was called. C<shortmess()> returns the
793contents of this error message. There is no guarantee that that is where the
794error was, but it is a good educated guess.
0cda2667 795
cbd58baf
Z
796C<Carp> takes care not to clobber the status variables C<$!> and C<$^E>
797in the course of assembling its error messages. This means that a
798C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error
799information held in those variables, if it is required to augment the
800error message, and if the code calling C<Carp> left useful values there.
801Of course, C<Carp> can't guarantee the latter.
802
0cda2667
DM
803You can also alter the way the output and logic of C<Carp> works, by
804changing some global variables in the C<Carp> namespace. See the
805section on C<GLOBAL VARIABLES> below.
806
3b46207f 807Here is a more complete description of how C<carp> and C<croak> work.
d735c2ef
BT
808What they do is search the call-stack for a function call stack where
809they have not been told that there shouldn't be an error. If every
810call is marked safe, they give up and give a full stack backtrace
811instead. In other words they presume that the first likely looking
812potential suspect is guilty. Their rules for telling whether
0cda2667
DM
813a call shouldn't generate errors work as follows:
814
815=over 4
816
817=item 1.
818
819Any call from a package to itself is safe.
820
821=item 2.
822
823Packages claim that there won't be errors on calls to or from
d735c2ef
BT
824packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
825(if that array is empty) C<@ISA>. The ability to override what
0cda2667
DM
826@ISA says is new in 5.8.
827
828=item 3.
829
830The trust in item 2 is transitive. If A trusts B, and B
d735c2ef
BT
831trusts C, then A trusts C. So if you do not override C<@ISA>
832with C<@CARP_NOT>, then this trust relationship is identical to,
0cda2667
DM
833"inherits from".
834
835=item 4.
836
837Any call from an internal Perl module is safe. (Nothing keeps
838user modules from marking themselves as internal to Perl, but
839this practice is discouraged.)
840
841=item 5.
842
d735c2ef
BT
843Any call to Perl's warning system (eg Carp itself) is safe.
844(This rule is what keeps it from reporting the error at the
845point where you call C<carp> or C<croak>.)
846
847=item 6.
848
849C<$Carp::CarpLevel> can be set to skip a fixed number of additional
850call levels. Using this is not recommended because it is very
851difficult to get it to behave correctly.
0cda2667
DM
852
853=back
854
855=head2 Forcing a Stack Trace
856
857As a debugging aid, you can force Carp to treat a croak as a confess
858and a carp as a cluck across I<all> modules. In other words, force a
859detailed stack trace to be given. This can be very helpful when trying
860to understand why, or from where, a warning or error is being generated.
861
862This feature is enabled by 'importing' the non-existent symbol
863'verbose'. You would typically enable it by saying
864
865 perl -MCarp=verbose script.pl
866
11ed4d01 867or by including the string C<-MCarp=verbose> in the PERL5OPT
0cda2667
DM
868environment variable.
869
870Alternately, you can set the global variable C<$Carp::Verbose> to true.
871See the C<GLOBAL VARIABLES> section below.
872
b4bf645b
DM
873=head2 Stack Trace formatting
874
875At each stack level, the subroutine's name is displayed along with
876its parameters. For simple scalars, this is sufficient. For complex
877data types, such as objects and other references, this can simply
878display C<'HASH(0x1ab36d8)'>.
879
f7c3eab3 880Carp gives two ways to control this.
b4bf645b
DM
881
882=over 4
883
884=item 1.
885
886For objects, a method, C<CARP_TRACE>, will be called, if it exists. If
887this method doesn't exist, or it recurses into C<Carp>, or it otherwise
888throws an exception, this is skipped, and Carp moves on to the next option,
889otherwise checking stops and the string returned is used. It is recommended
890that the object's type is part of the string to make debugging easier.
891
892=item 2.
893
894For any type of reference, C<$Carp::RefArgFormatter> is checked (see below).
895This variable is expected to be a code reference, and the current parameter
896is passed in. If this function doesn't exist (the variable is undef), or
897it recurses into C<Carp>, or it otherwise throws an exception, this is
f7c3eab3 898skipped, and Carp moves on to the next option, otherwise checking stops
b4bf645b
DM
899and the string returned is used.
900
05e287df 901=item 3.
b4bf645b 902
f7c3eab3
TC
903Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is
904available, stringify the value ignoring any overloading.
b4bf645b
DM
905
906=back
907
0cda2667
DM
908=head1 GLOBAL VARIABLES
909
0cda2667
DM
910=head2 $Carp::MaxEvalLen
911
912This variable determines how many characters of a string-eval are to
913be shown in the output. Use a value of C<0> to show all text.
914
915Defaults to C<0>.
916
917=head2 $Carp::MaxArgLen
918
919This variable determines how many characters of each argument to a
920function to print. Use a value of C<0> to show the full length of the
921argument.
922
923Defaults to C<64>.
924
925=head2 $Carp::MaxArgNums
926
927This variable determines how many arguments to each function to show.
bc150b6c 928Use a false value to show all arguments to a function call. To suppress all
929arguments, use C<-1> or C<'0 but true'>.
0cda2667
DM
930
931Defaults to C<8>.
932
933=head2 $Carp::Verbose
934
ed504453
JK
935This variable makes C<carp()> and C<croak()> generate stack backtraces
936just like C<cluck()> and C<confess()>. This is how C<use Carp 'verbose'>
d735c2ef
BT
937is implemented internally.
938
939Defaults to C<0>.
940
b4bf645b
DM
941=head2 $Carp::RefArgFormatter
942
943This variable sets a general argument formatter to display references.
944Plain scalars and objects that implement C<CARP_TRACE> will not go through
945this formatter. Calling C<Carp> from within this function is not supported.
946
fecc0102
D
947 local $Carp::RefArgFormatter = sub {
948 require Data::Dumper;
949 Data::Dumper->Dump($_[0]); # not necessarily safe
950 };
b4bf645b 951
b60d6605
AG
952=head2 @CARP_NOT
953
954This variable, I<in your package>, says which packages are I<not> to be
955considered as the location of an error. The C<carp()> and C<cluck()>
956functions will skip over callers when reporting where an error occurred.
957
958NB: This variable must be in the package's symbol table, thus:
959
960 # These work
961 our @CARP_NOT; # file scope
962 use vars qw(@CARP_NOT); # package scope
963 @My::Package::CARP_NOT = ... ; # explicit package variable
964
965 # These don't work
966 sub xyz { ... @CARP_NOT = ... } # w/o declarations above
967 my @CARP_NOT; # even at top-level
968
969Example of use:
970
971 package My::Carping::Package;
972 use Carp;
973 our @CARP_NOT;
974 sub bar { .... or _error('Wrong input') }
975 sub _error {
976 # temporary control of where'ness, __PACKAGE__ is implicit
977 local @CARP_NOT = qw(My::Friendly::Caller);
978 carp(@_)
979 }
980
981This would make C<Carp> report the error as coming from a caller not
982in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
983
345e2394 984Also read the L</DESCRIPTION> section above, about how C<Carp> decides
b60d6605
AG
985where the error is reported from.
986
987Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
988
989Overrides C<Carp>'s use of C<@ISA>.
990
d735c2ef
BT
991=head2 %Carp::Internal
992
993This says what packages are internal to Perl. C<Carp> will never
994report an error as being from a line in a package that is internal to
995Perl. For example:
996
2a6a7022 997 $Carp::Internal{ (__PACKAGE__) }++;
d735c2ef
BT
998 # time passes...
999 sub foo { ... or confess("whatever") };
1000
1001would give a full stack backtrace starting from the first caller
1002outside of __PACKAGE__. (Unless that package was also internal to
1003Perl.)
1004
1005=head2 %Carp::CarpInternal
1006
1007This says which packages are internal to Perl's warning system. For
1008generating a full stack backtrace this is the same as being internal
1009to Perl, the stack backtrace will not start inside packages that are
1010listed in C<%Carp::CarpInternal>. But it is slightly different for
1011the summary message generated by C<carp> or C<croak>. There errors
1012will not be reported on any lines that are calling packages in
1013C<%Carp::CarpInternal>.
1014
1015For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
1016Therefore the full stack backtrace from C<confess> will not start
1017inside of C<Carp>, and the short message from calling C<croak> is
1018not placed on the line where C<croak> was called.
1019
1020=head2 $Carp::CarpLevel
0cda2667 1021
d735c2ef
BT
1022This variable determines how many additional call frames are to be
1023skipped that would not otherwise be when reporting where an error
1024occurred on a call to one of C<Carp>'s functions. It is fairly easy
1025to count these call frames on calls that generate a full stack
1026backtrace. However it is much harder to do this accounting for calls
1027that generate a short message. Usually people skip too many call
1028frames. If they are lucky they skip enough that C<Carp> goes all of
1029the way through the call stack, realizes that something is wrong, and
1030then generates a full stack backtrace. If they are unlucky then the
1031error is reported from somewhere misleading very high in the call
1032stack.
1033
1034Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
3b46207f 1035C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
0cda2667
DM
1036
1037Defaults to C<0>.
1038
0cda2667
DM
1039=head1 BUGS
1040
1041The Carp routines don't handle exception objects currently.
1042If called with a first argument that is a reference, they simply
1043call die() or warn(), as appropriate.
1044
634ff085
Z
1045=head1 SEE ALSO
1046
1047L<Carp::Always>,
1048L<Carp::Clan>
1049
8b2caac3
SF
1050=head1 CONTRIBUTING
1051
1052L<Carp> is maintained by the perl 5 porters as part of the core perl 5
1053version control repository. Please see the L<perlhack> perldoc for how to
1054submit patches and contribute to it.
1055
634ff085
Z
1056=head1 AUTHOR
1057
1058The Carp module first appeared in Larry Wall's perl 5.000 distribution.
1059Since then it has been modified by several of the perl 5 porters.
1060Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
1061distribution.
1062
1063=head1 COPYRIGHT
1064
3f2a9fa3 1065Copyright (C) 1994-2013 Larry Wall
634ff085 1066
3f2a9fa3 1067Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
634ff085
Z
1068
1069=head1 LICENSE
1070
1071This module is free software; you can redistribute it and/or modify it
1072under the same terms as Perl itself.