This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
95503d3ff3c098ec82c418f1f56ac88a0360d138
[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.23';
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         eval {
293             die;
294         };
295         if($@ =~ /^Died at .*(, <.*?> line \d+).$/ ) {
296             $mess .= $1;
297         }
298     }
299     $mess .= "\n";
300
301     while ( my %i = caller_info( ++$i ) ) {
302         $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
303     }
304
305     return $mess;
306 }
307
308 sub ret_summary {
309     my ( $i, @error ) = @_;
310     my $err = join '', @error;
311     $i++;
312
313     my $tid_msg = '';
314     if ( defined &threads::tid ) {
315         my $tid = threads->tid;
316         $tid_msg = " thread $tid" if $tid;
317     }
318
319     my %i = caller_info($i);
320     return "$err at $i{file} line $i{line}$tid_msg\n";
321 }
322
323 sub short_error_loc {
324     # You have to create your (hash)ref out here, rather than defaulting it
325     # inside trusts *on a lexical*, as you want it to persist across calls.
326     # (You can default it on $_[2], but that gets messy)
327     my $cache = {};
328     my $i     = 1;
329     my $lvl   = $CarpLevel;
330     {
331         my $cgc = _cgc();
332         my $called = $cgc ? $cgc->($i) : caller($i);
333         $i++;
334         my $caller = $cgc ? $cgc->($i) : caller($i);
335
336         return 0 unless defined($caller);    # What happened?
337         redo if $Internal{$caller};
338         redo if $CarpInternal{$caller};
339         redo if $CarpInternal{$called};
340         redo if trusts( $called, $caller, $cache );
341         redo if trusts( $caller, $called, $cache );
342         redo unless 0 > --$lvl;
343     }
344     return $i - 1;
345 }
346
347 sub shortmess_heavy {
348     return longmess_heavy(@_) if $Verbose;
349     return @_ if ref( $_[0] );    # don't break references as exceptions
350     my $i = short_error_loc();
351     if ($i) {
352         ret_summary( $i, @_ );
353     }
354     else {
355         longmess_heavy(@_);
356     }
357 }
358
359 # If a string is too long, trims it with ...
360 sub str_len_trim {
361     my $str = shift;
362     my $max = shift || 0;
363     if ( 2 < $max and $max < length($str) ) {
364         substr( $str, $max - 3 ) = '...';
365     }
366     return $str;
367 }
368
369 # Takes two packages and an optional cache.  Says whether the
370 # first inherits from the second.
371 #
372 # Recursive versions of this have to work to avoid certain
373 # possible endless loops, and when following long chains of
374 # inheritance are less efficient.
375 sub trusts {
376     my $child  = shift;
377     my $parent = shift;
378     my $cache  = shift;
379     my ( $known, $partial ) = get_status( $cache, $child );
380
381     # Figure out consequences until we have an answer
382     while ( @$partial and not exists $known->{$parent} ) {
383         my $anc = shift @$partial;
384         next if exists $known->{$anc};
385         $known->{$anc}++;
386         my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
387         my @found = keys %$anc_knows;
388         @$known{@found} = ();
389         push @$partial, @$anc_partial;
390     }
391     return exists $known->{$parent};
392 }
393
394 # Takes a package and gives a list of those trusted directly
395 sub trusts_directly {
396     my $class = shift;
397     no strict 'refs';
398     no warnings 'once';
399     return @{"$class\::CARP_NOT"}
400         ? @{"$class\::CARP_NOT"}
401         : @{"$class\::ISA"};
402 }
403
404 1;
405
406 __END__
407
408 =head1 NAME
409
410 Carp - alternative warn and die for modules
411
412 =head1 SYNOPSIS
413
414     use Carp;
415
416     # warn user (from perspective of caller)
417     carp "string trimmed to 80 chars";
418
419     # die of errors (from perspective of caller)
420     croak "We're outta here!";
421
422     # die of errors with stack backtrace
423     confess "not implemented";
424
425     # cluck not exported by default
426     use Carp qw(cluck);
427     cluck "This is how we got here!";
428
429 =head1 DESCRIPTION
430
431 The Carp routines are useful in your own modules because
432 they act like die() or warn(), but with a message which is more
433 likely to be useful to a user of your module.  In the case of
434 cluck, confess, and longmess that context is a summary of every
435 call in the call-stack.  For a shorter message you can use C<carp>
436 or C<croak> which report the error as being from where your module
437 was called.  There is no guarantee that that is where the error
438 was, but it is a good educated guess.
439
440 You can also alter the way the output and logic of C<Carp> works, by
441 changing some global variables in the C<Carp> namespace. See the
442 section on C<GLOBAL VARIABLES> below.
443
444 Here is a more complete description of how C<carp> and C<croak> work.
445 What they do is search the call-stack for a function call stack where
446 they have not been told that there shouldn't be an error.  If every
447 call is marked safe, they give up and give a full stack backtrace
448 instead.  In other words they presume that the first likely looking
449 potential suspect is guilty.  Their rules for telling whether
450 a call shouldn't generate errors work as follows:
451
452 =over 4
453
454 =item 1.
455
456 Any call from a package to itself is safe.
457
458 =item 2.
459
460 Packages claim that there won't be errors on calls to or from
461 packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
462 (if that array is empty) C<@ISA>.  The ability to override what
463 @ISA says is new in 5.8.
464
465 =item 3.
466
467 The trust in item 2 is transitive.  If A trusts B, and B
468 trusts C, then A trusts C.  So if you do not override C<@ISA>
469 with C<@CARP_NOT>, then this trust relationship is identical to,
470 "inherits from".
471
472 =item 4.
473
474 Any call from an internal Perl module is safe.  (Nothing keeps
475 user modules from marking themselves as internal to Perl, but
476 this practice is discouraged.)
477
478 =item 5.
479
480 Any call to Perl's warning system (eg Carp itself) is safe.
481 (This rule is what keeps it from reporting the error at the
482 point where you call C<carp> or C<croak>.)
483
484 =item 6.
485
486 C<$Carp::CarpLevel> can be set to skip a fixed number of additional
487 call levels.  Using this is not recommended because it is very
488 difficult to get it to behave correctly.
489
490 =back
491
492 =head2 Forcing a Stack Trace
493
494 As a debugging aid, you can force Carp to treat a croak as a confess
495 and a carp as a cluck across I<all> modules. In other words, force a
496 detailed stack trace to be given.  This can be very helpful when trying
497 to understand why, or from where, a warning or error is being generated.
498
499 This feature is enabled by 'importing' the non-existent symbol
500 'verbose'. You would typically enable it by saying
501
502     perl -MCarp=verbose script.pl
503
504 or by including the string C<-MCarp=verbose> in the PERL5OPT
505 environment variable.
506
507 Alternately, you can set the global variable C<$Carp::Verbose> to true.
508 See the C<GLOBAL VARIABLES> section below.
509
510 =head1 GLOBAL VARIABLES
511
512 =head2 $Carp::MaxEvalLen
513
514 This variable determines how many characters of a string-eval are to
515 be shown in the output. Use a value of C<0> to show all text.
516
517 Defaults to C<0>.
518
519 =head2 $Carp::MaxArgLen
520
521 This variable determines how many characters of each argument to a
522 function to print. Use a value of C<0> to show the full length of the
523 argument.
524
525 Defaults to C<64>.
526
527 =head2 $Carp::MaxArgNums
528
529 This variable determines how many arguments to each function to show.
530 Use a value of C<0> to show all arguments to a function call.
531
532 Defaults to C<8>.
533
534 =head2 $Carp::Verbose
535
536 This variable makes C<carp> and C<croak> generate stack backtraces
537 just like C<cluck> and C<confess>.  This is how C<use Carp 'verbose'>
538 is implemented internally.
539
540 Defaults to C<0>.
541
542 =head2 @CARP_NOT
543
544 This variable, I<in your package>, says which packages are I<not> to be
545 considered as the location of an error. The C<carp()> and C<cluck()>
546 functions will skip over callers when reporting where an error occurred.
547
548 NB: This variable must be in the package's symbol table, thus:
549
550     # These work
551     our @CARP_NOT; # file scope
552     use vars qw(@CARP_NOT); # package scope
553     @My::Package::CARP_NOT = ... ; # explicit package variable
554
555     # These don't work
556     sub xyz { ... @CARP_NOT = ... } # w/o declarations above
557     my @CARP_NOT; # even at top-level
558
559 Example of use:
560
561     package My::Carping::Package;
562     use Carp;
563     our @CARP_NOT;
564     sub bar     { .... or _error('Wrong input') }
565     sub _error  {
566         # temporary control of where'ness, __PACKAGE__ is implicit
567         local @CARP_NOT = qw(My::Friendly::Caller);
568         carp(@_)
569     }
570
571 This would make C<Carp> report the error as coming from a caller not
572 in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
573
574 Also read the L</DESCRIPTION> section above, about how C<Carp> decides
575 where the error is reported from.
576
577 Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
578
579 Overrides C<Carp>'s use of C<@ISA>.
580
581 =head2 %Carp::Internal
582
583 This says what packages are internal to Perl.  C<Carp> will never
584 report an error as being from a line in a package that is internal to
585 Perl.  For example:
586
587     $Carp::Internal{ (__PACKAGE__) }++;
588     # time passes...
589     sub foo { ... or confess("whatever") };
590
591 would give a full stack backtrace starting from the first caller
592 outside of __PACKAGE__.  (Unless that package was also internal to
593 Perl.)
594
595 =head2 %Carp::CarpInternal
596
597 This says which packages are internal to Perl's warning system.  For
598 generating a full stack backtrace this is the same as being internal
599 to Perl, the stack backtrace will not start inside packages that are
600 listed in C<%Carp::CarpInternal>.  But it is slightly different for
601 the summary message generated by C<carp> or C<croak>.  There errors
602 will not be reported on any lines that are calling packages in
603 C<%Carp::CarpInternal>.
604
605 For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
606 Therefore the full stack backtrace from C<confess> will not start
607 inside of C<Carp>, and the short message from calling C<croak> is
608 not placed on the line where C<croak> was called.
609
610 =head2 $Carp::CarpLevel
611
612 This variable determines how many additional call frames are to be
613 skipped that would not otherwise be when reporting where an error
614 occurred on a call to one of C<Carp>'s functions.  It is fairly easy
615 to count these call frames on calls that generate a full stack
616 backtrace.  However it is much harder to do this accounting for calls
617 that generate a short message.  Usually people skip too many call
618 frames.  If they are lucky they skip enough that C<Carp> goes all of
619 the way through the call stack, realizes that something is wrong, and
620 then generates a full stack backtrace.  If they are unlucky then the
621 error is reported from somewhere misleading very high in the call
622 stack.
623
624 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
625 C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
626
627 Defaults to C<0>.
628
629 =head1 BUGS
630
631 The Carp routines don't handle exception objects currently.
632 If called with a first argument that is a reference, they simply
633 call die() or warn(), as appropriate.
634
635 =head1 SEE ALSO
636
637 L<Carp::Always>,
638 L<Carp::Clan>
639
640 =head1 AUTHOR
641
642 The Carp module first appeared in Larry Wall's perl 5.000 distribution.
643 Since then it has been modified by several of the perl 5 porters.
644 Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
645 distribution.
646
647 =head1 COPYRIGHT
648
649 Copyright (C) 1994-2011 Larry Wall
650
651 Copyright (C) 2011 Andrew Main (Zefram) <zefram@fysh.org>
652
653 =head1 LICENSE
654
655 This module is free software; you can redistribute it and/or modify it
656 under the same terms as Perl itself.