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