lib/Carp.pm

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