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
1 package Carp;
2
3 use strict;
4 use warnings;
5
6 our $VERSION = '1.20';
7
8 our $MaxEvalLen = 0;
9 our $Verbose    = 0;
10 our $CarpLevel  = 0;
11 our $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
12 our $MaxArgNums = 8;     # How many arguments to print. 0 = all.
13
14 require Exporter;
15 our @ISA       = ('Exporter');
16 our @EXPORT    = qw(confess croak carp);
17 our @EXPORT_OK = qw(cluck verbose longmess shortmess);
18 our @EXPORT_FAIL = qw(verbose);    # hook to enable verbose mode
19
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
29 our %CarpInternal;
30 our %Internal;
31
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
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
43 sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
44
45 sub _cgc {
46     no strict 'refs';
47     return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
48     return;
49 }
50
51 sub 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.
58     my $cgc = _cgc();
59     my $call_pack = $cgc ? $cgc->() : caller();
60     if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
61         return longmess_heavy(@_);
62     }
63     else {
64         local $CarpLevel = $CarpLevel + 1;
65         return longmess_heavy(@_);
66     }
67 }
68
69 our @CARP_NOT;
70
71 sub shortmess {
72     my $cgc = _cgc();
73
74     # Icky backwards compatibility wrapper. :-(
75     local @CARP_NOT = $cgc ? $cgc->() : caller();
76     shortmess_heavy(@_);
77 }
78
79 sub croak   { die shortmess @_ }
80 sub confess { die longmess @_ }
81 sub carp    { warn shortmess @_ }
82 sub cluck   { warn longmess @_ }
83
84 sub caller_info {
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);
94     }
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 ) . ')';
133     }
134     $call_info{sub_name} = $sub_name;
135     return wantarray() ? %call_info : \%call_info;
136 }
137
138 # Transform an argument to a function into a string.
139 sub format_arg {
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;
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.
167 sub get_status {
168     my $cache = shift;
169     my $pkg   = shift;
170     $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
171     return @{ $cache->{$pkg} };
172 }
173
174 # Takes the info from caller() and figures out the name of
175 # the sub/require/eval
176 sub get_subname {
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         }
187     }
188
189     return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
190 }
191
192 # Figures out what call (from the point of view of the caller)
193 # the long error backtrace should start at.
194 sub long_error_loc {
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};
218     }
219     return $i - 1;
220 }
221
222 sub longmess_heavy {
223     return @_ if ref( $_[0] );    # don't break references as exceptions
224     my $i = long_error_loc();
225     return ret_backtrace( $i, @_ );
226 }
227
228 # Returns a full stack backtrace starting from where it is
229 # told.
230 sub ret_backtrace {
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;
250 }
251
252 sub ret_summary {
253     my ( $i, @error ) = @_;
254     my $err = join '', @error;
255     $i++;
256
257     my $tid_msg = '';
258     if ( defined &threads::tid ) {
259         my $tid = threads->tid;
260         $tid_msg = " thread $tid" if $tid;
261     }
262
263     my %i = caller_info($i);
264     return "$err at $i{file} line $i{line}$tid_msg\n";
265 }
266
267 sub 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 }
290
291 sub shortmess_heavy {
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     }
301 }
302
303 # If a string is too long, trims it with ...
304 sub str_len_trim {
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;
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.
319 sub trusts {
320     my $child  = shift;
321     my $parent = shift;
322     my $cache  = shift;
323     my ( $known, $partial ) = get_status( $cache, $child );
324
325     # Figure out consequences until we have an answer
326     while ( @$partial and not exists $known->{$parent} ) {
327         my $anc = shift @$partial;
328         next if exists $known->{$anc};
329         $known->{$anc}++;
330         my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
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
339 sub trusts_directly {
340     my $class = shift;
341     no strict 'refs';
342     no warnings 'once';
343     return @{"$class\::CARP_NOT"}
344         ? @{"$class\::CARP_NOT"}
345         : @{"$class\::ISA"};
346 }
347
348 1;
349
350 __END__
351
352 =head1 NAME
353
354 carp    - warn of errors (from perspective of caller)
355
356 cluck   - warn of errors with stack backtrace
357           (not exported by default)
358
359 croak   - die of errors (from perspective of caller)
360
361 confess - die of errors with stack backtrace
362
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
371 =head1 DESCRIPTION
372
373 The Carp routines are useful in your own modules because
374 they act like die() or warn(), but with a message which is more
375 likely to be useful to a user of your module.  In the case of
376 cluck, confess, and longmess that context is a summary of every
377 call in the call-stack.  For a shorter message you can use C<carp>
378 or C<croak> which report the error as being from where your module
379 was called.  There is no guarantee that that is where the error
380 was, but it is a good educated guess.
381
382 You can also alter the way the output and logic of C<Carp> works, by
383 changing some global variables in the C<Carp> namespace. See the
384 section on C<GLOBAL VARIABLES> below.
385
386 Here is a more complete description of how C<carp> and C<croak> work.
387 What they do is search the call-stack for a function call stack where
388 they have not been told that there shouldn't be an error.  If every
389 call is marked safe, they give up and give a full stack backtrace
390 instead.  In other words they presume that the first likely looking
391 potential suspect is guilty.  Their rules for telling whether
392 a call shouldn't generate errors work as follows:
393
394 =over 4
395
396 =item 1.
397
398 Any call from a package to itself is safe.
399
400 =item 2.
401
402 Packages claim that there won't be errors on calls to or from
403 packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
404 (if that array is empty) C<@ISA>.  The ability to override what
405 @ISA says is new in 5.8.
406
407 =item 3.
408
409 The trust in item 2 is transitive.  If A trusts B, and B
410 trusts C, then A trusts C.  So if you do not override C<@ISA>
411 with C<@CARP_NOT>, then this trust relationship is identical to,
412 "inherits from".
413
414 =item 4.
415
416 Any call from an internal Perl module is safe.  (Nothing keeps
417 user modules from marking themselves as internal to Perl, but
418 this practice is discouraged.)
419
420 =item 5.
421
422 Any call to Perl's warning system (eg Carp itself) is safe.
423 (This rule is what keeps it from reporting the error at the
424 point where you call C<carp> or C<croak>.)
425
426 =item 6.
427
428 C<$Carp::CarpLevel> can be set to skip a fixed number of additional
429 call levels.  Using this is not recommended because it is very
430 difficult to get it to behave correctly.
431
432 =back
433
434 =head2 Forcing a Stack Trace
435
436 As a debugging aid, you can force Carp to treat a croak as a confess
437 and a carp as a cluck across I<all> modules. In other words, force a
438 detailed stack trace to be given.  This can be very helpful when trying
439 to understand why, or from where, a warning or error is being generated.
440
441 This 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
446 or by including the string C<-MCarp=verbose> in the PERL5OPT
447 environment variable.
448
449 Alternately, you can set the global variable C<$Carp::Verbose> to true.
450 See the C<GLOBAL VARIABLES> section below.
451
452 =head1 GLOBAL VARIABLES
453
454 =head2 $Carp::MaxEvalLen
455
456 This variable determines how many characters of a string-eval are to
457 be shown in the output. Use a value of C<0> to show all text.
458
459 Defaults to C<0>.
460
461 =head2 $Carp::MaxArgLen
462
463 This variable determines how many characters of each argument to a
464 function to print. Use a value of C<0> to show the full length of the
465 argument.
466
467 Defaults to C<64>.
468
469 =head2 $Carp::MaxArgNums
470
471 This variable determines how many arguments to each function to show.
472 Use a value of C<0> to show all arguments to a function call.
473
474 Defaults to C<8>.
475
476 =head2 $Carp::Verbose
477
478 This variable makes C<carp> and C<croak> generate stack backtraces
479 just like C<cluck> and C<confess>.  This is how C<use Carp 'verbose'>
480 is implemented internally.
481
482 Defaults to C<0>.
483
484 =head2 @CARP_NOT
485
486 This variable, I<in your package>, says which packages are I<not> to be
487 considered as the location of an error. The C<carp()> and C<cluck()>
488 functions will skip over callers when reporting where an error occurred.
489
490 NB: 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
501 Example 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
513 This would make C<Carp> report the error as coming from a caller not
514 in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
515
516 Also read the L</DESCRIPTION> section above, about how C<Carp> decides
517 where the error is reported from.
518
519 Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
520
521 Overrides C<Carp>'s use of C<@ISA>.
522
523 =head2 %Carp::Internal
524
525 This says what packages are internal to Perl.  C<Carp> will never
526 report an error as being from a line in a package that is internal to
527 Perl.  For example:
528
529     $Carp::Internal{ (__PACKAGE__) }++;
530     # time passes...
531     sub foo { ... or confess("whatever") };
532
533 would give a full stack backtrace starting from the first caller
534 outside of __PACKAGE__.  (Unless that package was also internal to
535 Perl.)
536
537 =head2 %Carp::CarpInternal
538
539 This says which packages are internal to Perl's warning system.  For
540 generating a full stack backtrace this is the same as being internal
541 to Perl, the stack backtrace will not start inside packages that are
542 listed in C<%Carp::CarpInternal>.  But it is slightly different for
543 the summary message generated by C<carp> or C<croak>.  There errors
544 will not be reported on any lines that are calling packages in
545 C<%Carp::CarpInternal>.
546
547 For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
548 Therefore the full stack backtrace from C<confess> will not start
549 inside of C<Carp>, and the short message from calling C<croak> is
550 not placed on the line where C<croak> was called.
551
552 =head2 $Carp::CarpLevel
553
554 This variable determines how many additional call frames are to be
555 skipped that would not otherwise be when reporting where an error
556 occurred on a call to one of C<Carp>'s functions.  It is fairly easy
557 to count these call frames on calls that generate a full stack
558 backtrace.  However it is much harder to do this accounting for calls
559 that generate a short message.  Usually people skip too many call
560 frames.  If they are lucky they skip enough that C<Carp> goes all of
561 the way through the call stack, realizes that something is wrong, and
562 then generates a full stack backtrace.  If they are unlucky then the
563 error is reported from somewhere misleading very high in the call
564 stack.
565
566 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
567 C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
568
569 Defaults to C<0>.
570
571 =head1 BUGS
572
573 The Carp routines don't handle exception objects currently.
574 If called with a first argument that is a reference, they simply
575 call die() or warn(), as appropriate.
576