lib/Carp.pm

   1 package Carp;
   2
   3 =head1 NAME
   4
   5 carp    - warn of errors (from perspective of caller)
   6
   7 cluck   - warn of errors with stack backtrace
   8           (not exported by default)
   9
  10 croak   - die of errors (from perspective of caller)
  11
  12 confess - die of errors with stack backtrace
  13
  14 =head1 SYNOPSIS
  15
  16     use Carp;
  17     croak "We're outta here!";
  18
  19     use Carp qw(cluck);
  20     cluck "This is how we got here!";
  21
  22 =head1 DESCRIPTION
  23
  24 The Carp routines are useful in your own modules because
  25 they act like die() or warn(), but report where the error
  26 was in the code they were called from.  Thus if you have a
  27 routine Foo() that has a carp() in it, then the carp()
  28 will report the error as occurring where Foo() was called,
  29 not where carp() was called.
  30
  31 =head2 Forcing a Stack Trace
  32
  33 As a debugging aid, you can force Carp to treat a croak as a confess
  34 and a carp as a cluck across I<all> modules. In other words, force a
  35 detailed stack trace to be given.  This can be very helpful when trying
  36 to understand why, or from where, a warning or error is being generated.
  37
  38 This feature is enabled by 'importing' the non-existent symbol
  39 'verbose'. You would typically enable it by saying
  40
  41     perl -MCarp=verbose script.pl
  42
  43 or by including the string C<MCarp=verbose> in the L<PERL5OPT>
  44 environment variable.
  45
  46 =head1 BUGS
  47
  48 The Carp routines don't handle exception objects currently.
  49 If called with a first argument that is a reference, they simply
  50 call die() or warn(), as appropriate.
  51
  52 =cut
  53
  54 # This package is heavily used. Be small. Be fast. Be good.
  55
  56 # Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
  57 # _almost_ complete understanding of the package.  Corrections and
  58 # comments are welcome.
  59
  60 # The $CarpLevel variable can be set to "strip off" extra caller levels for
  61 # those times when Carp calls are buried inside other functions.  The
  62 # $Max(EvalLen|(Arg(Len|Nums)) variables are used to specify how the eval
  63 # text and function arguments should be formatted when printed.
  64
  65 $CarpLevel = 0;         # How many extra package levels to skip on carp.
  66 $MaxEvalLen = 0;        # How much eval '...text...' to show. 0 = all.
  67 $MaxArgLen = 64;        # How much of each argument to print. 0 = all.
  68 $MaxArgNums = 8;        # How many arguments to print. 0 = all.
  69 $Verbose = 0;           # If true then make shortmess call longmess instead
  70
  71 require Exporter;
  72 @ISA = ('Exporter');
  73 @EXPORT = qw(confess croak carp);
  74 @EXPORT_OK = qw(cluck verbose);
  75 @EXPORT_FAIL = qw(verbose);     # hook to enable verbose mode
  76
  77
  78 # if the caller specifies verbose usage ("perl -MCarp=verbose script.pl")
  79 # then the following method will be called by the Exporter which knows
  80 # to do this thanks to @EXPORT_FAIL, above.  $_[1] will contain the word
  81 # 'verbose'.
  82
  83 sub export_fail {
  84     shift;
  85     $Verbose = shift if $_[0] eq 'verbose';
  86     return @_;
  87 }
  88
  89
  90 # longmess() crawls all the way up the stack reporting on all the function
  91 # calls made.  The error string, $error, is originally constructed from the
  92 # arguments passed into longmess() via confess(), cluck() or shortmess().
  93 # This gets appended with the stack trace messages which are generated for
  94 # each function call on the stack.
  95
  96 sub longmess {
  97     return @_ if ref $_[0];
  98     my $error = join '', @_;
  99     my $mess = "";
 100     my $i = 1 + $CarpLevel;
 101     my ($pack,$file,$line,$sub,$hargs,$eval,$require);
 102     my (@a);
 103     #
 104     # crawl up the stack....
 105     #
 106     while (do { { package DB; @a = caller($i++) } } ) {
 107         # get copies of the variables returned from caller()
 108         ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
 109         #
 110         # if the $error error string is newline terminated then it
 111         # is copied into $mess.  Otherwise, $mess gets set (at the end of
 112         # the 'else {' section below) to one of two things.  The first time
 113         # through, it is set to the "$error at $file line $line" message.
 114         # $error is then set to 'called' which triggers subsequent loop
 115         # iterations to append $sub to $mess before appending the "$error
 116         # at $file line $line" which now actually reads "called at $file line
 117         # $line".  Thus, the stack trace message is constructed:
 118         #
 119         #        first time: $mess  = $error at $file line $line
 120         #  subsequent times: $mess .= $sub $error at $file line $line
 121         #                                  ^^^^^^
 122         #                                 "called"
 123         if ($error =~ m/\n$/) {
 124             $mess .= $error;
 125         } else {
 126             # Build a string, $sub, which names the sub-routine called.
 127             # This may also be "require ...", "eval '...' or "eval {...}"
 128             if (defined $eval) {
 129                 if ($require) {
 130                     $sub = "require $eval";
 131                 } else {
 132                     $eval =~ s/([\\\'])/\\$1/g;
 133                     if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
 134                         substr($eval,$MaxEvalLen) = '...';
 135                     }
 136                     $sub = "eval '$eval'";
 137                 }
 138             } elsif ($sub eq '(eval)') {
 139                 $sub = 'eval {...}';
 140             }
 141             # if there are any arguments in the sub-routine call, format
 142             # them according to the format variables defined earlier in
 143             # this file and join them onto the $sub sub-routine string
 144             if ($hargs) {
 145                 # we may trash some of the args so we take a copy
 146                 @a = @DB::args; # must get local copy of args
 147                 # don't print any more than $MaxArgNums
 148                 if ($MaxArgNums and @a > $MaxArgNums) {
 149                     # cap the length of $#a and set the last element to '...'
 150                     $#a = $MaxArgNums;
 151                     $a[$#a] = "...";
 152                 }
 153                 for (@a) {
 154                     # set args to the string "undef" if undefined
 155                     $_ = "undef", next unless defined $_;
 156                     if (ref $_) {
 157                         # dunno what this is for...
 158                         $_ .= '';
 159                         s/'/\\'/g;
 160                     }
 161                     else {
 162                         s/'/\\'/g;
 163                         # terminate the string early with '...' if too long
 164                         substr($_,$MaxArgLen) = '...'
 165                             if $MaxArgLen and $MaxArgLen < length;
 166                     }
 167                     # 'quote' arg unless it looks like a number
 168                     $_ = "'$_'" unless /^-?[\d.]+$/;
 169                     # print high-end chars as 'M-<char>' or '^<char>'
 170                     s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
 171                     s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
 172                 }
 173                 # append ('all', 'the', 'arguments') to the $sub string
 174                 $sub .= '(' . join(', ', @a) . ')';
 175             }
 176             # here's where the error message, $mess, gets constructed
 177             $mess .= "\t$sub " if $error eq "called";
 178             $mess .= "$error at $file line $line";
 179             if (exists $main::{'Thread::'}) {
 180                 my $tid = Thread->self->tid;
 181                 $mess .= " thread $tid" if $tid;
 182             }
 183             $mess .= "\n";
 184         }
 185         # we don't need to print the actual error message again so we can
 186         # change this to "called" so that the string "$error at $file line
 187         # $line" makes sense as "called at $file line $line".
 188         $error = "called";
 189     }
 190     # this kludge circumvents die's incorrect handling of NUL
 191     my $msg = \($mess || $error);
 192     $$msg =~ tr/\0//d;
 193     $$msg;
 194 }
 195
 196
 197 # shortmess() is called by carp() and croak() to skip all the way up to
 198 # the top-level caller's package and report the error from there.  confess()
 199 # and cluck() generate a full stack trace so they call longmess() to
 200 # generate that.  In verbose mode shortmess() calls longmess() so
 201 # you always get a stack trace
 202
 203 sub shortmess { # Short-circuit &longmess if called via multiple packages
 204     goto &longmess if $Verbose;
 205     return @_ if ref $_[0];
 206     my $error = join '', @_;
 207     my ($prevpack) = caller(1);
 208     my $extra = $CarpLevel;
 209     my $i = 2;
 210     my ($pack,$file,$line);
 211     # when reporting an error, we want to report it from the context of the
 212     # calling package.  So what is the calling package?  Within a module,
 213     # there may be many calls between methods and perhaps between sub-classes
 214     # and super-classes, but the user isn't interested in what happens
 215     # inside the package.  We start by building a hash array which keeps
 216     # track of all the packages to which the calling package belongs.  We
 217     # do this by examining its @ISA variable.  Any call from a base class
 218     # method (one of our caller's @ISA packages) can be ignored
 219     my %isa = ($prevpack,1);
 220
 221     # merge all the caller's @ISA packages into %isa.
 222     @isa{@{"${prevpack}::ISA"}} = ()
 223         if(@{"${prevpack}::ISA"});
 224
 225     # now we crawl up the calling stack and look at all the packages in
 226     # there.  For each package, we look to see if it has an @ISA and then
 227     # we see if our caller features in that list.  That would imply that
 228     # our caller is a derived class of that package and its calls can also
 229     # be ignored
 230     while (($pack,$file,$line) = caller($i++)) {
 231         if(@{$pack . "::ISA"}) {
 232             my @i = @{$pack . "::ISA"};
 233             my %i;
 234             @i{@i} = ();
 235             # merge any relevant packages into %isa
 236             @isa{@i,$pack} = ()
 237                 if(exists $i{$prevpack} || exists $isa{$pack});
 238         }
 239
 240         # and here's where we do the ignoring... if the package in
 241         # question is one of our caller's base or derived packages then
 242         # we can ignore it (skip it) and go onto the next (but note that
 243         # the continue { } block below gets called every time)
 244         next
 245             if(exists $isa{$pack});
 246
 247         # Hey!  We've found a package that isn't one of our caller's
 248         # clan....but wait, $extra refers to the number of 'extra' levels
 249         # we should skip up.  If $extra > 0 then this is a false alarm.
 250         # We must merge the package into the %isa hash (so we can ignore it
 251         # if it pops up again), decrement $extra, and continue.
 252         if ($extra-- > 0) {
 253             %isa = ($pack,1);
 254             @isa{@{$pack . "::ISA"}} = ()
 255                 if(@{$pack . "::ISA"});
 256         }
 257         else {
 258             # OK!  We've got a candidate package.  Time to construct the
 259             # relevant error message and return it.   die() doesn't like
 260             # to be given NUL characters (which $msg may contain) so we
 261             # remove them first.
 262             my $msg;
 263             $msg = "$error at $file line $line";
 264             if (exists $main::{'Thread::'}) {
 265                 my $tid = Thread->self->tid;
 266                 $mess .= " thread $tid" if $tid;
 267             }
 268             $msg .= "\n";
 269             $msg =~ tr/\0//d;
 270             return $msg;
 271         }
 272     }
 273     continue {
 274         $prevpack = $pack;
 275     }
 276
 277     # uh-oh!  It looks like we crawled all the way up the stack and
 278     # never found a candidate package.  Oh well, let's call longmess
 279     # to generate a full stack trace.  We use the magical form of 'goto'
 280     # so that this shortmess() function doesn't appear on the stack
 281     # to further confuse longmess() about it's calling package.
 282     goto &longmess;
 283 }
 284
 285
 286 # the following four functions call longmess() or shortmess() depending on
 287 # whether they should generate a full stack trace (confess() and cluck())
 288 # or simply report the caller's package (croak() and carp()), respectively.
 289 # confess() and croak() die, carp() and cluck() warn.
 290
 291 sub croak   { die  shortmess @_ }
 292 sub confess { die  longmess  @_ }
 293 sub carp    { warn shortmess @_ }
 294 sub cluck   { warn longmess  @_ }
 295
 296 1;