lib/Carp/Heavy.pm

   1 package Carp;
   2 # This package is heavily used. Be small. Be fast. Be good.
   3
   4 # Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an
   5 # _almost_ complete understanding of the package.  Corrections and
   6 # comments are welcome.
   7
   8 # longmess() crawls all the way up the stack reporting on all the function
   9 # calls made.  The error string, $error, is originally constructed from the
  10 # arguments passed into longmess() via confess(), cluck() or shortmess().
  11 # This gets appended with the stack trace messages which are generated for
  12 # each function call on the stack.
  13
  14 sub longmess_heavy {
  15     return @_ if ref $_[0];
  16     my $error = join '', @_;
  17     my $mess = "";
  18     my $i = 1 + $CarpLevel;
  19     my ($pack,$file,$line,$sub,$hargs,$eval,$require);
  20     my (@a);
  21     #
  22     # crawl up the stack....
  23     #
  24     while (do { { package DB; @a = caller($i++) } } ) {
  25         # get copies of the variables returned from caller()
  26         ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
  27         #
  28         # if the $error error string is newline terminated then it
  29         # is copied into $mess.  Otherwise, $mess gets set (at the end of
  30         # the 'else {' section below) to one of two things.  The first time
  31         # through, it is set to the "$error at $file line $line" message.
  32         # $error is then set to 'called' which triggers subsequent loop
  33         # iterations to append $sub to $mess before appending the "$error
  34         # at $file line $line" which now actually reads "called at $file line
  35         # $line".  Thus, the stack trace message is constructed:
  36         #
  37         #        first time: $mess  = $error at $file line $line
  38         #  subsequent times: $mess .= $sub $error at $file line $line
  39         #                                  ^^^^^^
  40         #                                 "called"
  41         if ($error =~ m/\n$/) {
  42             $mess .= $error;
  43         } else {
  44             # Build a string, $sub, which names the sub-routine called.
  45             # This may also be "require ...", "eval '...' or "eval {...}"
  46             if (defined $eval) {
  47                 if ($require) {
  48                     $sub = "require $eval";
  49                 } else {
  50                     $eval =~ s/([\\\'])/\\$1/g;
  51                     if ($MaxEvalLen && length($eval) > $MaxEvalLen) {
  52                         substr($eval,$MaxEvalLen) = '...';
  53                     }
  54                     $sub = "eval '$eval'";
  55                 }
  56             } elsif ($sub eq '(eval)') {
  57                 $sub = 'eval {...}';
  58             }
  59             # if there are any arguments in the sub-routine call, format
  60             # them according to the format variables defined earlier in
  61             # this file and join them onto the $sub sub-routine string
  62             if ($hargs) {
  63                 # we may trash some of the args so we take a copy
  64                 @a = @DB::args; # must get local copy of args
  65                 # don't print any more than $MaxArgNums
  66                 if ($MaxArgNums and @a > $MaxArgNums) {
  67                     # cap the length of $#a and set the last element to '...'
  68                     $#a = $MaxArgNums;
  69                     $a[$#a] = "...";
  70                 }
  71                 for (@a) {
  72                     # set args to the string "undef" if undefined
  73                     $_ = "undef", next unless defined $_;
  74                     if (ref $_) {
  75                         # dunno what this is for...
  76                         $_ .= '';
  77                         s/'/\\'/g;
  78                     }
  79                     else {
  80                         s/'/\\'/g;
  81                         # terminate the string early with '...' if too long
  82                         substr($_,$MaxArgLen) = '...'
  83                             if $MaxArgLen and $MaxArgLen < length;
  84                     }
  85                     # 'quote' arg unless it looks like a number
  86                     $_ = "'$_'" unless /^-?[\d.]+$/;
  87                     # print high-end chars as 'M-<char>'
  88                     s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
  89                     # print remaining control chars as ^<char>
  90                     s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
  91                 }
  92                 # append ('all', 'the', 'arguments') to the $sub string
  93                 $sub .= '(' . join(', ', @a) . ')';
  94             }
  95             # here's where the error message, $mess, gets constructed
  96             $mess .= "\t$sub " if $error eq "called";
  97             $mess .= "$error at $file line $line";
  98             if (defined &Thread::tid) {
  99                 my $tid = Thread->self->tid;
 100                 $mess .= " thread $tid" if $tid;
 101             }
 102             $mess .= "\n";
 103         }
 104         # we don't need to print the actual error message again so we can
 105         # change this to "called" so that the string "$error at $file line
 106         # $line" makes sense as "called at $file line $line".
 107         $error = "called";
 108     }
 109     # this kludge circumvents die's incorrect handling of NUL
 110     my $msg = \($mess || $error);
 111     $$msg =~ tr/\0//d;
 112     $$msg;
 113 }
 114
 115
 116 # shortmess() is called by carp() and croak() to skip all the way up to
 117 # the top-level caller's package and report the error from there.  confess()
 118 # and cluck() generate a full stack trace so they call longmess() to
 119 # generate that.  In verbose mode shortmess() calls longmess() so
 120 # you always get a stack trace
 121
 122 sub shortmess_heavy {   # Short-circuit &longmess if called via multiple packages
 123     goto &longmess_heavy if $Verbose;
 124     return @_ if ref $_[0];
 125     my $error = join '', @_;
 126     my ($prevpack) = caller(1);
 127     my $extra = $CarpLevel;
 128     my $i = 2;
 129     my ($pack,$file,$line);
 130     # when reporting an error, we want to report it from the context of the
 131     # calling package.  So what is the calling package?  Within a module,
 132     # there may be many calls between methods and perhaps between sub-classes
 133     # and super-classes, but the user isn't interested in what happens
 134     # inside the package.  We start by building a hash array which keeps
 135     # track of all the packages to which the calling package belongs.  We
 136     # do this by examining its @ISA variable.  Any call from a base class
 137     # method (one of our caller's @ISA packages) can be ignored
 138     my %isa = ($prevpack,1);
 139
 140     # merge all the caller's @ISA packages into %isa.
 141     @isa{@{"${prevpack}::ISA"}} = ()
 142         if(@{"${prevpack}::ISA"});
 143
 144     # now we crawl up the calling stack and look at all the packages in
 145     # there.  For each package, we look to see if it has an @ISA and then
 146     # we see if our caller features in that list.  That would imply that
 147     # our caller is a derived class of that package and its calls can also
 148     # be ignored
 149     while (($pack,$file,$line) = caller($i++)) {
 150         if(@{$pack . "::ISA"}) {
 151             my @i = @{$pack . "::ISA"};
 152             my %i;
 153             @i{@i} = ();
 154             # merge any relevant packages into %isa
 155             @isa{@i,$pack} = ()
 156                 if(exists $i{$prevpack} || exists $isa{$pack});
 157         }
 158
 159         # and here's where we do the ignoring... if the package in
 160         # question is one of our caller's base or derived packages then
 161         # we can ignore it (skip it) and go onto the next (but note that
 162         # the continue { } block below gets called every time)
 163         next
 164             if(exists $isa{$pack});
 165
 166         # Hey!  We've found a package that isn't one of our caller's
 167         # clan....but wait, $extra refers to the number of 'extra' levels
 168         # we should skip up.  If $extra > 0 then this is a false alarm.
 169         # We must merge the package into the %isa hash (so we can ignore it
 170         # if it pops up again), decrement $extra, and continue.
 171         if ($extra-- > 0) {
 172             %isa = ($pack,1);
 173             @isa{@{$pack . "::ISA"}} = ()
 174                 if(@{$pack . "::ISA"});
 175         }
 176         else {
 177             # OK!  We've got a candidate package.  Time to construct the
 178             # relevant error message and return it.   die() doesn't like
 179             # to be given NUL characters (which $msg may contain) so we
 180             # remove them first.
 181             my $msg;
 182             $msg = "$error at $file line $line";
 183             if (defined &Thread::tid) {
 184                 my $tid = Thread->self->tid;
 185                 $mess .= " thread $tid" if $tid;
 186             }
 187             $msg .= "\n";
 188             $msg =~ tr/\0//d;
 189             return $msg;
 190         }
 191     }
 192     continue {
 193         $prevpack = $pack;
 194     }
 195
 196     # uh-oh!  It looks like we crawled all the way up the stack and
 197     # never found a candidate package.  Oh well, let's call longmess
 198     # to generate a full stack trace.  We use the magical form of 'goto'
 199     # so that this shortmess() function doesn't appear on the stack
 200     # to further confuse longmess() about it's calling package.
 201     goto &longmess_heavy;
 202 }
 203
 204 1;