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