Module::CoreList 5.20191020 is now on CPAN
[perl.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 sub _univ_mod_loaded {
120     return 0 unless exists($::{"UNIVERSAL::"});
121     for ($::{"UNIVERSAL::"}) {
122         return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"$_[0]::"};
123         for ($$_{"$_[0]::"}) {
124             return 0 unless ref \$_ eq "GLOB" && *$_{HASH} && exists $$_{"VERSION"};
125             for ($$_{"VERSION"}) {
126                 return 0 unless ref \$_ eq "GLOB";
127                 return ${*$_{SCALAR}};
128             }
129         }
130     }
131 }
132
133 # _maybe_isa() is usually the UNIVERSAL::isa function.  We have to avoid
134 # the latter if the UNIVERSAL::isa module has been loaded, to avoid infi-
135 # nite recursion; in that case _maybe_isa simply returns true.
136 my $isa;
137 BEGIN {
138     if (_univ_mod_loaded('isa')) {
139         *_maybe_isa = sub { 1 }
140     }
141     else {
142         # Since we have already done the check, record $isa for use below
143         # when defining _StrVal.
144         *_maybe_isa = $isa = _fetch_sub(UNIVERSAL => "isa");
145     }
146 }
147
148
149 # We need an overload::StrVal or equivalent function, but we must avoid
150 # loading any modules on demand, as Carp is used from __DIE__ handlers and
151 # may be invoked after a syntax error.
152 # We can copy recent implementations of overload::StrVal and use
153 # overloading.pm, which is the fastest implementation, so long as
154 # overloading is available.  If it is not available, we use our own pure-
155 # Perl StrVal.  We never actually use overload::StrVal, for various rea-
156 # sons described below.
157 # overload versions are as follows:
158 #     undef-1.00 (up to perl 5.8.0)   uses bless (avoid!)
159 #     1.01-1.17  (perl 5.8.1 to 5.14) uses Scalar::Util
160 #     1.18+      (perl 5.16+)         uses overloading
161 # The ancient 'bless' implementation (that inspires our pure-Perl version)
162 # blesses unblessed references and must be avoided.  Those using
163 # Scalar::Util use refaddr, possibly the pure-Perl implementation, which
164 # has the same blessing bug, and must be avoided.  Also, Scalar::Util is
165 # loaded on demand.  Since we avoid the Scalar::Util implementations, we
166 # end up having to implement our own overloading.pm-based version for perl
167 # 5.10.1 to 5.14.  Since it also works just as well in more recent ver-
168 # sions, we use it there, too.
169 BEGIN {
170     if (eval { require "overloading.pm" }) {
171         *_StrVal = eval 'sub { no overloading; "$_[0]" }'
172     }
173     else {
174         # Work around the UNIVERSAL::can/isa modules to avoid recursion.
175
176         # _mycan is either UNIVERSAL::can, or, in the presence of an
177         # override, overload::mycan.
178         *_mycan = _univ_mod_loaded('can')
179             ? do { require "overload.pm"; _fetch_sub overload => 'mycan' }
180             : \&UNIVERSAL::can;
181
182         # _blessed is either UNIVERAL::isa(...), or, in the presence of an
183         # override, a hideous, but fairly reliable, workaround.
184         *_blessed = $isa
185             ? sub { &$isa($_[0], "UNIVERSAL") }
186             : sub {
187                 my $probe = "UNIVERSAL::Carp_probe_" . rand;
188                 no strict 'refs';
189                 local *$probe = sub { "unlikely string" };
190                 local $@;
191                 local $SIG{__DIE__} = sub{};
192                 (eval { $_[0]->$probe } || '') eq 'unlikely string'
193               };
194
195         *_StrVal = sub {
196             my $pack = ref $_[0];
197             # Perl's overload mechanism uses the presence of a special
198             # "method" named "((" or "()" to signal it is in effect.
199             # This test seeks to see if it has been set up.  "((" post-
200             # dates overloading.pm, so we can skip it.
201             return "$_[0]" unless _mycan($pack, "()");
202             # Even at this point, the invocant may not be blessed, so
203             # check for that.
204             return "$_[0]" if not _blessed($_[0]);
205             bless $_[0], "Carp";
206             my $str = "$_[0]";
207             bless $_[0], $pack;
208             $pack . substr $str, index $str, "=";
209         }
210     }
211 }
212
213
214 our $VERSION = '1.50';
215 $VERSION =~ tr/_//d;
216
217 our $MaxEvalLen = 0;
218 our $Verbose    = 0;
219 our $CarpLevel  = 0;
220 our $MaxArgLen  = 64;    # How much of each argument to print. 0 = all.
221 our $MaxArgNums = 8;     # How many arguments to print. 0 = all.
222 our $RefArgFormatter = undef; # allow caller to format reference arguments
223
224 require Exporter;
225 our @ISA       = ('Exporter');
226 our @EXPORT    = qw(confess croak carp);
227 our @EXPORT_OK = qw(cluck verbose longmess shortmess);
228 our @EXPORT_FAIL = qw(verbose);    # hook to enable verbose mode
229
230 # The members of %Internal are packages that are internal to perl.
231 # Carp will not report errors from within these packages if it
232 # can.  The members of %CarpInternal are internal to Perl's warning
233 # system.  Carp will not report errors from within these packages
234 # either, and will not report calls *to* these packages for carp and
235 # croak.  They replace $CarpLevel, which is deprecated.    The
236 # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
237 # text and function arguments should be formatted when printed.
238
239 our %CarpInternal;
240 our %Internal;
241
242 # disable these by default, so they can live w/o require Carp
243 $CarpInternal{Carp}++;
244 $CarpInternal{warnings}++;
245 $Internal{Exporter}++;
246 $Internal{'Exporter::Heavy'}++;
247
248 # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
249 # then the following method will be called by the Exporter which knows
250 # to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
251 # 'verbose'.
252
253 sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
254
255 sub _cgc {
256     no strict 'refs';
257     return \&{"CORE::GLOBAL::caller"} if defined &{"CORE::GLOBAL::caller"};
258     return;
259 }
260
261 sub longmess {
262     local($!, $^E);
263     # Icky backwards compatibility wrapper. :-(
264     #
265     # The story is that the original implementation hard-coded the
266     # number of call levels to go back, so calls to longmess were off
267     # by one.  Other code began calling longmess and expecting this
268     # behaviour, so the replacement has to emulate that behaviour.
269     my $cgc = _cgc();
270     my $call_pack = $cgc ? $cgc->() : caller();
271     if ( $Internal{$call_pack} or $CarpInternal{$call_pack} ) {
272         return longmess_heavy(@_);
273     }
274     else {
275         local $CarpLevel = $CarpLevel + 1;
276         return longmess_heavy(@_);
277     }
278 }
279
280 our @CARP_NOT;
281
282 sub shortmess {
283     local($!, $^E);
284     my $cgc = _cgc();
285
286     # Icky backwards compatibility wrapper. :-(
287     local @CARP_NOT = $cgc ? $cgc->() : caller();
288     shortmess_heavy(@_);
289 }
290
291 sub croak   { die shortmess @_ }
292 sub confess { die longmess @_ }
293 sub carp    { warn shortmess @_ }
294 sub cluck   { warn longmess @_ }
295
296 BEGIN {
297     if("$]" >= 5.015002 || ("$]" >= 5.014002 && "$]" < 5.015) ||
298             ("$]" >= 5.012005 && "$]" < 5.013)) {
299         *CALLER_OVERRIDE_CHECK_OK = sub () { 1 };
300     } else {
301         *CALLER_OVERRIDE_CHECK_OK = sub () { 0 };
302     }
303 }
304
305 sub caller_info {
306     my $i = shift(@_) + 1;
307     my %call_info;
308     my $cgc = _cgc();
309     {
310         # Some things override caller() but forget to implement the
311         # @DB::args part of it, which we need.  We check for this by
312         # pre-populating @DB::args with a sentinel which no-one else
313         # has the address of, so that we can detect whether @DB::args
314         # has been properly populated.  However, on earlier versions
315         # of perl this check tickles a bug in CORE::caller() which
316         # leaks memory.  So we only check on fixed perls.
317         @DB::args = \$i if CALLER_OVERRIDE_CHECK_OK;
318         package DB;
319         @call_info{
320             qw(pack file line sub has_args wantarray evaltext is_require) }
321             = $cgc ? $cgc->($i) : caller($i);
322     }
323
324     unless ( defined $call_info{file} ) {
325         return ();
326     }
327
328     my $sub_name = Carp::get_subname( \%call_info );
329     if ( $call_info{has_args} ) {
330         # Guard our serialization of the stack from stack refcounting bugs
331         # NOTE this is NOT a complete solution, we cannot 100% guard against
332         # these bugs.  However in many cases Perl *is* capable of detecting
333         # them and throws an error when it does.  Unfortunately serializing
334         # the arguments on the stack is a perfect way of finding these bugs,
335         # even when they would not affect normal program flow that did not
336         # poke around inside the stack.  Inside of Carp.pm it makes little
337         # sense reporting these bugs, as Carp's job is to report the callers
338         # errors, not the ones it might happen to tickle while doing so.
339         # See: https://rt.perl.org/Public/Bug/Display.html?id=131046
340         # and: https://rt.perl.org/Public/Bug/Display.html?id=52610
341         # for more details and discussion. - Yves
342         my @args = map {
343                 my $arg;
344                 local $@= $@;
345                 eval {
346                     $arg = $_;
347                     1;
348                 } or do {
349                     $arg = '** argument not available anymore **';
350                 };
351                 $arg;
352             } @DB::args;
353         if (CALLER_OVERRIDE_CHECK_OK && @args == 1
354             && ref $args[0] eq ref \$i
355             && $args[0] == \$i ) {
356             @args = ();    # Don't let anyone see the address of $i
357             local $@;
358             my $where = eval {
359                 my $func    = $cgc or return '';
360                 my $gv      =
361                     (_fetch_sub B => 'svref_2object' or return '')
362                         ->($func)->GV;
363                 my $package = $gv->STASH->NAME;
364                 my $subname = $gv->NAME;
365                 return unless defined $package && defined $subname;
366
367                 # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
368                 return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
369                 " in &${package}::$subname";
370             } || '';
371             @args
372                 = "** Incomplete caller override detected$where; \@DB::args were not set **";
373         }
374         else {
375             my $overflow;
376             if ( $MaxArgNums and @args > $MaxArgNums )
377             {    # More than we want to show?
378                 $#args = $MaxArgNums - 1;
379                 $overflow = 1;
380             }
381
382             @args = map { Carp::format_arg($_) } @args;
383
384             if ($overflow) {
385                 push @args, '...';
386             }
387         }
388
389         # Push the args onto the subroutine
390         $sub_name .= '(' . join( ', ', @args ) . ')';
391     }
392     $call_info{sub_name} = $sub_name;
393     return wantarray() ? %call_info : \%call_info;
394 }
395
396 # Transform an argument to a function into a string.
397 our $in_recurse;
398 sub format_arg {
399     my $arg = shift;
400
401     if ( my $pack= ref($arg) ) {
402
403          # legitimate, let's not leak it.
404         if (!$in_recurse && _maybe_isa( $arg, 'UNIVERSAL' ) &&
405             do {
406                 local $@;
407                 local $in_recurse = 1;
408                 local $SIG{__DIE__} = sub{};
409                 eval {$arg->can('CARP_TRACE') }
410             })
411         {
412             return $arg->CARP_TRACE();
413         }
414         elsif (!$in_recurse &&
415                defined($RefArgFormatter) &&
416                do {
417                 local $@;
418                 local $in_recurse = 1;
419                 local $SIG{__DIE__} = sub{};
420                 eval {$arg = $RefArgFormatter->($arg); 1}
421                 })
422         {
423             return $arg;
424         }
425         else
426         {
427             # Argument may be blessed into a class with overloading, and so
428             # might have an overloaded stringification.  We don't want to
429             # risk getting the overloaded stringification, so we need to
430             # use _StrVal, our overload::StrVal()-equivalent.
431             return _StrVal $arg;
432         }
433     }
434     return "undef" if !defined($arg);
435     downgrade($arg, 1);
436     return $arg if !(UTF8_REGEXP_PROBLEM && is_utf8($arg)) &&
437             $arg =~ /\A-?[0-9]+(?:\.[0-9]*)?(?:[eE][-+]?[0-9]+)?\z/;
438     my $suffix = "";
439     if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
440         substr ( $arg, $MaxArgLen - 3 ) = "";
441         $suffix = "...";
442     }
443     if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
444         for(my $i = length($arg); $i--; ) {
445             my $c = substr($arg, $i, 1);
446             my $x = substr($arg, 0, 0);   # work around bug on Perl 5.8.{1,2}
447             if($c eq "\"" || $c eq "\\" || $c eq "\$" || $c eq "\@") {
448                 substr $arg, $i, 0, "\\";
449                 next;
450             }
451             my $o = ord($c);
452             substr $arg, $i, 1, sprintf("\\x{%x}", $o)
453                 unless is_safe_printable_codepoint($o);
454         }
455     } else {
456         $arg =~ s/([\"\\\$\@])/\\$1/g;
457         # This is all the ASCII printables spelled-out.  It is portable to all
458         # Perl versions and platforms (such as EBCDIC).  There are other more
459         # compact ways to do this, but may not work everywhere every version.
460         $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
461     }
462     downgrade($arg, 1);
463     return "\"".$arg."\"".$suffix;
464 }
465
466 sub Regexp::CARP_TRACE {
467     my $arg = "$_[0]";
468     downgrade($arg, 1);
469     if(UTF8_REGEXP_PROBLEM && is_utf8($arg)) {
470         for(my $i = length($arg); $i--; ) {
471             my $o = ord(substr($arg, $i, 1));
472             my $x = substr($arg, 0, 0);   # work around bug on Perl 5.8.{1,2}
473             substr $arg, $i, 1, sprintf("\\x{%x}", $o)
474                 unless is_safe_printable_codepoint($o);
475         }
476     } else {
477         # See comment in format_arg() about this same regex.
478         $arg =~ s/([^ !"#\$\%\&'()*+,\-.\/0123456789:;<=>?\@ABCDEFGHIJKLMNOPQRSTUVWXYZ\[\\\]^_`abcdefghijklmnopqrstuvwxyz\{|}~])/sprintf("\\x{%x}",ord($1))/eg;
479     }
480     downgrade($arg, 1);
481     my $suffix = "";
482     if($arg =~ /\A\(\?\^?([a-z]*)(?:-[a-z]*)?:(.*)\)\z/s) {
483         ($suffix, $arg) = ($1, $2);
484     }
485     if ( 2 < $MaxArgLen and $MaxArgLen < length($arg) ) {
486         substr ( $arg, $MaxArgLen - 3 ) = "";
487         $suffix = "...".$suffix;
488     }
489     return "qr($arg)$suffix";
490 }
491
492 # Takes an inheritance cache and a package and returns
493 # an anon hash of known inheritances and anon array of
494 # inheritances which consequences have not been figured
495 # for.
496 sub get_status {
497     my $cache = shift;
498     my $pkg   = shift;
499     $cache->{$pkg} ||= [ { $pkg => $pkg }, [ trusts_directly($pkg) ] ];
500     return @{ $cache->{$pkg} };
501 }
502
503 # Takes the info from caller() and figures out the name of
504 # the sub/require/eval
505 sub get_subname {
506     my $info = shift;
507     if ( defined( $info->{evaltext} ) ) {
508         my $eval = $info->{evaltext};
509         if ( $info->{is_require} ) {
510             return "require $eval";
511         }
512         else {
513             $eval =~ s/([\\\'])/\\$1/g;
514             return "eval '" . str_len_trim( $eval, $MaxEvalLen ) . "'";
515         }
516     }
517
518     # this can happen on older perls when the sub (or the stash containing it)
519     # has been deleted
520     if ( !defined( $info->{sub} ) ) {
521         return '__ANON__::__ANON__';
522     }
523
524     return ( $info->{sub} eq '(eval)' ) ? 'eval {...}' : $info->{sub};
525 }
526
527 # Figures out what call (from the point of view of the caller)
528 # the long error backtrace should start at.
529 sub long_error_loc {
530     my $i;
531     my $lvl = $CarpLevel;
532     {
533         ++$i;
534         my $cgc = _cgc();
535         my @caller = $cgc ? $cgc->($i) : caller($i);
536         my $pkg = $caller[0];
537         unless ( defined($pkg) ) {
538
539             # This *shouldn't* happen.
540             if (%Internal) {
541                 local %Internal;
542                 $i = long_error_loc();
543                 last;
544             }
545             elsif (defined $caller[2]) {
546                 # this can happen when the stash has been deleted
547                 # in that case, just assume that it's a reasonable place to
548                 # stop (the file and line data will still be intact in any
549                 # case) - the only issue is that we can't detect if the
550                 # deleted package was internal (so don't do that then)
551                 # -doy
552                 redo unless 0 > --$lvl;
553                 last;
554             }
555             else {
556                 return 2;
557             }
558         }
559         redo if $CarpInternal{$pkg};
560         redo unless 0 > --$lvl;
561         redo if $Internal{$pkg};
562     }
563     return $i - 1;
564 }
565
566 sub longmess_heavy {
567     if ( ref( $_[0] ) ) {   # don't break references as exceptions
568         return wantarray ? @_ : $_[0];
569     }
570     my $i = long_error_loc();
571     return ret_backtrace( $i, @_ );
572 }
573
574 BEGIN {
575     if("$]" >= 5.017004) {
576         # The LAST_FH constant is a reference to the variable.
577         $Carp::{LAST_FH} = \eval '\${^LAST_FH}';
578     } else {
579         eval '*LAST_FH = sub () { 0 }';
580     }
581 }
582
583 # Returns a full stack backtrace starting from where it is
584 # told.
585 sub ret_backtrace {
586     my ( $i, @error ) = @_;
587     my $mess;
588     my $err = join '', @error;
589     $i++;
590
591     my $tid_msg = '';
592     if ( defined &threads::tid ) {
593         my $tid = threads->tid;
594         $tid_msg = " thread $tid" if $tid;
595     }
596
597     my %i = caller_info($i);
598     $mess = "$err at $i{file} line $i{line}$tid_msg";
599     if( $. ) {
600       # Use ${^LAST_FH} if available.
601       if (LAST_FH) {
602         if (${+LAST_FH}) {
603             $mess .= sprintf ", <%s> %s %d",
604                               *${+LAST_FH}{NAME},
605                               ($/ eq "\n" ? "line" : "chunk"), $.
606         }
607       }
608       else {
609         local $@ = '';
610         local $SIG{__DIE__};
611         eval {
612             CORE::die;
613         };
614         if($@ =~ /^Died at .*(, <.*?> (?:line|chunk) \d+).$/ ) {
615             $mess .= $1;
616         }
617       }
618     }
619     $mess .= "\.\n";
620
621     while ( my %i = caller_info( ++$i ) ) {
622         $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
623     }
624
625     return $mess;
626 }
627
628 sub ret_summary {
629     my ( $i, @error ) = @_;
630     my $err = join '', @error;
631     $i++;
632
633     my $tid_msg = '';
634     if ( defined &threads::tid ) {
635         my $tid = threads->tid;
636         $tid_msg = " thread $tid" if $tid;
637     }
638
639     my %i = caller_info($i);
640     return "$err at $i{file} line $i{line}$tid_msg\.\n";
641 }
642
643 sub short_error_loc {
644     # You have to create your (hash)ref out here, rather than defaulting it
645     # inside trusts *on a lexical*, as you want it to persist across calls.
646     # (You can default it on $_[2], but that gets messy)
647     my $cache = {};
648     my $i     = 1;
649     my $lvl   = $CarpLevel;
650     {
651         my $cgc = _cgc();
652         my $called = $cgc ? $cgc->($i) : caller($i);
653         $i++;
654         my $caller = $cgc ? $cgc->($i) : caller($i);
655
656         if (!defined($caller)) {
657             my @caller = $cgc ? $cgc->($i) : caller($i);
658             if (@caller) {
659                 # if there's no package but there is other caller info, then
660                 # the package has been deleted - treat this as a valid package
661                 # in this case
662                 redo if defined($called) && $CarpInternal{$called};
663                 redo unless 0 > --$lvl;
664                 last;
665             }
666             else {
667                 return 0;
668             }
669         }
670         redo if $Internal{$caller};
671         redo if $CarpInternal{$caller};
672         redo if $CarpInternal{$called};
673         redo if trusts( $called, $caller, $cache );
674         redo if trusts( $caller, $called, $cache );
675         redo unless 0 > --$lvl;
676     }
677     return $i - 1;
678 }
679
680 sub shortmess_heavy {
681     return longmess_heavy(@_) if $Verbose;
682     return @_ if ref( $_[0] );    # don't break references as exceptions
683     my $i = short_error_loc();
684     if ($i) {
685         ret_summary( $i, @_ );
686     }
687     else {
688         longmess_heavy(@_);
689     }
690 }
691
692 # If a string is too long, trims it with ...
693 sub str_len_trim {
694     my $str = shift;
695     my $max = shift || 0;
696     if ( 2 < $max and $max < length($str) ) {
697         substr( $str, $max - 3 ) = '...';
698     }
699     return $str;
700 }
701
702 # Takes two packages and an optional cache.  Says whether the
703 # first inherits from the second.
704 #
705 # Recursive versions of this have to work to avoid certain
706 # possible endless loops, and when following long chains of
707 # inheritance are less efficient.
708 sub trusts {
709     my $child  = shift;
710     my $parent = shift;
711     my $cache  = shift;
712     my ( $known, $partial ) = get_status( $cache, $child );
713
714     # Figure out consequences until we have an answer
715     while ( @$partial and not exists $known->{$parent} ) {
716         my $anc = shift @$partial;
717         next if exists $known->{$anc};
718         $known->{$anc}++;
719         my ( $anc_knows, $anc_partial ) = get_status( $cache, $anc );
720         my @found = keys %$anc_knows;
721         @$known{@found} = ();
722         push @$partial, @$anc_partial;
723     }
724     return exists $known->{$parent};
725 }
726
727 # Takes a package and gives a list of those trusted directly
728 sub trusts_directly {
729     my $class = shift;
730     no strict 'refs';
731     my $stash = \%{"$class\::"};
732     for my $var (qw/ CARP_NOT ISA /) {
733         # Don't try using the variable until we know it exists,
734         # to avoid polluting the caller's namespace.
735         if ( $stash->{$var} && ref \$stash->{$var} eq 'GLOB'
736           && *{$stash->{$var}}{ARRAY} && @{$stash->{$var}} ) {
737            return @{$stash->{$var}}
738         }
739     }
740     return;
741 }
742
743 if(!defined($warnings::VERSION) ||
744         do { no warnings "numeric"; $warnings::VERSION < 1.03 }) {
745     # Very old versions of warnings.pm import from Carp.  This can go
746     # wrong due to the circular dependency.  If Carp is invoked before
747     # warnings, then Carp starts by loading warnings, then warnings
748     # tries to import from Carp, and gets nothing because Carp is in
749     # the process of loading and hasn't defined its import method yet.
750     # So we work around that by manually exporting to warnings here.
751     no strict "refs";
752     *{"warnings::$_"} = \&$_ foreach @EXPORT;
753 }
754
755 1;
756
757 __END__
758
759 =head1 NAME
760
761 Carp - alternative warn and die for modules
762
763 =head1 SYNOPSIS
764
765     use Carp;
766
767     # warn user (from perspective of caller)
768     carp "string trimmed to 80 chars";
769
770     # die of errors (from perspective of caller)
771     croak "We're outta here!";
772
773     # die of errors with stack backtrace
774     confess "not implemented";
775
776     # cluck, longmess and shortmess not exported by default
777     use Carp qw(cluck longmess shortmess);
778     cluck "This is how we got here!"; # warn with stack backtrace
779     $long_message   = longmess( "message from cluck() or confess()" );
780     $short_message  = shortmess( "message from carp() or croak()" );
781
782 =head1 DESCRIPTION
783
784 The Carp routines are useful in your own modules because
785 they act like C<die()> or C<warn()>, but with a message which is more
786 likely to be useful to a user of your module.  In the case of
787 C<cluck()> and C<confess()>, that context is a summary of every
788 call in the call-stack; C<longmess()> returns the contents of the error
789 message.
790
791 For a shorter message you can use C<carp()> or C<croak()> which report the
792 error as being from where your module was called.  C<shortmess()> returns the
793 contents of this error message.  There is no guarantee that that is where the
794 error was, but it is a good educated guess.
795
796 C<Carp> takes care not to clobber the status variables C<$!> and C<$^E>
797 in the course of assembling its error messages.  This means that a
798 C<$SIG{__DIE__}> or C<$SIG{__WARN__}> handler can capture the error
799 information held in those variables, if it is required to augment the
800 error message, and if the code calling C<Carp> left useful values there.
801 Of course, C<Carp> can't guarantee the latter.
802
803 You can also alter the way the output and logic of C<Carp> works, by
804 changing some global variables in the C<Carp> namespace. See the
805 section on C<GLOBAL VARIABLES> below.
806
807 Here is a more complete description of how C<carp> and C<croak> work.
808 What they do is search the call-stack for a function call stack where
809 they have not been told that there shouldn't be an error.  If every
810 call is marked safe, they give up and give a full stack backtrace
811 instead.  In other words they presume that the first likely looking
812 potential suspect is guilty.  Their rules for telling whether
813 a call shouldn't generate errors work as follows:
814
815 =over 4
816
817 =item 1.
818
819 Any call from a package to itself is safe.
820
821 =item 2.
822
823 Packages claim that there won't be errors on calls to or from
824 packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
825 (if that array is empty) C<@ISA>.  The ability to override what
826 @ISA says is new in 5.8.
827
828 =item 3.
829
830 The trust in item 2 is transitive.  If A trusts B, and B
831 trusts C, then A trusts C.  So if you do not override C<@ISA>
832 with C<@CARP_NOT>, then this trust relationship is identical to,
833 "inherits from".
834
835 =item 4.
836
837 Any call from an internal Perl module is safe.  (Nothing keeps
838 user modules from marking themselves as internal to Perl, but
839 this practice is discouraged.)
840
841 =item 5.
842
843 Any call to Perl's warning system (eg Carp itself) is safe.
844 (This rule is what keeps it from reporting the error at the
845 point where you call C<carp> or C<croak>.)
846
847 =item 6.
848
849 C<$Carp::CarpLevel> can be set to skip a fixed number of additional
850 call levels.  Using this is not recommended because it is very
851 difficult to get it to behave correctly.
852
853 =back
854
855 =head2 Forcing a Stack Trace
856
857 As a debugging aid, you can force Carp to treat a croak as a confess
858 and a carp as a cluck across I<all> modules. In other words, force a
859 detailed stack trace to be given.  This can be very helpful when trying
860 to understand why, or from where, a warning or error is being generated.
861
862 This feature is enabled by 'importing' the non-existent symbol
863 'verbose'. You would typically enable it by saying
864
865     perl -MCarp=verbose script.pl
866
867 or by including the string C<-MCarp=verbose> in the PERL5OPT
868 environment variable.
869
870 Alternately, you can set the global variable C<$Carp::Verbose> to true.
871 See the C<GLOBAL VARIABLES> section below.
872
873 =head2 Stack Trace formatting
874
875 At each stack level, the subroutine's name is displayed along with
876 its parameters.  For simple scalars, this is sufficient.  For complex
877 data types, such as objects and other references, this can simply
878 display C<'HASH(0x1ab36d8)'>.
879
880 Carp gives two ways to control this.
881
882 =over 4
883
884 =item 1.
885
886 For objects, a method, C<CARP_TRACE>, will be called, if it exists.  If
887 this method doesn't exist, or it recurses into C<Carp>, or it otherwise
888 throws an exception, this is skipped, and Carp moves on to the next option,
889 otherwise checking stops and the string returned is used.  It is recommended
890 that the object's type is part of the string to make debugging easier.
891
892 =item 2.
893
894 For any type of reference, C<$Carp::RefArgFormatter> is checked (see below).
895 This variable is expected to be a code reference, and the current parameter
896 is passed in.  If this function doesn't exist (the variable is undef), or
897 it recurses into C<Carp>, or it otherwise throws an exception, this is
898 skipped, and Carp moves on to the next option, otherwise checking stops
899 and the string returned is used.
900
901 =item 3.
902
903 Otherwise, if neither C<CARP_TRACE> nor C<$Carp::RefArgFormatter> is
904 available, stringify the value ignoring any overloading.
905
906 =back
907
908 =head1 GLOBAL VARIABLES
909
910 =head2 $Carp::MaxEvalLen
911
912 This variable determines how many characters of a string-eval are to
913 be shown in the output. Use a value of C<0> to show all text.
914
915 Defaults to C<0>.
916
917 =head2 $Carp::MaxArgLen
918
919 This variable determines how many characters of each argument to a
920 function to print. Use a value of C<0> to show the full length of the
921 argument.
922
923 Defaults to C<64>.
924
925 =head2 $Carp::MaxArgNums
926
927 This variable determines how many arguments to each function to show.
928 Use a false value to show all arguments to a function call.  To suppress all
929 arguments, use C<-1> or C<'0 but true'>.
930
931 Defaults to C<8>.
932
933 =head2 $Carp::Verbose
934
935 This variable makes C<carp()> and C<croak()> generate stack backtraces
936 just like C<cluck()> and C<confess()>.  This is how C<use Carp 'verbose'>
937 is implemented internally.
938
939 Defaults to C<0>.
940
941 =head2 $Carp::RefArgFormatter
942
943 This variable sets a general argument formatter to display references.
944 Plain scalars and objects that implement C<CARP_TRACE> will not go through
945 this formatter.  Calling C<Carp> from within this function is not supported.
946
947 local $Carp::RefArgFormatter = sub {
948     require Data::Dumper;
949     Data::Dumper::Dump($_[0]); # not necessarily safe
950 };
951
952 =head2 @CARP_NOT
953
954 This variable, I<in your package>, says which packages are I<not> to be
955 considered as the location of an error. The C<carp()> and C<cluck()>
956 functions will skip over callers when reporting where an error occurred.
957
958 NB: This variable must be in the package's symbol table, thus:
959
960     # These work
961     our @CARP_NOT; # file scope
962     use vars qw(@CARP_NOT); # package scope
963     @My::Package::CARP_NOT = ... ; # explicit package variable
964
965     # These don't work
966     sub xyz { ... @CARP_NOT = ... } # w/o declarations above
967     my @CARP_NOT; # even at top-level
968
969 Example of use:
970
971     package My::Carping::Package;
972     use Carp;
973     our @CARP_NOT;
974     sub bar     { .... or _error('Wrong input') }
975     sub _error  {
976         # temporary control of where'ness, __PACKAGE__ is implicit
977         local @CARP_NOT = qw(My::Friendly::Caller);
978         carp(@_)
979     }
980
981 This would make C<Carp> report the error as coming from a caller not
982 in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
983
984 Also read the L</DESCRIPTION> section above, about how C<Carp> decides
985 where the error is reported from.
986
987 Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
988
989 Overrides C<Carp>'s use of C<@ISA>.
990
991 =head2 %Carp::Internal
992
993 This says what packages are internal to Perl.  C<Carp> will never
994 report an error as being from a line in a package that is internal to
995 Perl.  For example:
996
997     $Carp::Internal{ (__PACKAGE__) }++;
998     # time passes...
999     sub foo { ... or confess("whatever") };
1000
1001 would give a full stack backtrace starting from the first caller
1002 outside of __PACKAGE__.  (Unless that package was also internal to
1003 Perl.)
1004
1005 =head2 %Carp::CarpInternal
1006
1007 This says which packages are internal to Perl's warning system.  For
1008 generating a full stack backtrace this is the same as being internal
1009 to Perl, the stack backtrace will not start inside packages that are
1010 listed in C<%Carp::CarpInternal>.  But it is slightly different for
1011 the summary message generated by C<carp> or C<croak>.  There errors
1012 will not be reported on any lines that are calling packages in
1013 C<%Carp::CarpInternal>.
1014
1015 For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
1016 Therefore the full stack backtrace from C<confess> will not start
1017 inside of C<Carp>, and the short message from calling C<croak> is
1018 not placed on the line where C<croak> was called.
1019
1020 =head2 $Carp::CarpLevel
1021
1022 This variable determines how many additional call frames are to be
1023 skipped that would not otherwise be when reporting where an error
1024 occurred on a call to one of C<Carp>'s functions.  It is fairly easy
1025 to count these call frames on calls that generate a full stack
1026 backtrace.  However it is much harder to do this accounting for calls
1027 that generate a short message.  Usually people skip too many call
1028 frames.  If they are lucky they skip enough that C<Carp> goes all of
1029 the way through the call stack, realizes that something is wrong, and
1030 then generates a full stack backtrace.  If they are unlucky then the
1031 error is reported from somewhere misleading very high in the call
1032 stack.
1033
1034 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
1035 C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
1036
1037 Defaults to C<0>.
1038
1039 =head1 BUGS
1040
1041 The Carp routines don't handle exception objects currently.
1042 If called with a first argument that is a reference, they simply
1043 call die() or warn(), as appropriate.
1044
1045 =head1 SEE ALSO
1046
1047 L<Carp::Always>,
1048 L<Carp::Clan>
1049
1050 =head1 CONTRIBUTING
1051
1052 L<Carp> is maintained by the perl 5 porters as part of the core perl 5
1053 version control repository. Please see the L<perlhack> perldoc for how to
1054 submit patches and contribute to it.
1055
1056 =head1 AUTHOR
1057
1058 The Carp module first appeared in Larry Wall's perl 5.000 distribution.
1059 Since then it has been modified by several of the perl 5 porters.
1060 Andrew Main (Zefram) <zefram@fysh.org> divested Carp into an independent
1061 distribution.
1062
1063 =head1 COPYRIGHT
1064
1065 Copyright (C) 1994-2013 Larry Wall
1066
1067 Copyright (C) 2011, 2012, 2013 Andrew Main (Zefram) <zefram@fysh.org>
1068
1069 =head1 LICENSE
1070
1071 This module is free software; you can redistribute it and/or modify it
1072 under the same terms as Perl itself.