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