This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Speed up Carp.pm when backtrace arguments are references
[perl5.git] / dist / Carp / lib / Carp.pm
1 package Carp;
2
3 { use 5.006; }
4 use strict;
5 use warnings;
6 BEGIN {
7     # Very old versions of warnings.pm load Carp.  This can go wrong due
8     # to the circular dependency.  If warnings is invoked before Carp,
9     # then warnings starts by loading Carp, then Carp (above) tries to
10     # invoke warnings, and gets nothing because warnings is in the process
11     # of loading and hasn't defined its import method yet.  If we were
12     # only turning on warnings ("use warnings" above) this wouldn't be too
13     # bad, because Carp would just gets the state of the -w switch and so
14     # might not get some warnings that it wanted.  The real problem is
15     # that we then want to turn off Unicode warnings, but "no warnings
16     # 'utf8'" won't be effective if we're in this circular-dependency
17     # situation.  So, if warnings.pm is an affected version, we turn
18     # off all warnings ourselves by directly setting ${^WARNING_BITS}.
19     # On unaffected versions, we turn off just Unicode warnings, via
20     # the proper API.
21     if(!defined($warnings::VERSION) || eval($warnings::VERSION) < 1.06) {
22         ${^WARNING_BITS} = "";
23     } else {
24         "warnings"->unimport("utf8");
25     }
26 }
27
28 sub _fetch_sub { # fetch sub without autovivifying
29     my($pack, $sub) = @_;
30     $pack .= '::';
31     # only works with top-level packages
32     return unless exists($::{$pack});
33     for ($::{$pack}) {
34         return unless ref \$_ eq 'GLOB' && *$_{HASH} && exists $$_{$sub};
35         for ($$_{$sub}) {
36             return ref \$_ eq 'GLOB' ? *$_{CODE} : undef
37         }
38     }
39 }
40
41 # UTF8_REGEXP_PROBLEM is a compile-time constant indicating whether Carp
42 # must avoid applying a regular expression to an upgraded (is_utf8)
43 # string.  There are multiple problems, on different Perl versions,
44 # that require this to be avoided.  All versions prior to 5.13.8 will
45 # load utf8_heavy.pl for the swash system, even if the regexp doesn't
46 # use character classes.  Perl 5.6 and Perls [5.11.2, 5.13.11) exhibit
47 # specific problems when Carp is being invoked in the aftermath of a
48 # syntax error.
49 BEGIN {
50     if("$]" < 5.013011) {
51         *UTF8_REGEXP_PROBLEM = sub () { 1 };
52     } else {
53         *UTF8_REGEXP_PROBLEM = sub () { 0 };
54     }
55 }
56
57 # is_utf8() is essentially the utf8::is_utf8() function, which indicates
58 # whether a string is represented in the upgraded form (using UTF-8
59 # internally).  As utf8::is_utf8() is only available from Perl 5.8
60 # onwards, extra effort is required here to make it work on Perl 5.6.
61 BEGIN {
62     if(defined(my $sub = _fetch_sub utf8 => 'is_utf8')) {
63         *is_utf8 = $sub;
64     } else {
65         # black magic for perl 5.6
66         *is_utf8 = sub { unpack("C", "\xaa".$_[0]) != 170 };
67     }
68 }
69
70 # The downgrade() function defined here is to be used for attempts to
71 # downgrade where it is acceptable to fail.  It must be called with a
72 # second argument that is a true value.
73 BEGIN {
74     if(defined(my $sub = _fetch_sub utf8 => 'downgrade')) {
75         *downgrade = \&{"utf8::downgrade"};
76     } else {
77         *downgrade = sub {
78             my $r = "";
79             my $l = length($_[0]);
80             for(my $i = 0; $i != $l; $i++) {
81                 my $o = ord(substr($_[0], $i, 1));
82                 return if $o > 255;
83                 $r .= chr($o);
84             }
85             $_[0] = $r;
86         };
87     }
88 }
89
90 # is_safe_printable_codepoint() indicates whether a character, specified
91 # by integer codepoint, is OK to output literally in a trace.  Generally
92 # this is if it is a printable character in the ancestral character set
93 # (ASCII or EBCDIC).  This is used on some Perls in situations where a
94 # regexp can't be used.
95 BEGIN {
96     *is_safe_printable_codepoint =
97         "$]" >= 5.007_003 ?
98             eval(q(sub ($) {
99                 my $u = utf8::native_to_unicode($_[0]);
100                 $u >= 0x20 && $u <= 0x7e;
101             }))
102         : ord("A") == 65 ?
103             sub ($) { $_[0] >= 0x20 && $_[0] <= 0x7e }
104         :
105             sub ($) {
106                 # Early EBCDIC
107                 # 3 EBCDIC code pages supported then;  all controls but one
108                 # are the code points below SPACE.  The other one is 0x5F on
109                 # POSIX-BC; FF on the other two.
110                 # FIXME: there are plenty of unprintable codepoints other
111                 # than those that this code and the comment above identifies
112                 # as "controls".
113                 $_[0] >= ord(" ") && $_[0] <= 0xff &&
114                     $_[0] != (ord ("^") == 106 ? 0x5f : 0xff);
115             }
116         ;
117 }
118
119 our $VERSION = '1.44';
120 $VERSION =~ tr/_//d;
121
122 our $MaxEvalLen = 0;
123 our $Verbose    = 0;
124 our $CarpLevel  = 0;
125 our $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
126 our $MaxArgNums = 8;     # How many arguments to print. 0 = all.
127 our $RefArgFormatter = undef; # allow caller to format reference arguments
128
129 require Exporter;
130 our @ISA       = ('Exporter');
131 our @EXPORT    = qw(confess croak carp);
132 our @EXPORT_OK = qw(cluck verbose longmess shortmess);
133 our @EXPORT_FAIL = qw(verbose);    # hook to enable verbose mode
134
135 # The members of %Internal are packages that are internal to perl.
136 # Carp will not report errors from within these packages if it
137 # can.  The members of %CarpInternal are internal to Perl's warning
138 # system.  Carp will not report errors from within these packages
139 # either, and will not report calls *to* these packages for carp and
140 # croak.  They replace $CarpLevel, which is deprecated.    The
141 # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
142 # text and function arguments should be formatted when printed.
143
144 our %CarpInternal;
145 our %Internal;
146
147 # disable these by default, so they can live w/o require Carp
148 $CarpInternal{Carp}++;
149 $CarpInternal{warnings}++;
150 $Internal{Exporter}++;
151 $Internal{'Exporter::Heavy'}++;
152
153 # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
154 # then the following method will be called by the Exporter which knows
155 # to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
156 # 'verbose'.
157
158 sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
159
160 sub _cgc {
161     no strict 'refs';
162     return defined &{"CORE::GLOBAL::caller"} ? \&{"CORE::GLOBAL::caller"} : undef;
163 }
164
165 sub longmess {
166     local($!, $^E);
167     # Icky backwards compatibility wrapper. :-(
168     #
169     # The story is that the original implementation hard-coded the
170     # number of call levels to go back, so calls to longmess were off
171     # by one.  Other code began calling longmess and expecting this
172     # behaviour, so the replacement has to emulate that behaviour.
173     my $cgc = _cgc();
174     my $call_pack = $cgc ? $cgc->() : caller();
175     if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
176         return longmess_heavy(@_);
177     }
178     else {
179         local $CarpLevel = $CarpLevel + 1;
180         return longmess_heavy(@_);
181     }
182 }
183
184 our @CARP_NOT;
185
186 sub shortmess {
187     local($!, $^E);
188     my $cgc = _cgc();
189
190     # Icky backwards compatibility wrapper. :-(
191     local @CARP_NOT = $cgc ? $cgc->() : caller();
192     shortmess_heavy(@_);
193 }
194
195 sub croak   { die shortmess @_ }
196 sub confess { die longmess @_ }
197 sub carp    { warn shortmess @_ }
198 sub cluck   { warn longmess @_ }
199
200 BEGIN {
201     if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
202             ("$]" >= 5.012005 && "$]" < 5.013)) {
203         *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
204     } else {
205         *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
206     }
207 }
208
209 sub caller_info {
210     my $i = shift(@_) + 1;
211     my %call_info;
212     my $cgc = _cgc();
213     {
214         # Some things override caller() but forget to implement the
215         # @DB::args part of it, which we need.  We check for this by
216         # pre-populating @DB::args with a sentinel which no-one else
217         # has the address of, so that we can detect whether @DB::args
218         # has been properly populated.  However, on earlier versions
219         # of perl this check tickles a bug in CORE::caller() which
220         # leaks memory.  So we only check on fixed perls.
221         @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
222         package DB;
223         @call_info{
224             qw(pack file line sub has_args wantarray evaltext is_require) }
225             = $cgc ? $cgc->($i) : caller($i);
226     }
227
228     unless ( defined $call_info{file} ) {
229         return ();
230     }
231
232     my $sub_name = Carp::get_subname( \%call_info );
233     if ( $call_info{has_args} ) {
234         my @args;
235         if (CALLER_OVERRIDE_CHECK_OK && @DB::args == 1
236             && ref $DB::args[0] eq ref \$i
237             && $DB::args[0] == \$i ) {
238             @DB::args = ();    # Don't let anyone see the address of $i
239             local $@;
240             my $where = eval {
241                 my $func    = $cgc or return '';
242                 my $gv      =
243                     (_fetch_sub B => 'svref_2object' or return '')
244                         ->($func)->GV;
245                 my $package = $gv->STASH->NAME;
246                 my $subname = $gv->NAME;
247                 return unless defined $package && defined $subname;
248
249                 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
250                 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
251                 " in &${package}::$subname";
252             } || '';
253             @args
254                 = "** Incomplete caller override detected$where; \@DB::args were not set **";
255         }
256         else {
257             @args = @DB::args;
258             my $overflow;
259             if ( $MaxArgNums and @args > $MaxArgNums )
260             {    # More than we want to show?
261                 $#args = $MaxArgNums - 1;
262                 $overflow = 1;
263             }
264
265             @args = map { Carp::format_arg($_) } @args;
266
267             if ($overflow) {
268                 push @args, '...';
269             }
270         }
271
272         # Push the args onto the subroutine
273         $sub_name .= '(' . join( ', ', @args ) . ')';
274     }
275     $call_info{sub_name} = $sub_name;
276     return wantarray() ? %call_info : \%call_info;
277 }
278
279 # Transform an argument to a function into a string.
280 our $in_recurse;
281 sub format_arg {
282     my ($arg) = @_;
283
284     if ( ref($arg) ) {
285          # legitimate, let's not leak it.
286         if (!$in_recurse && UNIVERSAL::isa( $arg, 'UNIVERSAL' ) &&
287             do {
288                 local $@;
289                 local $in_recurse = 1;
290                 local $SIG{__DIE__} = sub{};
291                 eval {$arg->can('CARP_TRACE') }
292             })
293         {
294             return $arg->CARP_TRACE();
295         }
296         elsif (!$in_recurse &&
297                defined($RefArgFormatter) &&
298                do {
299                 local $@;
300                 local $in_recurse = 1;
301                 local $SIG{__DIE__} = sub{};
302                 eval {$arg = $RefArgFormatter->($arg); 1}
303                 })
304         {
305             return $arg;
306         }
307         else
308         {
309             my $sub = _fetch_sub(overload => 'StrVal');
310             return $sub ? &$sub($arg) : "$arg";
311         }
312     }
313     return "undef" if !defined($arg);
314     downgrade($arg, 1);
315     return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
316             $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
317     my $suffix = "";
318     if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
319         substr ( $arg, $MaxArgLen - 3 ) = "";
320         $suffix = "...";
321     }
322     if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
323         for(my $i = length($arg); $i--; ) {
324             my $c = substr($arg, $i, 1);
325             my $x = substr($arg, 0, 0);   # work around bug on Perl 5.8.{1,2}
326             if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
327                 substr $arg, $i, 0, "\\";
328                 next;
329             }
330             my $o = ord($c);
331             substr $arg, $i, 1, sprintf("\\x{%x}", $o)
332                 unless is_safe_printable_codepoint($o);
333         }
334       downgrade($arg, 1);
335     } elsif ($arg =~ tr{"\\@$}{} || $arg =~ tr/ !"\$\%#'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~//c) {
336         $arg =~ s/([\"\\\$\@])/\\$1/g;
337         # This is all the ASCII printables spelled-out.  It is portable to all
338         # Perl versions and platforms (such as EBCDIC).  There are other more
339         # compact ways to do this, but may not work everywhere every version.
340         $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
341         downgrade($arg, 1);
342     }
343     return "\"".$arg."\"".$suffix;
344 }
345
346 sub Regexp::CARP_TRACE {
347     my $arg = "$_[0]";
348     downgrade($arg, 1);
349     if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
350         for(my $i = length($arg); $i--; ) {
351             my $o = ord(substr($arg, $i, 1));
352             my $x = substr($arg, 0, 0);   # work around bug on Perl 5.8.{1,2}
353             substr $arg, $i, 1, sprintf("\\x{%x}", $o)
354                 unless is_safe_printable_codepoint($o);
355         }
356     } else {
357         # See comment in format_arg() about this same regex.
358         $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
359     }
360     downgrade($arg, 1);
361     my $suffix = "";
362     if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
363         ($suffix, $arg) = ($1, $2);
364     }
365     if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
366         substr ( $arg, $MaxArgLen - 3 ) = "";
367         $suffix = "...".$suffix;
368     }
369     return "qr($arg)$suffix";
370 }
371
372 # Takes an inheritance cache and a package and returns
373 # an anon hash of known inheritances and anon array of
374 # inheritances which consequences have not been figured
375 # for.
376 sub get_status {
377     my $cache = shift;
378     my $pkg   = shift;
379     $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
380     return @{ $cache->{$pkg} };
381 }
382
383 # Takes the info from caller() and figures out the name of
384 # the sub/require/eval
385 sub get_subname {
386     my ($info) = @_;
387     if ( defined( $info->{evaltext} ) ) {
388         my $eval = $info->{evaltext};
389         if ( $info->{is_require} ) {
390             return "require $eval";
391         }
392         else {
393             $eval =~ s/([\\\'])/\\$1/g;
394             return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
395         }
396     }
397
398     # this can happen on older perls when the sub (or the stash containing it)
399     # has been deleted
400     elsif ( !defined( $info->{sub} ) ) {
401         return '__ANON__::__ANON__';
402     }
403
404     return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
405 }
406
407 # Figures out what call (from the point of view of the caller)
408 # the long error backtrace should start at.
409 sub long_error_loc {
410     my $i;
411     my $lvl = $CarpLevel;
412     my $cgc = _cgc();
413     {
414         ++$i;
415         my @caller = $cgc ? $cgc->($i) : caller($i);
416         my $pkg = $caller[0];
417         unless ( defined($pkg) ) {
418
419             # This *shouldn't* happen.
420             if (%Internal) {
421                 local %Internal;
422                 $i = long_error_loc();
423                 last;
424             }
425             elsif (defined $caller[2]) {
426                 # this can happen when the stash has been deleted
427                 # in that case, just assume that it's a reasonable place to
428                 # stop (the file and line data will still be intact in any
429                 # case) - the only issue is that we can't detect if the
430                 # deleted package was internal (so don't do that then)
431                 # -doy
432                 redo unless 0 > --$lvl;
433                 last;
434             }
435             else {
436                 return 2;
437             }
438         }
439         redo if $CarpInternal{$pkg};
440         redo unless 0 > --$lvl;
441         redo if $Internal{$pkg};
442     }
443     return $i - 1;
444 }
445
446 sub longmess_heavy {
447     if ( ref( $_[0] ) ) {   # don't break references as exceptions
448         return wantarray ? @_ : $_[0];
449     }
450     my $i = long_error_loc();
451     return ret_backtrace( $i, @_ );
452 }
453
454 # Returns a full stack backtrace starting from where it is
455 # told.
456 sub ret_backtrace {
457     my ( $i, @error ) = @_;
458     my $mess;
459     my $err = join '', @error;
460     $i++;
461
462     my $tid_msg = '';
463     if ( defined &threads::tid ) {
464         my $tid = threads->tid;
465         $tid_msg = " thread $tid" if $tid;
466     }
467
468     my %i = caller_info($i);
469     $mess = "$err at $i{file} line $i{line}$tid_msg";
470     if( defined $. ) {
471         local $@ = '';
472         local $SIG{__DIE__};
473         eval {
474             CORE::die;
475         };
476         if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
477             $mess .= $1;
478         }
479     }
480     $mess .= "\.\n";
481
482     while ( my %i = caller_info( ++$i ) ) {
483         $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
484     }
485
486     return $mess;
487 }
488
489 sub ret_summary {
490     my ( $i, @error ) = @_;
491     my $err = join '', @error;
492     $i++;
493
494     my $tid_msg = '';
495     if ( defined &threads::tid ) {
496         my $tid = threads->tid;
497         $tid_msg = " thread $tid" if $tid;
498     }
499
500     my %i = caller_info($i);
501     return "$err at $i{file} line $i{line}$tid_msg\.\n";
502 }
503
504 sub short_error_loc {
505     # You have to create your (hash)ref out here, rather than defaulting it
506     # inside trusts *on a lexical*, as you want it to persist across calls.
507     # (You can default it on $_[2], but that gets messy)
508     my $cache = {};
509     my $i     = 1;
510     my $lvl   = $CarpLevel;
511     my $cgc = _cgc();
512     {
513         my $called = $cgc ? $cgc->($i) : caller($i);
514         $i++;
515         my $caller = $cgc ? $cgc->($i) : caller($i);
516
517         if (!defined($caller)) {
518             my @caller = $cgc ? $cgc->($i) : caller($i);
519             if (@caller) {
520                 # if there's no package but there is other caller info, then
521                 # the package has been deleted - treat this as a valid package
522                 # in this case
523                 redo if defined($called) && $CarpInternal{$called};
524                 redo unless 0 > --$lvl;
525                 last;
526             }
527             else {
528                 return 0;
529             }
530         }
531         redo if $Internal{$caller};
532         redo if $CarpInternal{$caller};
533         redo if $CarpInternal{$called};
534         redo if trusts( $called, $caller, $cache );
535         redo if trusts( $caller, $called, $cache );
536         redo unless 0 > --$lvl;
537     }
538     return $i - 1;
539 }
540
541 sub shortmess_heavy {
542     return longmess_heavy(@_) if $Verbose;
543     return @_ if ref( $_[0] );    # don't break references as exceptions
544     my $i = short_error_loc();
545     if ($i) {
546         ret_summary( $i, @_ );
547     }
548     else {
549         longmess_heavy(@_);
550     }
551 }
552
553 # If a string is too long, trims it with ...
554 sub str_len_trim {
555     my $str = shift;
556     my $max = shift || 0;
557     if ( 2 < $max and $max < length($str) ) {
558         substr( $str, $max - 3 ) = '...';
559     }
560     return $str;
561 }
562
563 # Takes two packages and an optional cache.  Says whether the
564 # first inherits from the second.
565 #
566 # Recursive versions of this have to work to avoid certain
567 # possible endless loops, and when following long chains of
568 # inheritance are less efficient.
569 sub trusts {
570     my $child  = shift;
571     my $parent = shift;
572     my $cache  = shift;
573     my ( $known, $partial ) = get_status( $cache, $child );
574
575     # Figure out consequences until we have an answer
576     while ( @$partial and not exists $known->{$parent} ) {
577         my $anc = shift @$partial;
578         next if exists $known->{$anc};
579         $known->{$anc}++;
580         my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
581         my @found = keys %$anc_knows;
582         @$known{@found} = ();
583         push @$partial, @$anc_partial;
584     }
585     return exists $known->{$parent};
586 }
587
588 # Takes a package and gives a list of those trusted directly
589 sub trusts_directly {
590     my $class = shift;
591     no strict 'refs';
592     my $stash = \%{"$class\::"};
593     for my $var (qw/ CARP_NOT ISA /) {
594         # Don't try using the variable until we know it exists,
595         # to avoid polluting the caller's namespace.
596         if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
597           && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
598            return @{$stash->{$var}}
599         }
600     }
601     return;
602 }
603
604 if(!defined($warnings::VERSION) ||
605         do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
606     # Very old versions of warnings.pm import from Carp.  This can go
607     # wrong due to the circular dependency.  If Carp is invoked before
608     # warnings, then Carp starts by loading warnings, then warnings
609     # tries to import from Carp, and gets nothing because Carp is in
610     # the process of loading and hasn't defined its import method yet.
611     # So we work around that by manually exporting to warnings here.
612     no strict "refs";
613     *{"warnings::$_"} = \&$_ foreach @EXPORT;
614 }
615
616 1;
617
618 __END__
619
620 =head1 NAME
621
622 Carp - alternative warn and die for modules
623
624 =head1 SYNOPSIS
625
626     use Carp;
627
628     # warn user (from perspective of caller)
629     carp "string trimmed to 80 chars";
630
631     # die of errors (from perspective of caller)
632     croak "We're outta here!";
633
634     # die of errors with stack backtrace
635     confess "not implemented";
636
637     # cluck, longmess and shortmess not exported by default
638     use Carp qw(cluck longmess shortmess);
639     cluck "This is how we got here!"; # warn with stack backtrace
640     $long_message   = longmess( "message from cluck() or confess()" );
641     $short_message  = shortmess( "message from carp() or croak()" );
642
643 =head1 DESCRIPTION
644
645 The Carp routines are useful in your own modules because
646 they act like C<die()> or C<warn()>, but with a message which is more
647 likely to be useful to a user of your module.  In the case of
648 C<cluck()> and C<confess()>, that context is a summary of every
649 call in the call-stack; C<longmess()> returns the contents of the error
650 message.
651
652 For a shorter message you can use C<carp()> or C<croak()> which report the
653 error as being from where your module was called.  C<shortmess()> returns the
654 contents of this error message.  There is no guarantee that that is where the
655 error was, but it is a good educated guess.
656
657 C<Carp> takes care not to clobber the status variables C<$!> and C<$^E>
658 in the course of assembling its error messages.  This means that a
659 C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error
660 information held in those variables, if it is required to augment the
661 error message, and if the code calling C<Carp> left useful values there.
662 Of course, C<Carp> can't guarantee the latter.
663
664 You can also alter the way the output and logic of C<Carp> works, by
665 changing some global variables in the C<Carp> namespace. See the
666 section on C<GLOBAL VARIABLES> below.
667
668 Here is a more complete description of how C<carp> and C<croak> work.
669 What they do is search the call-stack for a function call stack where
670 they have not been told that there shouldn't be an error.  If every
671 call is marked safe, they give up and give a full stack backtrace
672 instead.  In other words they presume that the first likely looking
673 potential suspect is guilty.  Their rules for telling whether
674 a call shouldn't generate errors work as follows:
675
676 =over 4
677
678 =item 1.
679
680 Any call from a package to itself is safe.
681
682 =item 2.
683
684 Packages claim that there won't be errors on calls to or from
685 packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
686 (if that array is empty) C<@ISA>.  The ability to override what
687 @ISA says is new in 5.8.
688
689 =item 3.
690
691 The trust in item 2 is transitive.  If A trusts B, and B
692 trusts C, then A trusts C.  So if you do not override C<@ISA>
693 with C<@CARP_NOT>, then this trust relationship is identical to,
694 "inherits from".
695
696 =item 4.
697
698 Any call from an internal Perl module is safe.  (Nothing keeps
699 user modules from marking themselves as internal to Perl, but
700 this practice is discouraged.)
701
702 =item 5.
703
704 Any call to Perl's warning system (eg Carp itself) is safe.
705 (This rule is what keeps it from reporting the error at the
706 point where you call C<carp> or C<croak>.)
707
708 =item 6.
709
710 C<$Carp::CarpLevel> can be set to skip a fixed number of additional
711 call levels.  Using this is not recommended because it is very
712 difficult to get it to behave correctly.
713
714 =back
715
716 =head2 Forcing a Stack Trace
717
718 As a debugging aid, you can force Carp to treat a croak as a confess
719 and a carp as a cluck across I<all> modules. In other words, force a
720 detailed stack trace to be given.  This can be very helpful when trying
721 to understand why, or from where, a warning or error is being generated.
722
723 This feature is enabled by 'importing' the non-existent symbol
724 'verbose'. You would typically enable it by saying
725
726     perl -MCarp=verbose script.pl
727
728 or by including the string C<-MCarp=verbose> in the PERL5OPT
729 environment variable.
730
731 Alternately, you can set the global variable C<$Carp::Verbose> to true.
732 See the C<GLOBAL VARIABLES> section below.
733
734 =head2 Stack Trace formatting
735
736 At each stack level, the subroutine's name is displayed along with
737 its parameters.  For simple scalars, this is sufficient.  For complex
738 data types, such as objects and other references, this can simply
739 display C<'HASH(0x1ab36d8)'>.
740
741 Carp gives two ways to control this.
742
743 =over 4
744
745 =item 1.
746
747 For objects, a method, C<CARP_TRACE>, will be called, if it exists.  If
748 this method doesn't exist, or it recurses into C<Carp>, or it otherwise
749 throws an exception, this is skipped, and Carp moves on to the next option,
750 otherwise checking stops and the string returned is used.  It is recommended
751 that the object's type is part of the string to make debugging easier.
752
753 =item 2.
754
755 For any type of reference, C<$Carp::RefArgFormatter> is checked (see below).
756 This variable is expected to be a code reference, and the current parameter
757 is passed in.  If this function doesn't exist (the variable is undef), or
758 it recurses into C<Carp>, or it otherwise throws an exception, this is
759 skipped, and Carp moves on to the next option, otherwise checking stops
760 and the string returned is used.
761
762 =item 3.
763
764 Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is
765 available, stringify the value ignoring any overloading.
766
767 =back
768
769 =head1 GLOBAL VARIABLES
770
771 =head2 $Carp::MaxEvalLen
772
773 This variable determines how many characters of a string-eval are to
774 be shown in the output. Use a value of C<0> to show all text.
775
776 Defaults to C<0>.
777
778 =head2 $Carp::MaxArgLen
779
780 This variable determines how many characters of each argument to a
781 function to print. Use a value of C<0> to show the full length of the
782 argument.
783
784 Defaults to C<64>.
785
786 =head2 $Carp::MaxArgNums
787
788 This variable determines how many arguments to each function to show.
789 Use a false value to show all arguments to a function call.  To suppress all
790 arguments, use C<-1> or C<'0 but true'>.
791
792 Defaults to C<8>.
793
794 =head2 $Carp::Verbose
795
796 This variable makes C<carp()> and C<croak()> generate stack backtraces
797 just like C<cluck()> and C<confess()>.  This is how C<use Carp 'verbose'>
798 is implemented internally.
799
800 Defaults to C<0>.
801
802 =head2 $Carp::RefArgFormatter
803
804 This variable sets a general argument formatter to display references.
805 Plain scalars and objects that implement C<CARP_TRACE> will not go through
806 this formatter.  Calling C<Carp> from within this function is not supported.
807
808 local $Carp::RefArgFormatter = sub {
809     require Data::Dumper;
810     Data::Dumper::Dump($_[0]); # not necessarily safe
811 };
812
813 =head2 @CARP_NOT
814
815 This variable, I<in your package>, says which packages are I<not> to be
816 considered as the location of an error. The C<carp()> and C<cluck()>
817 functions will skip over callers when reporting where an error occurred.
818
819 NB: This variable must be in the package's symbol table, thus:
820
821     # These work
822     our @CARP_NOT; # file scope
823     use vars qw(@CARP_NOT); # package scope
824     @My::Package::CARP_NOT = ... ; # explicit package variable
825
826     # These don't work
827     sub xyz { ... @CARP_NOT = ... } # w/o declarations above
828     my @CARP_NOT; # even at top-level
829
830 Example of use:
831
832     package My::Carping::Package;
833     use Carp;
834     our @CARP_NOT;
835     sub bar     { .... or _error('Wrong input') }
836     sub _error  {
837         # temporary control of where'ness, __PACKAGE__ is implicit
838         local @CARP_NOT = qw(My::Friendly::Caller);
839         carp(@_)
840     }
841
842 This would make C<Carp> report the error as coming from a caller not
843 in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
844
845 Also read the L</DESCRIPTION> section above, about how C<Carp> decides
846 where the error is reported from.
847
848 Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
849
850 Overrides C<Carp>'s use of C<@ISA>.
851
852 =head2 %Carp::Internal
853
854 This says what packages are internal to Perl.  C<Carp> will never
855 report an error as being from a line in a package that is internal to
856 Perl.  For example:
857
858     $Carp::Internal{ (__PACKAGE__) }++;
859     # time passes...
860     sub foo { ... or confess("whatever") };
861
862 would give a full stack backtrace starting from the first caller
863 outside of __PACKAGE__.  (Unless that package was also internal to
864 Perl.)
865
866 =head2 %Carp::CarpInternal
867
868 This says which packages are internal to Perl's warning system.  For
869 generating a full stack backtrace this is the same as being internal
870 to Perl, the stack backtrace will not start inside packages that are
871 listed in C<%Carp::CarpInternal>.  But it is slightly different for
872 the summary message generated by C<carp> or C<croak>.  There errors
873 will not be reported on any lines that are calling packages in
874 C<%Carp::CarpInternal>.
875
876 For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
877 Therefore the full stack backtrace from C<confess> will not start
878 inside of C<Carp>, and the short message from calling C<croak> is
879 not placed on the line where C<croak> was called.
880
881 =head2 $Carp::CarpLevel
882
883 This variable determines how many additional call frames are to be
884 skipped that would not otherwise be when reporting where an error
885 occurred on a call to one of C<Carp>'s functions.  It is fairly easy
886 to count these call frames on calls that generate a full stack
887 backtrace.  However it is much harder to do this accounting for calls
888 that generate a short message.  Usually people skip too many call
889 frames.  If they are lucky they skip enough that C<Carp> goes all of
890 the way through the call stack, realizes that something is wrong, and
891 then generates a full stack backtrace.  If they are unlucky then the
892 error is reported from somewhere misleading very high in the call
893 stack.
894
895 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
896 C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
897
898 Defaults to C<0>.
899
900 =head1 BUGS
901
902 The Carp routines don't handle exception objects currently.
903 If called with a first argument that is a reference, they simply
904 call die() or warn(), as appropriate.
905
906 =head1 SEE ALSO
907
908 L<Carp::Always>,
909 L<Carp::Clan>
910
911 =head1 CONTRIBUTING
912
913 L<Carp> is maintained by the perl 5 porters as part of the core perl 5
914 version control repository. Please see the L<perlhack> perldoc for how to
915 submit patches and contribute to it.
916
917 =head1 AUTHOR
918
919 The Carp module first appeared in Larry Wall's perl 5.000 distribution.
920 Since then it has been modified by several of the perl 5 porters.
921 Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
922 distribution.
923
924 =head1 COPYRIGHT
925
926 Copyright (C) 1994-2013 Larry Wall
927
928 Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
929
930 =head1 LICENSE
931
932 This module is free software; you can redistribute it and/or modify it
933 under the same terms as Perl itself.