lib/Carp.pm

   1 package Carp;
   2
   3 our $VERSION = '1.19';
   4
   5 our $MaxEvalLen = 0;
   6 our $Verbose    = 0;
   7 our $CarpLevel  = 0;
   8 our $MaxArgLen  = 64;   # How much of each argument to print. 0 = all.
   9 our $MaxArgNums = 8;    # How many arguments to print. 0 = all.
  10
  11 require Exporter;
  12 our @ISA = ('Exporter');
  13 our @EXPORT = qw(confess croak carp);
  14 our @EXPORT_OK = qw(cluck verbose longmess shortmess);
  15 our @EXPORT_FAIL = qw(verbose); # hook to enable verbose mode
  16
  17 # The members of %Internal are packages that are internal to perl.
  18 # Carp will not report errors from within these packages if it
  19 # can.  The members of %CarpInternal are internal to Perl's warning
  20 # system.  Carp will not report errors from within these packages
  21 # either, and will not report calls *to* these packages for carp and
  22 # croak.  They replace $CarpLevel, which is deprecated.    The
  23 # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
  24 # text and function arguments should be formatted when printed.
  25
  26 # disable these by default, so they can live w/o require Carp
  27 $CarpInternal{Carp}++;
  28 $CarpInternal{warnings}++;
  29 $Internal{Exporter}++;
  30 $Internal{'Exporter::Heavy'}++;
  31
  32 # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
  33 # then the following method will be called by the Exporter which knows
  34 # to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
  35 # 'verbose'.
  36
  37 sub export_fail { shift; $Verbose = shift if $_[0] eq 'verbose'; @_ }
  38
  39 sub longmess {
  40     # Icky backwards compatibility wrapper. :-(
  41     #
  42     # The story is that the original implementation hard-coded the
  43     # number of call levels to go back, so calls to longmess were off
  44     # by one.  Other code began calling longmess and expecting this
  45     # behaviour, so the replacement has to emulate that behaviour.
  46     my $call_pack = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : caller();
  47     if ($Internal{$call_pack} or $CarpInternal{$call_pack}) {
  48       return longmess_heavy(@_);
  49     }
  50     else {
  51       local $CarpLevel = $CarpLevel + 1;
  52       return longmess_heavy(@_);
  53     }
  54 };
  55
  56 sub shortmess {
  57     # Icky backwards compatibility wrapper. :-(
  58     local @CARP_NOT = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}() : caller();
  59     shortmess_heavy(@_);
  60 };
  61
  62 sub croak   { die  shortmess @_ }
  63 sub confess { die  longmess  @_ }
  64 sub carp    { warn shortmess @_ }
  65 sub cluck   { warn longmess  @_ }
  66
  67 sub caller_info {
  68   my $i = shift(@_) + 1;
  69   my %call_info;
  70   {
  71   package DB;
  72   @args = \$i; # A sentinal, which no-one else has the address of
  73   @call_info{
  74     qw(pack file line sub has_args wantarray evaltext is_require)
  75   } = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
  76   }
  77
  78   unless (defined $call_info{pack}) {
  79     return ();
  80   }
  81
  82   my $sub_name = Carp::get_subname(\%call_info);
  83   if ($call_info{has_args}) {
  84     my @args;
  85     if (@DB::args == 1 && ref $DB::args[0] eq ref \$i && $DB::args[0] == \$i) {
  86       @DB::args = (); # Don't let anyone see the address of $i
  87       local $@;
  88       my $where = eval {
  89         my $func = defined &{"CORE::GLOBAL::caller"} ? \&{"CORE::GLOBAL::caller"} : return '';
  90         my $gv = B::svref_2object($func)->GV;
  91         my $package = $gv->STASH->NAME;
  92         my $subname = $gv->NAME;
  93         return unless defined $package && defined $subname;
  94         # returning CORE::GLOBAL::caller isn't useful for tracing the cause:
  95         return if $package eq 'CORE::GLOBAL' && $subname eq 'caller';
  96         " in &${package}::$subname";
  97       } // '';
  98       @args = "** Incomplete caller override detected$where; \@DB::args were not set **";
  99     } else {
 100       @args = map {Carp::format_arg($_)} @DB::args;
 101     }
 102     if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show?
 103       $#args = $MaxArgNums;
 104       push @args, '...';
 105     }
 106     # Push the args onto the subroutine
 107     $sub_name .= '(' . join (', ', @args) . ')';
 108   }
 109   $call_info{sub_name} = $sub_name;
 110   return wantarray() ? %call_info : \%call_info;
 111 }
 112
 113 # Transform an argument to a function into a string.
 114 sub format_arg {
 115   my $arg = shift;
 116   if (ref($arg)) {
 117       $arg = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
 118   }
 119   if (defined($arg)) {
 120       $arg =~ s/'/\\'/g;
 121       $arg = str_len_trim($arg, $MaxArgLen);
 122
 123       # Quote it?
 124       $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/;
 125   } else {
 126       $arg = 'undef';
 127   }
 128
 129   # The following handling of "control chars" is direct from
 130   # the original code - it is broken on Unicode though.
 131   # Suggestions?
 132   utf8::is_utf8($arg)
 133     or $arg =~ s/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
 134   return $arg;
 135 }
 136
 137 # Takes an inheritance cache and a package and returns
 138 # an anon hash of known inheritances and anon array of
 139 # inheritances which consequences have not been figured
 140 # for.
 141 sub get_status {
 142     my $cache = shift;
 143     my $pkg = shift;
 144     $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]];
 145     return @{$cache->{$pkg}};
 146 }
 147
 148 # Takes the info from caller() and figures out the name of
 149 # the sub/require/eval
 150 sub get_subname {
 151   my $info = shift;
 152   if (defined($info->{evaltext})) {
 153     my $eval = $info->{evaltext};
 154     if ($info->{is_require}) {
 155       return "require $eval";
 156     }
 157     else {
 158       $eval =~ s/([\\\'])/\\$1/g;
 159       return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
 160     }
 161   }
 162
 163   return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
 164 }
 165
 166 # Figures out what call (from the point of view of the caller)
 167 # the long error backtrace should start at.
 168 sub long_error_loc {
 169   my $i;
 170   my $lvl = $CarpLevel;
 171   {
 172     ++$i;
 173     my $pkg = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
 174     unless(defined($pkg)) {
 175       # This *shouldn't* happen.
 176       if (%Internal) {
 177         local %Internal;
 178         $i = long_error_loc();
 179         last;
 180       }
 181       else {
 182         # OK, now I am irritated.
 183         return 2;
 184       }
 185     }
 186     redo if $CarpInternal{$pkg};
 187     redo unless 0 > --$lvl;
 188     redo if $Internal{$pkg};
 189   }
 190   return $i - 1;
 191 }
 192
 193
 194 sub longmess_heavy {
 195   return @_ if ref($_[0]); # don't break references as exceptions
 196   my $i = long_error_loc();
 197   return ret_backtrace($i, @_);
 198 }
 199
 200 # Returns a full stack backtrace starting from where it is
 201 # told.
 202 sub ret_backtrace {
 203   my ($i, @error) = @_;
 204   my $mess;
 205   my $err = join '', @error;
 206   $i++;
 207
 208   my $tid_msg = '';
 209   if (defined &threads::tid) {
 210     my $tid = threads->tid;
 211     $tid_msg = " thread $tid" if $tid;
 212   }
 213
 214   my %i = caller_info($i);
 215   $mess = "$err at $i{file} line $i{line}$tid_msg\n";
 216
 217   while (my %i = caller_info(++$i)) {
 218       $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n";
 219   }
 220
 221   return $mess;
 222 }
 223
 224 sub ret_summary {
 225   my ($i, @error) = @_;
 226   my $err = join '', @error;
 227   $i++;
 228
 229   my $tid_msg = '';
 230   if (defined &threads::tid) {
 231     my $tid = threads->tid;
 232     $tid_msg = " thread $tid" if $tid;
 233   }
 234
 235   my %i = caller_info($i);
 236   return "$err at $i{file} line $i{line}$tid_msg\n";
 237 }
 238
 239
 240 sub short_error_loc {
 241   # You have to create your (hash)ref out here, rather than defaulting it
 242   # inside trusts *on a lexical*, as you want it to persist across calls.
 243   # (You can default it on $_[2], but that gets messy)
 244   my $cache = {};
 245   my $i = 1;
 246   my $lvl = $CarpLevel;
 247   {
 248
 249     my $called = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
 250     $i++;
 251     my $caller = defined &{"CORE::GLOBAL::caller"} ? &{"CORE::GLOBAL::caller"}($i) : caller($i);
 252
 253     return 0 unless defined($caller); # What happened?
 254     redo if $Internal{$caller};
 255     redo if $CarpInternal{$caller};
 256     redo if $CarpInternal{$called};
 257     redo if trusts($called, $caller, $cache);
 258     redo if trusts($caller, $called, $cache);
 259     redo unless 0 > --$lvl;
 260   }
 261   return $i - 1;
 262 }
 263
 264
 265 sub shortmess_heavy {
 266   return longmess_heavy(@_) if $Verbose;
 267   return @_ if ref($_[0]); # don't break references as exceptions
 268   my $i = short_error_loc();
 269   if ($i) {
 270     ret_summary($i, @_);
 271   }
 272   else {
 273     longmess_heavy(@_);
 274   }
 275 }
 276
 277 # If a string is too long, trims it with ...
 278 sub str_len_trim {
 279   my $str = shift;
 280   my $max = shift || 0;
 281   if (2 < $max and $max < length($str)) {
 282     substr($str, $max - 3) = '...';
 283   }
 284   return $str;
 285 }
 286
 287 # Takes two packages and an optional cache.  Says whether the
 288 # first inherits from the second.
 289 #
 290 # Recursive versions of this have to work to avoid certain
 291 # possible endless loops, and when following long chains of
 292 # inheritance are less efficient.
 293 sub trusts {
 294     my $child = shift;
 295     my $parent = shift;
 296     my $cache = shift;
 297     my ($known, $partial) = get_status($cache, $child);
 298     # Figure out consequences until we have an answer
 299     while (@$partial and not exists $known->{$parent}) {
 300         my $anc = shift @$partial;
 301         next if exists $known->{$anc};
 302         $known->{$anc}++;
 303         my ($anc_knows, $anc_partial) = get_status($cache, $anc);
 304         my @found = keys %$anc_knows;
 305         @$known{@found} = ();
 306         push @$partial, @$anc_partial;
 307     }
 308     return exists $known->{$parent};
 309 }
 310
 311 # Takes a package and gives a list of those trusted directly
 312 sub trusts_directly {
 313     my $class = shift;
 314     no strict 'refs';
 315     no warnings 'once';
 316     return @{"$class\::CARP_NOT"}
 317       ? @{"$class\::CARP_NOT"}
 318       : @{"$class\::ISA"};
 319 }
 320
 321 1;
 322
 323 __END__
 324
 325 =head1 NAME
 326
 327 carp    - warn of errors (from perspective of caller)
 328
 329 cluck   - warn of errors with stack backtrace
 330           (not exported by default)
 331
 332 croak   - die of errors (from perspective of caller)
 333
 334 confess - die of errors with stack backtrace
 335
 336 =head1 SYNOPSIS
 337
 338     use Carp;
 339     croak "We're outta here!";
 340
 341     use Carp qw(cluck);
 342     cluck "This is how we got here!";
 343
 344 =head1 DESCRIPTION
 345
 346 The Carp routines are useful in your own modules because
 347 they act like die() or warn(), but with a message which is more
 348 likely to be useful to a user of your module.  In the case of
 349 cluck, confess, and longmess that context is a summary of every
 350 call in the call-stack.  For a shorter message you can use C<carp>
 351 or C<croak> which report the error as being from where your module
 352 was called.  There is no guarantee that that is where the error
 353 was, but it is a good educated guess.
 354
 355 You can also alter the way the output and logic of C<Carp> works, by
 356 changing some global variables in the C<Carp> namespace. See the
 357 section on C<GLOBAL VARIABLES> below.
 358
 359 Here is a more complete description of how C<carp> and C<croak> work.
 360 What they do is search the call-stack for a function call stack where
 361 they have not been told that there shouldn't be an error.  If every
 362 call is marked safe, they give up and give a full stack backtrace
 363 instead.  In other words they presume that the first likely looking
 364 potential suspect is guilty.  Their rules for telling whether
 365 a call shouldn't generate errors work as follows:
 366
 367 =over 4
 368
 369 =item 1.
 370
 371 Any call from a package to itself is safe.
 372
 373 =item 2.
 374
 375 Packages claim that there won't be errors on calls to or from
 376 packages explicitly marked as safe by inclusion in C<@CARP_NOT>, or
 377 (if that array is empty) C<@ISA>.  The ability to override what
 378 @ISA says is new in 5.8.
 379
 380 =item 3.
 381
 382 The trust in item 2 is transitive.  If A trusts B, and B
 383 trusts C, then A trusts C.  So if you do not override C<@ISA>
 384 with C<@CARP_NOT>, then this trust relationship is identical to,
 385 "inherits from".
 386
 387 =item 4.
 388
 389 Any call from an internal Perl module is safe.  (Nothing keeps
 390 user modules from marking themselves as internal to Perl, but
 391 this practice is discouraged.)
 392
 393 =item 5.
 394
 395 Any call to Perl's warning system (eg Carp itself) is safe.
 396 (This rule is what keeps it from reporting the error at the
 397 point where you call C<carp> or C<croak>.)
 398
 399 =item 6.
 400
 401 C<$Carp::CarpLevel> can be set to skip a fixed number of additional
 402 call levels.  Using this is not recommended because it is very
 403 difficult to get it to behave correctly.
 404
 405 =back
 406
 407 =head2 Forcing a Stack Trace
 408
 409 As a debugging aid, you can force Carp to treat a croak as a confess
 410 and a carp as a cluck across I<all> modules. In other words, force a
 411 detailed stack trace to be given.  This can be very helpful when trying
 412 to understand why, or from where, a warning or error is being generated.
 413
 414 This feature is enabled by 'importing' the non-existent symbol
 415 'verbose'. You would typically enable it by saying
 416
 417     perl -MCarp=verbose script.pl
 418
 419 or by including the string C<-MCarp=verbose> in the PERL5OPT
 420 environment variable.
 421
 422 Alternately, you can set the global variable C<$Carp::Verbose> to true.
 423 See the C<GLOBAL VARIABLES> section below.
 424
 425 =head1 GLOBAL VARIABLES
 426
 427 =head2 $Carp::MaxEvalLen
 428
 429 This variable determines how many characters of a string-eval are to
 430 be shown in the output. Use a value of C<0> to show all text.
 431
 432 Defaults to C<0>.
 433
 434 =head2 $Carp::MaxArgLen
 435
 436 This variable determines how many characters of each argument to a
 437 function to print. Use a value of C<0> to show the full length of the
 438 argument.
 439
 440 Defaults to C<64>.
 441
 442 =head2 $Carp::MaxArgNums
 443
 444 This variable determines how many arguments to each function to show.
 445 Use a value of C<0> to show all arguments to a function call.
 446
 447 Defaults to C<8>.
 448
 449 =head2 $Carp::Verbose
 450
 451 This variable makes C<carp> and C<croak> generate stack backtraces
 452 just like C<cluck> and C<confess>.  This is how C<use Carp 'verbose'>
 453 is implemented internally.
 454
 455 Defaults to C<0>.
 456
 457 =head2 @CARP_NOT
 458
 459 This variable, I<in your package>, says which packages are I<not> to be
 460 considered as the location of an error. The C<carp()> and C<cluck()>
 461 functions will skip over callers when reporting where an error occurred.
 462
 463 NB: This variable must be in the package's symbol table, thus:
 464
 465     # These work
 466     our @CARP_NOT; # file scope
 467     use vars qw(@CARP_NOT); # package scope
 468     @My::Package::CARP_NOT = ... ; # explicit package variable
 469
 470     # These don't work
 471     sub xyz { ... @CARP_NOT = ... } # w/o declarations above
 472     my @CARP_NOT; # even at top-level
 473
 474 Example of use:
 475
 476     package My::Carping::Package;
 477     use Carp;
 478     our @CARP_NOT;
 479     sub bar     { .... or _error('Wrong input') }
 480     sub _error  {
 481         # temporary control of where'ness, __PACKAGE__ is implicit
 482         local @CARP_NOT = qw(My::Friendly::Caller);
 483         carp(@_)
 484     }
 485
 486 This would make C<Carp> report the error as coming from a caller not
 487 in C<My::Carping::Package>, nor from C<My::Friendly::Caller>.
 488
 489 Also read the L</DESCRIPTION> section above, about how C<Carp> decides
 490 where the error is reported from.
 491
 492 Use C<@CARP_NOT>, instead of C<$Carp::CarpLevel>.
 493
 494 Overrides C<Carp>'s use of C<@ISA>.
 495
 496 =head2 %Carp::Internal
 497
 498 This says what packages are internal to Perl.  C<Carp> will never
 499 report an error as being from a line in a package that is internal to
 500 Perl.  For example:
 501
 502     $Carp::Internal{ (__PACKAGE__) }++;
 503     # time passes...
 504     sub foo { ... or confess("whatever") };
 505
 506 would give a full stack backtrace starting from the first caller
 507 outside of __PACKAGE__.  (Unless that package was also internal to
 508 Perl.)
 509
 510 =head2 %Carp::CarpInternal
 511
 512 This says which packages are internal to Perl's warning system.  For
 513 generating a full stack backtrace this is the same as being internal
 514 to Perl, the stack backtrace will not start inside packages that are
 515 listed in C<%Carp::CarpInternal>.  But it is slightly different for
 516 the summary message generated by C<carp> or C<croak>.  There errors
 517 will not be reported on any lines that are calling packages in
 518 C<%Carp::CarpInternal>.
 519
 520 For example C<Carp> itself is listed in C<%Carp::CarpInternal>.
 521 Therefore the full stack backtrace from C<confess> will not start
 522 inside of C<Carp>, and the short message from calling C<croak> is
 523 not placed on the line where C<croak> was called.
 524
 525 =head2 $Carp::CarpLevel
 526
 527 This variable determines how many additional call frames are to be
 528 skipped that would not otherwise be when reporting where an error
 529 occurred on a call to one of C<Carp>'s functions.  It is fairly easy
 530 to count these call frames on calls that generate a full stack
 531 backtrace.  However it is much harder to do this accounting for calls
 532 that generate a short message.  Usually people skip too many call
 533 frames.  If they are lucky they skip enough that C<Carp> goes all of
 534 the way through the call stack, realizes that something is wrong, and
 535 then generates a full stack backtrace.  If they are unlucky then the
 536 error is reported from somewhere misleading very high in the call
 537 stack.
 538
 539 Therefore it is best to avoid C<$Carp::CarpLevel>.  Instead use
 540 C<@CARP_NOT>, C<%Carp::Internal> and C<%Carp::CarpInternal>.
 541
 542 Defaults to C<0>.
 543
 544 =head1 BUGS
 545
 546 The Carp routines don't handle exception objects currently.
 547 If called with a first argument that is a reference, they simply
 548 call die() or warn(), as appropriate.
 549