lib/Carp.pm

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