dist/Carp/lib/Carp.pm

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