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
1 package Carp;
2
3 { use 5.006; }
4 use strict;
5 use warnings;
6
7 BEGIN {
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
17 BEGIN {
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
27 our $VERSION = '1.24';
28
29 our $MaxEvalLen = 0;
30 our $Verbose    = 0;
31 our $CarpLevel  = 0;
32 our $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
33 our $MaxArgNums = 8;     # How many arguments to print. 0 = all.
34
35 require Exporter;
36 our @ISA       = ('Exporter');
37 our @EXPORT    = qw(confess croak carp);
38 our @EXPORT_OK = qw(cluck verbose longmess shortmess);
39 our @EXPORT_FAIL = qw(verbose);    # hook to enable verbose mode
40
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
50 our %CarpInternal;
51 our %Internal;
52
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
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
64 sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
65
66 sub _cgc {
67     no strict 'refs';
68     return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
69     return;
70 }
71
72 sub 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.
79     my $cgc = _cgc();
80     my $call_pack = $cgc ? $cgc->() : caller();
81     if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
82         return longmess_heavy(@_);
83     }
84     else {
85         local $CarpLevel = $CarpLevel + 1;
86         return longmess_heavy(@_);
87     }
88 }
89
90 our @CARP_NOT;
91
92 sub shortmess {
93     my $cgc = _cgc();
94
95     # Icky backwards compatibility wrapper. :-(
96     local @CARP_NOT = $cgc ? $cgc->() : caller();
97     shortmess_heavy(@_);
98 }
99
100 sub croak   { die shortmess @_ }
101 sub confess { die longmess @_ }
102 sub carp    { warn shortmess @_ }
103 sub cluck   { warn longmess @_ }
104
105 BEGIN {
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
114 sub caller_info {
115     my $i = shift(@_) + 1;
116     my %call_info;
117     my $cgc = _cgc();
118     {
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;
127         package DB;
128         @call_info{
129             qw(pack file line sub has_args wantarray evaltext is_require) }
130             = $cgc ? $cgc->($i) : caller($i);
131     }
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;
140         if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
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 '';
147                 my $gv      =
148                     *{
149                         ( $::{"B::"} || return '')       # B stash
150                           ->{svref_2object} || return '' # entry in stash
151                      }{CODE}                             # coderef in entry
152                         ->($func)->GV;
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";
160             } || '';
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 ) . ')';
175     }
176     $call_info{sub_name} = $sub_name;
177     return wantarray() ? %call_info : \%call_info;
178 }
179
180 # Transform an argument to a function into a string.
181 sub format_arg {
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?
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.
194         downgrade($arg, 1);
195         $arg = "'$arg'" unless $arg =~ /^-?[0-9.]+\z/;
196     }
197     else {
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?
204     is_utf8($arg)
205         or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
206     return $arg;
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.
213 sub get_status {
214     my $cache = shift;
215     my $pkg   = shift;
216     $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
217     return @{ $cache->{$pkg} };
218 }
219
220 # Takes the info from caller() and figures out the name of
221 # the sub/require/eval
222 sub get_subname {
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         }
233     }
234
235     return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
236 }
237
238 # Figures out what call (from the point of view of the caller)
239 # the long error backtrace should start at.
240 sub long_error_loc {
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};
264     }
265     return $i - 1;
266 }
267
268 sub longmess_heavy {
269     return @_ if ref( $_[0] );    # don't break references as exceptions
270     my $i = long_error_loc();
271     return ret_backtrace( $i, @_ );
272 }
273
274 # Returns a full stack backtrace starting from where it is
275 # told.
276 sub ret_backtrace {
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);
289     $mess = "$err at $i{file} line $i{line}$tid_msg";
290     if( defined $. ) {
291         local $@ = '';
292         local $SIG{__DIE__};
293         eval {
294             die;
295         };
296         if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
297             $mess .= $1;
298         }
299     }
300     $mess .= "\n";
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;
307 }
308
309 sub ret_summary {
310     my ( $i, @error ) = @_;
311     my $err = join '', @error;
312     $i++;
313
314     my $tid_msg = '';
315     if ( defined &threads::tid ) {
316         my $tid = threads->tid;
317         $tid_msg = " thread $tid" if $tid;
318     }
319
320     my %i = caller_info($i);
321     return "$err at $i{file} line $i{line}$tid_msg\n";
322 }
323
324 sub 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 }
347
348 sub shortmess_heavy {
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     }
358 }
359
360 # If a string is too long, trims it with ...
361 sub str_len_trim {
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;
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.
376 sub trusts {
377     my $child  = shift;
378     my $parent = shift;
379     my $cache  = shift;
380     my ( $known, $partial ) = get_status( $cache, $child );
381
382     # Figure out consequences until we have an answer
383     while ( @$partial and not exists $known->{$parent} ) {
384         my $anc = shift @$partial;
385         next if exists $known->{$anc};
386         $known->{$anc}++;
387         my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
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
396 sub trusts_directly {
397     my $class = shift;
398     no strict 'refs';
399     no warnings 'once';
400     return @{"$class\::CARP_NOT"}
401         ? @{"$class\::CARP_NOT"}
402         : @{"$class\::ISA"};
403 }
404
405 1;
406
407 __END__
408
409 =head1 NAME
410
411 Carp - alternative warn and die for modules
412
413 =head1 SYNOPSIS
414
415     use Carp;
416
417     # warn user (from perspective of caller)
418     carp "string trimmed to 80 chars";
419
420     # die of errors (from perspective of caller)
421     croak "We're outta here!";
422
423     # die of errors with stack backtrace
424     confess "not implemented";
425
426     # cluck not exported by default
427     use Carp qw(cluck);
428     cluck "This is how we got here!";
429
430 =head1 DESCRIPTION
431
432 The Carp routines are useful in your own modules because
433 they act like die() or warn(), but with a message which is more
434 likely to be useful to a user of your module.  In the case of
435 cluck, confess, and longmess that context is a summary of every
436 call in the call-stack.  For a shorter message you can use C<carp>
437 or C<croak> which report the error as being from where your module
438 was called.  There is no guarantee that that is where the error
439 was, but it is a good educated guess.
440
441 You can also alter the way the output and logic of C<Carp> works, by
442 changing some global variables in the C<Carp> namespace. See the
443 section on C<GLOBAL VARIABLES> below.
444
445 Here is a more complete description of how C<carp> and C<croak> work.
446 What they do is search the call-stack for a function call stack where
447 they have not been told that there shouldn't be an error.  If every
448 call is marked safe, they give up and give a full stack backtrace
449 instead.  In other words they presume that the first likely looking
450 potential suspect is guilty.  Their rules for telling whether
451 a call shouldn't generate errors work as follows:
452
453 =over 4
454
455 =item 1.
456
457 Any call from a package to itself is safe.
458
459 =item 2.
460
461 Packages claim that there won't be errors on calls to or from
462 packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
463 (if that array is empty) C<@ISA>.  The ability to override what
464 @ISA says is new in 5.8.
465
466 =item 3.
467
468 The trust in item 2 is transitive.  If A trusts B, and B
469 trusts C, then A trusts C.  So if you do not override C<@ISA>
470 with C<@CARP_NOT>, then this trust relationship is identical to,
471 "inherits from".
472
473 =item 4.
474
475 Any call from an internal Perl module is safe.  (Nothing keeps
476 user modules from marking themselves as internal to Perl, but
477 this practice is discouraged.)
478
479 =item 5.
480
481 Any call to Perl's warning system (eg Carp itself) is safe.
482 (This rule is what keeps it from reporting the error at the
483 point where you call C<carp> or C<croak>.)
484
485 =item 6.
486
487 C<$Carp::CarpLevel> can be set to skip a fixed number of additional
488 call levels.  Using this is not recommended because it is very
489 difficult to get it to behave correctly.
490
491 =back
492
493 =head2 Forcing a Stack Trace
494
495 As a debugging aid, you can force Carp to treat a croak as a confess
496 and a carp as a cluck across I<all> modules. In other words, force a
497 detailed stack trace to be given.  This can be very helpful when trying
498 to understand why, or from where, a warning or error is being generated.
499
500 This 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
505 or by including the string C<-MCarp=verbose> in the PERL5OPT
506 environment variable.
507
508 Alternately, you can set the global variable C<$Carp::Verbose> to true.
509 See the C<GLOBAL VARIABLES> section below.
510
511 =head1 GLOBAL VARIABLES
512
513 =head2 $Carp::MaxEvalLen
514
515 This variable determines how many characters of a string-eval are to
516 be shown in the output. Use a value of C<0> to show all text.
517
518 Defaults to C<0>.
519
520 =head2 $Carp::MaxArgLen
521
522 This variable determines how many characters of each argument to a
523 function to print. Use a value of C<0> to show the full length of the
524 argument.
525
526 Defaults to C<64>.
527
528 =head2 $Carp::MaxArgNums
529
530 This variable determines how many arguments to each function to show.
531 Use a value of C<0> to show all arguments to a function call.
532
533 Defaults to C<8>.
534
535 =head2 $Carp::Verbose
536
537 This variable makes C<carp> and C<croak> generate stack backtraces
538 just like C<cluck> and C<confess>.  This is how C<use Carp 'verbose'>
539 is implemented internally.
540
541 Defaults to C<0>.
542
543 =head2 @CARP_NOT
544
545 This variable, I<in your package>, says which packages are I<not> to be
546 considered as the location of an error. The C<carp()> and C<cluck()>
547 functions will skip over callers when reporting where an error occurred.
548
549 NB: 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
560 Example 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
572 This would make C<Carp> report the error as coming from a caller not
573 in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
574
575 Also read the L</DESCRIPTION> section above, about how C<Carp> decides
576 where the error is reported from.
577
578 Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
579
580 Overrides C<Carp>'s use of C<@ISA>.
581
582 =head2 %Carp::Internal
583
584 This says what packages are internal to Perl.  C<Carp> will never
585 report an error as being from a line in a package that is internal to
586 Perl.  For example:
587
588     $Carp::Internal{ (__PACKAGE__) }++;
589     # time passes...
590     sub foo { ... or confess("whatever") };
591
592 would give a full stack backtrace starting from the first caller
593 outside of __PACKAGE__.  (Unless that package was also internal to
594 Perl.)
595
596 =head2 %Carp::CarpInternal
597
598 This says which packages are internal to Perl's warning system.  For
599 generating a full stack backtrace this is the same as being internal
600 to Perl, the stack backtrace will not start inside packages that are
601 listed in C<%Carp::CarpInternal>.  But it is slightly different for
602 the summary message generated by C<carp> or C<croak>.  There errors
603 will not be reported on any lines that are calling packages in
604 C<%Carp::CarpInternal>.
605
606 For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
607 Therefore the full stack backtrace from C<confess> will not start
608 inside of C<Carp>, and the short message from calling C<croak> is
609 not placed on the line where C<croak> was called.
610
611 =head2 $Carp::CarpLevel
612
613 This variable determines how many additional call frames are to be
614 skipped that would not otherwise be when reporting where an error
615 occurred on a call to one of C<Carp>'s functions.  It is fairly easy
616 to count these call frames on calls that generate a full stack
617 backtrace.  However it is much harder to do this accounting for calls
618 that generate a short message.  Usually people skip too many call
619 frames.  If they are lucky they skip enough that C<Carp> goes all of
620 the way through the call stack, realizes that something is wrong, and
621 then generates a full stack backtrace.  If they are unlucky then the
622 error is reported from somewhere misleading very high in the call
623 stack.
624
625 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
626 C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
627
628 Defaults to C<0>.
629
630 =head1 BUGS
631
632 The Carp routines don't handle exception objects currently.
633 If called with a first argument that is a reference, they simply
634 call die() or warn(), as appropriate.
635
636 =head1 SEE ALSO
637
638 L<Carp::Always>,
639 L<Carp::Clan>
640
641 =head1 AUTHOR
642
643 The Carp module first appeared in Larry Wall's perl 5.000 distribution.
644 Since then it has been modified by several of the perl 5 porters.
645 Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
646 distribution.
647
648 =head1 COPYRIGHT
649
650 Copyright (C) 1994-2011 Larry Wall
651
652 Copyright (C) 2011 Andrew Main (Zefram) <zefram@fysh.org>
653
654 =head1 LICENSE
655
656 This module is free software; you can redistribute it and/or modify it
657 under the same terms as Perl itself.