This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
preserve $! and $^E in Carp
[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
d5dcec3a 90our $VERSION = '1.32';
b75c8c73 91
8c3d9721
DM
92our $MaxEvalLen = 0;
93our $Verbose = 0;
94our $CarpLevel = 0;
d38ea511
DR
95our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
96our $MaxArgNums = 8; # How many arguments to print. 0 = all.
b4bf645b 97our $RefArgFormatter = undef; # allow caller to format reference arguments
748a9306 98
a0d0e21e 99require Exporter;
d38ea511
DR
100our @ISA = ('Exporter');
101our @EXPORT = qw(confess croak carp);
8c3d9721 102our @EXPORT_OK = qw(cluck verbose longmess shortmess);
d38ea511 103our @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
114our %CarpInternal;
115our %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 128sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
7b8d334a 129
01ca8b68
DR
130sub _cgc {
131 no strict 'refs';
132 return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
133 return;
134}
135
ba7a4549 136sub 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 155our @CARP_NOT;
d38ea511 156
ba7a4549 157sub 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
166sub croak { die shortmess @_ }
167sub confess { die longmess @_ }
7b8d334a 168sub carp { warn shortmess @_ }
d38ea511 169sub cluck { warn longmess @_ }
a0d0e21e 170
40c2103f
Z
171BEGIN {
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 180sub 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 251our $in_recurse;
ba7a4549 252sub 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
313sub 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.
342sub 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
351sub 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.
375sub 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 412sub 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.
420sub 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 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 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
453sub 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
468sub 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
505sub 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 ...
518sub 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.
533sub 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
553sub 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
567if(!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 5791;
ba7a4549 580
0cda2667
DM
581__END__
582
583=head1 NAME
584
aaca3d9d 585Carp - 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
608The Carp routines are useful in your own modules because
ed504453 609they act like C<die()> or C<warn()>, but with a message which is more
0cda2667 610likely to be useful to a user of your module. In the case of
ed504453
JK
611C<cluck()> and C<confess()>, that context is a summary of every
612call in the call-stack; C<longmess()> returns the contents of the error
613message.
614
615For a shorter message you can use C<carp()> or C<croak()> which report the
616error as being from where your module was called. C<shortmess()> returns the
617contents of this error message. There is no guarantee that that is where the
618error was, but it is a good educated guess.
0cda2667 619
cbd58baf
Z
620C<Carp> takes care not to clobber the status variables C<$!> and C<$^E>
621in the course of assembling its error messages. This means that a
622C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error
623information held in those variables, if it is required to augment the
624error message, and if the code calling C<Carp> left useful values there.
625Of course, C<Carp> can't guarantee the latter.
626
0cda2667
DM
627You can also alter the way the output and logic of C<Carp> works, by
628changing some global variables in the C<Carp> namespace. See the
629section on C<GLOBAL VARIABLES> below.
630
3b46207f 631Here is a more complete description of how C<carp> and C<croak> work.
d735c2ef
BT
632What they do is search the call-stack for a function call stack where
633they have not been told that there shouldn't be an error. If every
634call is marked safe, they give up and give a full stack backtrace
635instead. In other words they presume that the first likely looking
636potential suspect is guilty. Their rules for telling whether
0cda2667
DM
637a call shouldn't generate errors work as follows:
638
639=over 4
640
641=item 1.
642
643Any call from a package to itself is safe.
644
645=item 2.
646
647Packages claim that there won't be errors on calls to or from
d735c2ef
BT
648packages 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
654The trust in item 2 is transitive. If A trusts B, and B
d735c2ef
BT
655trusts C, then A trusts C. So if you do not override C<@ISA>
656with C<@CARP_NOT>, then this trust relationship is identical to,
0cda2667
DM
657"inherits from".
658
659=item 4.
660
661Any call from an internal Perl module is safe. (Nothing keeps
662user modules from marking themselves as internal to Perl, but
663this practice is discouraged.)
664
665=item 5.
666
d735c2ef
BT
667Any call to Perl's warning system (eg Carp itself) is safe.
668(This rule is what keeps it from reporting the error at the
669point where you call C<carp> or C<croak>.)
670
671=item 6.
672
673C<$Carp::CarpLevel> can be set to skip a fixed number of additional
674call levels. Using this is not recommended because it is very
675difficult to get it to behave correctly.
0cda2667
DM
676
677=back
678
679=head2 Forcing a Stack Trace
680
681As a debugging aid, you can force Carp to treat a croak as a confess
682and a carp as a cluck across I<all> modules. In other words, force a
683detailed stack trace to be given. This can be very helpful when trying
684to understand why, or from where, a warning or error is being generated.
685
686This 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 691or by including the string C<-MCarp=verbose> in the PERL5OPT
0cda2667
DM
692environment variable.
693
694Alternately, you can set the global variable C<$Carp::Verbose> to true.
695See the C<GLOBAL VARIABLES> section below.
696
b4bf645b
DM
697=head2 Stack Trace formatting
698
699At each stack level, the subroutine's name is displayed along with
700its parameters. For simple scalars, this is sufficient. For complex
701data types, such as objects and other references, this can simply
702display C<'HASH(0x1ab36d8)'>.
703
f7c3eab3 704Carp gives two ways to control this.
b4bf645b
DM
705
706=over 4
707
708=item 1.
709
710For objects, a method, C<CARP_TRACE>, will be called, if it exists. If
711this method doesn't exist, or it recurses into C<Carp>, or it otherwise
712throws an exception, this is skipped, and Carp moves on to the next option,
713otherwise checking stops and the string returned is used. It is recommended
714that the object's type is part of the string to make debugging easier.
715
716=item 2.
717
718For any type of reference, C<$Carp::RefArgFormatter> is checked (see below).
719This variable is expected to be a code reference, and the current parameter
720is passed in. If this function doesn't exist (the variable is undef), or
721it recurses into C<Carp>, or it otherwise throws an exception, this is
f7c3eab3 722skipped, and Carp moves on to the next option, otherwise checking stops
b4bf645b
DM
723and the string returned is used.
724
05e287df 725=item 3.
b4bf645b 726
f7c3eab3
TC
727Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is
728available, 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
736This variable determines how many characters of a string-eval are to
737be shown in the output. Use a value of C<0> to show all text.
738
739Defaults to C<0>.
740
741=head2 $Carp::MaxArgLen
742
743This variable determines how many characters of each argument to a
744function to print. Use a value of C<0> to show the full length of the
745argument.
746
747Defaults to C<64>.
748
749=head2 $Carp::MaxArgNums
750
751This variable determines how many arguments to each function to show.
752Use a value of C<0> to show all arguments to a function call.
753
754Defaults to C<8>.
755
756=head2 $Carp::Verbose
757
ed504453
JK
758This variable makes C<carp()> and C<croak()> generate stack backtraces
759just like C<cluck()> and C<confess()>. This is how C<use Carp 'verbose'>
d735c2ef
BT
760is implemented internally.
761
762Defaults to C<0>.
763
b4bf645b
DM
764=head2 $Carp::RefArgFormatter
765
766This variable sets a general argument formatter to display references.
767Plain scalars and objects that implement C<CARP_TRACE> will not go through
768this formatter. Calling C<Carp> from within this function is not supported.
769
770local $Carp::RefArgFormatter = sub {
771 require Data::Dumper;
772 Data::Dumper::Dump($_[0]); # not necessarily safe
773};
774
b60d6605
AG
775=head2 @CARP_NOT
776
777This variable, I<in your package>, says which packages are I<not> to be
778considered as the location of an error. The C<carp()> and C<cluck()>
779functions will skip over callers when reporting where an error occurred.
780
781NB: 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
792Example 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
804This would make C<Carp> report the error as coming from a caller not
805in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
806
345e2394 807Also read the L</DESCRIPTION> section above, about how C<Carp> decides
b60d6605
AG
808where the error is reported from.
809
810Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
811
812Overrides C<Carp>'s use of C<@ISA>.
813
d735c2ef
BT
814=head2 %Carp::Internal
815
816This says what packages are internal to Perl. C<Carp> will never
817report an error as being from a line in a package that is internal to
818Perl. For example:
819
2a6a7022 820 $Carp::Internal{ (__PACKAGE__) }++;
d735c2ef
BT
821 # time passes...
822 sub foo { ... or confess("whatever") };
823
824would give a full stack backtrace starting from the first caller
825outside of __PACKAGE__. (Unless that package was also internal to
826Perl.)
827
828=head2 %Carp::CarpInternal
829
830This says which packages are internal to Perl's warning system. For
831generating a full stack backtrace this is the same as being internal
832to Perl, the stack backtrace will not start inside packages that are
833listed in C<%Carp::CarpInternal>. But it is slightly different for
834the summary message generated by C<carp> or C<croak>. There errors
835will not be reported on any lines that are calling packages in
836C<%Carp::CarpInternal>.
837
838For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
839Therefore the full stack backtrace from C<confess> will not start
840inside of C<Carp>, and the short message from calling C<croak> is
841not placed on the line where C<croak> was called.
842
843=head2 $Carp::CarpLevel
0cda2667 844
d735c2ef
BT
845This variable determines how many additional call frames are to be
846skipped that would not otherwise be when reporting where an error
847occurred on a call to one of C<Carp>'s functions. It is fairly easy
848to count these call frames on calls that generate a full stack
849backtrace. However it is much harder to do this accounting for calls
850that generate a short message. Usually people skip too many call
851frames. If they are lucky they skip enough that C<Carp> goes all of
852the way through the call stack, realizes that something is wrong, and
853then generates a full stack backtrace. If they are unlucky then the
854error is reported from somewhere misleading very high in the call
855stack.
856
857Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
3b46207f 858C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
0cda2667
DM
859
860Defaults to C<0>.
861
0cda2667
DM
862=head1 BUGS
863
864The Carp routines don't handle exception objects currently.
865If called with a first argument that is a reference, they simply
866call die() or warn(), as appropriate.
867
6ffbec2c
Z
868Some of the Carp code assumes that Perl's basic character encoding is
869ASCII, and will go wrong on an EBCDIC platform.
870
634ff085
Z
871=head1 SEE ALSO
872
873L<Carp::Always>,
874L<Carp::Clan>
875
876=head1 AUTHOR
877
878The Carp module first appeared in Larry Wall's perl 5.000 distribution.
879Since then it has been modified by several of the perl 5 porters.
880Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
881distribution.
882
883=head1 COPYRIGHT
884
3f2a9fa3 885Copyright (C) 1994-2013 Larry Wall
634ff085 886
3f2a9fa3 887Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
634ff085
Z
888
889=head1 LICENSE
890
891This module is free software; you can redistribute it and/or modify it
892under the same terms as Perl itself.