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