This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Carp.pm localise $SIG{__DIE__} before eval
[perl5.git] / dist / Carp / lib / Carp.pm
CommitLineData
a0d0e21e 1package Carp;
8c3d9721 2
634ff085 3{ use 5.006; }
01ca8b68
DR
4use strict;
5use warnings;
6
40c2103f
Z
7BEGIN {
8 no strict "refs";
9 if(exists($::{"utf8::"}) && exists($utf8::{"is_utf8"}) &&
10 defined(*{"utf8::is_utf8"}{CODE})) {
11 *is_utf8 = \&{"utf8::is_utf8"};
12 } else {
13 *is_utf8 = sub { 0 };
14 }
15}
16
17BEGIN {
18 no strict "refs";
19 if(exists($::{"utf8::"}) && exists($utf8::{"downgrade"}) &&
20 defined(*{"utf8::downgrade"}{CODE})) {
21 *downgrade = \&{"utf8::downgrade"};
22 } else {
23 *downgrade = sub {};
24 }
25}
26
0ae11017 27our $VERSION = '1.24';
b75c8c73 28
8c3d9721
DM
29our $MaxEvalLen = 0;
30our $Verbose = 0;
31our $CarpLevel = 0;
d38ea511
DR
32our $MaxArgLen = 64; # How much of each argument to print. 0 = all.
33our $MaxArgNums = 8; # How many arguments to print. 0 = all.
748a9306 34
a0d0e21e 35require Exporter;
d38ea511
DR
36our @ISA = ('Exporter');
37our @EXPORT = qw(confess croak carp);
8c3d9721 38our @EXPORT_OK = qw(cluck verbose longmess shortmess);
d38ea511 39our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
af80c6a7 40
ba7a4549
RGS
41# The members of %Internal are packages that are internal to perl.
42# Carp will not report errors from within these packages if it
43# can. The members of %CarpInternal are internal to Perl's warning
44# system. Carp will not report errors from within these packages
45# either, and will not report calls *to* these packages for carp and
46# croak. They replace $CarpLevel, which is deprecated. The
47# $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
48# text and function arguments should be formatted when printed.
49
01ca8b68
DR
50our %CarpInternal;
51our %Internal;
52
ba7a4549
RGS
53# disable these by default, so they can live w/o require Carp
54$CarpInternal{Carp}++;
55$CarpInternal{warnings}++;
56$Internal{Exporter}++;
57$Internal{'Exporter::Heavy'}++;
58
af80c6a7
JH
59# if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
60# then the following method will be called by the Exporter which knows
61# to do this thanks to @EXPORT_FAIL, above. $_[1] will contain the word
62# 'verbose'.
63
29ddba3b 64sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
7b8d334a 65
01ca8b68
DR
66sub _cgc {
67 no strict 'refs';
68 return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
69 return;
70}
71
ba7a4549
RGS
72sub longmess {
73 # Icky backwards compatibility wrapper. :-(
74 #
75 # The story is that the original implementation hard-coded the
76 # number of call levels to go back, so calls to longmess were off
77 # by one. Other code began calling longmess and expecting this
78 # behaviour, so the replacement has to emulate that behaviour.
01ca8b68
DR
79 my $cgc = _cgc();
80 my $call_pack = $cgc ? $cgc->() : caller();
d38ea511
DR
81 if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
82 return longmess_heavy(@_);
ba7a4549
RGS
83 }
84 else {
d38ea511
DR
85 local $CarpLevel = $CarpLevel + 1;
86 return longmess_heavy(@_);
ba7a4549 87 }
d38ea511 88}
ba7a4549 89
01ca8b68 90our @CARP_NOT;
d38ea511 91
ba7a4549 92sub shortmess {
01ca8b68 93 my $cgc = _cgc();
d38ea511 94
ba7a4549 95 # Icky backwards compatibility wrapper. :-(
01ca8b68 96 local @CARP_NOT = $cgc ? $cgc->() : caller();
ba7a4549 97 shortmess_heavy(@_);
d38ea511 98}
7b8d334a 99
d38ea511
DR
100sub croak { die shortmess @_ }
101sub confess { die longmess @_ }
7b8d334a 102sub carp { warn shortmess @_ }
d38ea511 103sub cluck { warn longmess @_ }
a0d0e21e 104
40c2103f
Z
105BEGIN {
106 if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
107 ("$]" >= 5.012005 && "$]" < 5.013)) {
108 *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
109 } else {
110 *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
111 }
112}
113
ba7a4549 114sub caller_info {
d38ea511
DR
115 my $i = shift(@_) + 1;
116 my %call_info;
117 my $cgc = _cgc();
118 {
40c2103f
Z
119 # Some things override caller() but forget to implement the
120 # @DB::args part of it, which we need. We check for this by
121 # pre-populating @DB::args with a sentinel which no-one else
122 # has the address of, so that we can detect whether @DB::args
123 # has been properly populated. However, on earlier versions
124 # of perl this check tickles a bug in CORE::caller() which
125 # leaks memory. So we only check on fixed perls.
126 @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
d38ea511 127 package DB;
d38ea511
DR
128 @call_info{
129 qw(pack file line sub has_args wantarray evaltext is_require) }
130 = $cgc ? $cgc->($i) : caller($i);
eff7e72c 131 }
d38ea511
DR
132
133 unless ( defined $call_info{pack} ) {
134 return ();
135 }
136
137 my $sub_name = Carp::get_subname( \%call_info );
138 if ( $call_info{has_args} ) {
139 my @args;
40c2103f 140 if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
d38ea511
DR
141 && ref $DB::args[0] eq ref \$i
142 && $DB::args[0] == \$i ) {
143 @DB::args = (); # Don't let anyone see the address of $i
144 local $@;
145 my $where = eval {
146 my $func = $cgc or return '';
1a6d5308
FC
147 my $gv =
148 *{
149 ( $::{"B::"} || return '') # B stash
150 ->{svref_2object} || return '' # entry in stash
151 }{CODE} # coderef in entry
152 ->($func)->GV;
d38ea511
DR
153 my $package = $gv->STASH->NAME;
154 my $subname = $gv->NAME;
155 return unless defined $package && defined $subname;
156
157 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
158 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
159 " in &${package}::$subname";
634ff085 160 } || '';
d38ea511
DR
161 @args
162 = "** Incomplete caller override detected$where; \@DB::args were not set **";
163 }
164 else {
165 @args = map { Carp::format_arg($_) } @DB::args;
166 }
167 if ( $MaxArgNums and @args > $MaxArgNums )
168 { # More than we want to show?
169 $#args = $MaxArgNums;
170 push @args, '...';
171 }
172
173 # Push the args onto the subroutine
174 $sub_name .= '(' . join( ', ', @args ) . ')';
ba7a4549 175 }
d38ea511
DR
176 $call_info{sub_name} = $sub_name;
177 return wantarray() ? %call_info : \%call_info;
ba7a4549
RGS
178}
179
180# Transform an argument to a function into a string.
181sub format_arg {
d38ea511
DR
182 my $arg = shift;
183 if ( ref($arg) ) {
184 $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
185 }
186 if ( defined($arg) ) {
187 $arg =~ s/'/\\'/g;
188 $arg = str_len_trim( $arg, $MaxArgLen );
189
190 # Quote it?
634ff085
Z
191 # Downgrade, and use [0-9] rather than \d, to avoid loading
192 # Unicode tables, which would be liable to fail if we're
193 # processing a syntax error.
40c2103f 194 downgrade($arg, 1);
018c7c82 195 $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
634ff085
Z
196 }
197 else {
d38ea511
DR
198 $arg = 'undef';
199 }
200
201 # The following handling of "control chars" is direct from
202 # the original code - it is broken on Unicode though.
203 # Suggestions?
40c2103f 204 is_utf8($arg)
d38ea511
DR
205 or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
206 return $arg;
ba7a4549
RGS
207}
208
209# Takes an inheritance cache and a package and returns
210# an anon hash of known inheritances and anon array of
211# inheritances which consequences have not been figured
212# for.
213sub get_status {
214 my $cache = shift;
d38ea511
DR
215 my $pkg = shift;
216 $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
217 return @{ $cache->{$pkg} };
ba7a4549
RGS
218}
219
220# Takes the info from caller() and figures out the name of
221# the sub/require/eval
222sub get_subname {
d38ea511
DR
223 my $info = shift;
224 if ( defined( $info->{evaltext} ) ) {
225 my $eval = $info->{evaltext};
226 if ( $info->{is_require} ) {
227 return "require $eval";
228 }
229 else {
230 $eval =~ s/([\\\'])/\\$1/g;
231 return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
232 }
ba7a4549 233 }
ba7a4549 234
d38ea511 235 return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
ba7a4549
RGS
236}
237
238# Figures out what call (from the point of view of the caller)
239# the long error backtrace should start at.
240sub long_error_loc {
d38ea511
DR
241 my $i;
242 my $lvl = $CarpLevel;
243 {
244 ++$i;
245 my $cgc = _cgc();
246 my $pkg = $cgc ? $cgc->($i) : caller($i);
247 unless ( defined($pkg) ) {
248
249 # This *shouldn't* happen.
250 if (%Internal) {
251 local %Internal;
252 $i = long_error_loc();
253 last;
254 }
255 else {
256
257 # OK, now I am irritated.
258 return 2;
259 }
260 }
261 redo if $CarpInternal{$pkg};
262 redo unless 0 > --$lvl;
263 redo if $Internal{$pkg};
ba7a4549 264 }
d38ea511 265 return $i - 1;
ba7a4549
RGS
266}
267
ba7a4549 268sub longmess_heavy {
d38ea511
DR
269 return @_ if ref( $_[0] ); # don't break references as exceptions
270 my $i = long_error_loc();
271 return ret_backtrace( $i, @_ );
ba7a4549
RGS
272}
273
274# Returns a full stack backtrace starting from where it is
275# told.
276sub ret_backtrace {
d38ea511
DR
277 my ( $i, @error ) = @_;
278 my $mess;
279 my $err = join '', @error;
280 $i++;
281
282 my $tid_msg = '';
283 if ( defined &threads::tid ) {
284 my $tid = threads->tid;
285 $tid_msg = " thread $tid" if $tid;
286 }
287
288 my %i = caller_info($i);
89988fbd 289 $mess = "$err at $i{file} line $i{line}$tid_msg";
290 if( defined $. ) {
291 local $@ = '';
63a756fa 292 local $SIG{__DIE__};
89988fbd 293 eval {
294 die;
295 };
296 if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
297 $mess .= $1;
298 }
299 }
300 $mess .= "\n";
d38ea511
DR
301
302 while ( my %i = caller_info( ++$i ) ) {
303 $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
304 }
305
306 return $mess;
ba7a4549
RGS
307}
308
309sub ret_summary {
d38ea511
DR
310 my ( $i, @error ) = @_;
311 my $err = join '', @error;
312 $i++;
ba7a4549 313
d38ea511
DR
314 my $tid_msg = '';
315 if ( defined &threads::tid ) {
316 my $tid = threads->tid;
317 $tid_msg = " thread $tid" if $tid;
318 }
ba7a4549 319
d38ea511
DR
320 my %i = caller_info($i);
321 return "$err at $i{file} line $i{line}$tid_msg\n";
ba7a4549
RGS
322}
323
d38ea511
DR
324sub short_error_loc {
325 # You have to create your (hash)ref out here, rather than defaulting it
326 # inside trusts *on a lexical*, as you want it to persist across calls.
327 # (You can default it on $_[2], but that gets messy)
328 my $cache = {};
329 my $i = 1;
330 my $lvl = $CarpLevel;
331 {
332 my $cgc = _cgc();
333 my $called = $cgc ? $cgc->($i) : caller($i);
334 $i++;
335 my $caller = $cgc ? $cgc->($i) : caller($i);
336
337 return 0 unless defined($caller); # What happened?
338 redo if $Internal{$caller};
339 redo if $CarpInternal{$caller};
340 redo if $CarpInternal{$called};
341 redo if trusts( $called, $caller, $cache );
342 redo if trusts( $caller, $called, $cache );
343 redo unless 0 > --$lvl;
344 }
345 return $i - 1;
346}
ba7a4549
RGS
347
348sub shortmess_heavy {
d38ea511
DR
349 return longmess_heavy(@_) if $Verbose;
350 return @_ if ref( $_[0] ); # don't break references as exceptions
351 my $i = short_error_loc();
352 if ($i) {
353 ret_summary( $i, @_ );
354 }
355 else {
356 longmess_heavy(@_);
357 }
ba7a4549
RGS
358}
359
360# If a string is too long, trims it with ...
361sub str_len_trim {
d38ea511
DR
362 my $str = shift;
363 my $max = shift || 0;
364 if ( 2 < $max and $max < length($str) ) {
365 substr( $str, $max - 3 ) = '...';
366 }
367 return $str;
ba7a4549
RGS
368}
369
370# Takes two packages and an optional cache. Says whether the
371# first inherits from the second.
372#
373# Recursive versions of this have to work to avoid certain
374# possible endless loops, and when following long chains of
375# inheritance are less efficient.
376sub trusts {
d38ea511 377 my $child = shift;
ba7a4549 378 my $parent = shift;
d38ea511
DR
379 my $cache = shift;
380 my ( $known, $partial ) = get_status( $cache, $child );
381
ba7a4549 382 # Figure out consequences until we have an answer
d38ea511 383 while ( @$partial and not exists $known->{$parent} ) {
ba7a4549
RGS
384 my $anc = shift @$partial;
385 next if exists $known->{$anc};
386 $known->{$anc}++;
d38ea511 387 my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
ba7a4549
RGS
388 my @found = keys %$anc_knows;
389 @$known{@found} = ();
390 push @$partial, @$anc_partial;
391 }
392 return exists $known->{$parent};
393}
394
395# Takes a package and gives a list of those trusted directly
396sub trusts_directly {
397 my $class = shift;
398 no strict 'refs';
d38ea511 399 no warnings 'once';
ba7a4549 400 return @{"$class\::CARP_NOT"}
d38ea511
DR
401 ? @{"$class\::CARP_NOT"}
402 : @{"$class\::ISA"};
ba7a4549
RGS
403}
404
748a9306 4051;
ba7a4549 406
0cda2667
DM
407__END__
408
409=head1 NAME
410
aaca3d9d 411Carp - alternative warn and die for modules
0cda2667 412
0cda2667
DM
413=head1 SYNOPSIS
414
415 use Carp;
aaca3d9d
MS
416
417 # warn user (from perspective of caller)
418 carp "string trimmed to 80 chars";
419
420 # die of errors (from perspective of caller)
0cda2667
DM
421 croak "We're outta here!";
422
aaca3d9d
MS
423 # die of errors with stack backtrace
424 confess "not implemented";
425
426 # cluck not exported by default
0cda2667
DM
427 use Carp qw(cluck);
428 cluck "This is how we got here!";
429
0cda2667
DM
430=head1 DESCRIPTION
431
432The Carp routines are useful in your own modules because
433they act like die() or warn(), but with a message which is more
434likely to be useful to a user of your module. In the case of
435cluck, confess, and longmess that context is a summary of every
d735c2ef
BT
436call in the call-stack. For a shorter message you can use C<carp>
437or C<croak> which report the error as being from where your module
438was called. There is no guarantee that that is where the error
439was, but it is a good educated guess.
0cda2667
DM
440
441You can also alter the way the output and logic of C<Carp> works, by
442changing some global variables in the C<Carp> namespace. See the
443section on C<GLOBAL VARIABLES> below.
444
3b46207f 445Here is a more complete description of how C<carp> and C<croak> work.
d735c2ef
BT
446What they do is search the call-stack for a function call stack where
447they have not been told that there shouldn't be an error. If every
448call is marked safe, they give up and give a full stack backtrace
449instead. In other words they presume that the first likely looking
450potential suspect is guilty. Their rules for telling whether
0cda2667
DM
451a call shouldn't generate errors work as follows:
452
453=over 4
454
455=item 1.
456
457Any call from a package to itself is safe.
458
459=item 2.
460
461Packages claim that there won't be errors on calls to or from
d735c2ef
BT
462packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
463(if that array is empty) C<@ISA>. The ability to override what
0cda2667
DM
464@ISA says is new in 5.8.
465
466=item 3.
467
468The trust in item 2 is transitive. If A trusts B, and B
d735c2ef
BT
469trusts C, then A trusts C. So if you do not override C<@ISA>
470with C<@CARP_NOT>, then this trust relationship is identical to,
0cda2667
DM
471"inherits from".
472
473=item 4.
474
475Any call from an internal Perl module is safe. (Nothing keeps
476user modules from marking themselves as internal to Perl, but
477this practice is discouraged.)
478
479=item 5.
480
d735c2ef
BT
481Any call to Perl's warning system (eg Carp itself) is safe.
482(This rule is what keeps it from reporting the error at the
483point where you call C<carp> or C<croak>.)
484
485=item 6.
486
487C<$Carp::CarpLevel> can be set to skip a fixed number of additional
488call levels. Using this is not recommended because it is very
489difficult to get it to behave correctly.
0cda2667
DM
490
491=back
492
493=head2 Forcing a Stack Trace
494
495As a debugging aid, you can force Carp to treat a croak as a confess
496and a carp as a cluck across I<all> modules. In other words, force a
497detailed stack trace to be given. This can be very helpful when trying
498to understand why, or from where, a warning or error is being generated.
499
500This feature is enabled by 'importing' the non-existent symbol
501'verbose'. You would typically enable it by saying
502
503 perl -MCarp=verbose script.pl
504
11ed4d01 505or by including the string C<-MCarp=verbose> in the PERL5OPT
0cda2667
DM
506environment variable.
507
508Alternately, you can set the global variable C<$Carp::Verbose> to true.
509See the C<GLOBAL VARIABLES> section below.
510
511=head1 GLOBAL VARIABLES
512
0cda2667
DM
513=head2 $Carp::MaxEvalLen
514
515This variable determines how many characters of a string-eval are to
516be shown in the output. Use a value of C<0> to show all text.
517
518Defaults to C<0>.
519
520=head2 $Carp::MaxArgLen
521
522This variable determines how many characters of each argument to a
523function to print. Use a value of C<0> to show the full length of the
524argument.
525
526Defaults to C<64>.
527
528=head2 $Carp::MaxArgNums
529
530This variable determines how many arguments to each function to show.
531Use a value of C<0> to show all arguments to a function call.
532
533Defaults to C<8>.
534
535=head2 $Carp::Verbose
536
23fab7a5 537This variable makes C<carp> and C<croak> generate stack backtraces
d735c2ef
BT
538just like C<cluck> and C<confess>. This is how C<use Carp 'verbose'>
539is implemented internally.
540
541Defaults to C<0>.
542
b60d6605
AG
543=head2 @CARP_NOT
544
545This variable, I<in your package>, says which packages are I<not> to be
546considered as the location of an error. The C<carp()> and C<cluck()>
547functions will skip over callers when reporting where an error occurred.
548
549NB: This variable must be in the package's symbol table, thus:
550
551 # These work
552 our @CARP_NOT; # file scope
553 use vars qw(@CARP_NOT); # package scope
554 @My::Package::CARP_NOT = ... ; # explicit package variable
555
556 # These don't work
557 sub xyz { ... @CARP_NOT = ... } # w/o declarations above
558 my @CARP_NOT; # even at top-level
559
560Example of use:
561
562 package My::Carping::Package;
563 use Carp;
564 our @CARP_NOT;
565 sub bar { .... or _error('Wrong input') }
566 sub _error {
567 # temporary control of where'ness, __PACKAGE__ is implicit
568 local @CARP_NOT = qw(My::Friendly::Caller);
569 carp(@_)
570 }
571
572This would make C<Carp> report the error as coming from a caller not
573in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
574
345e2394 575Also read the L</DESCRIPTION> section above, about how C<Carp> decides
b60d6605
AG
576where the error is reported from.
577
578Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
579
580Overrides C<Carp>'s use of C<@ISA>.
581
d735c2ef
BT
582=head2 %Carp::Internal
583
584This says what packages are internal to Perl. C<Carp> will never
585report an error as being from a line in a package that is internal to
586Perl. For example:
587
2a6a7022 588 $Carp::Internal{ (__PACKAGE__) }++;
d735c2ef
BT
589 # time passes...
590 sub foo { ... or confess("whatever") };
591
592would give a full stack backtrace starting from the first caller
593outside of __PACKAGE__. (Unless that package was also internal to
594Perl.)
595
596=head2 %Carp::CarpInternal
597
598This says which packages are internal to Perl's warning system. For
599generating a full stack backtrace this is the same as being internal
600to Perl, the stack backtrace will not start inside packages that are
601listed in C<%Carp::CarpInternal>. But it is slightly different for
602the summary message generated by C<carp> or C<croak>. There errors
603will not be reported on any lines that are calling packages in
604C<%Carp::CarpInternal>.
605
606For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
607Therefore the full stack backtrace from C<confess> will not start
608inside of C<Carp>, and the short message from calling C<croak> is
609not placed on the line where C<croak> was called.
610
611=head2 $Carp::CarpLevel
0cda2667 612
d735c2ef
BT
613This variable determines how many additional call frames are to be
614skipped that would not otherwise be when reporting where an error
615occurred on a call to one of C<Carp>'s functions. It is fairly easy
616to count these call frames on calls that generate a full stack
617backtrace. However it is much harder to do this accounting for calls
618that generate a short message. Usually people skip too many call
619frames. If they are lucky they skip enough that C<Carp> goes all of
620the way through the call stack, realizes that something is wrong, and
621then generates a full stack backtrace. If they are unlucky then the
622error is reported from somewhere misleading very high in the call
623stack.
624
625Therefore it is best to avoid C<$Carp::CarpLevel>. Instead use
3b46207f 626C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
0cda2667
DM
627
628Defaults to C<0>.
629
0cda2667
DM
630=head1 BUGS
631
632The Carp routines don't handle exception objects currently.
633If called with a first argument that is a reference, they simply
634call die() or warn(), as appropriate.
635
634ff085
Z
636=head1 SEE ALSO
637
638L<Carp::Always>,
639L<Carp::Clan>
640
641=head1 AUTHOR
642
643The Carp module first appeared in Larry Wall's perl 5.000 distribution.
644Since then it has been modified by several of the perl 5 porters.
645Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
646distribution.
647
648=head1 COPYRIGHT
649
650Copyright (C) 1994-2011 Larry Wall
651
652Copyright (C) 2011 Andrew Main (Zefram) <zefram@fysh.org>
653
654=head1 LICENSE
655
656This module is free software; you can redistribute it and/or modify it
657under the same terms as Perl itself.