lib/Carp.pm

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