lib/Carp.pm

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