lib/Carp.pm

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