diff options
Diffstat (limited to 'contrib/perl5/lib/Carp/Heavy.pm')
| -rw-r--r-- | contrib/perl5/lib/Carp/Heavy.pm | 253 |
1 files changed, 253 insertions, 0 deletions
diff --git a/contrib/perl5/lib/Carp/Heavy.pm b/contrib/perl5/lib/Carp/Heavy.pm new file mode 100644 index 0000000..5e3de49 --- /dev/null +++ b/contrib/perl5/lib/Carp/Heavy.pm @@ -0,0 +1,253 @@ +package Carp; + +=head1 NAME + +Carp::Heavy - Carp guts + +=head1 SYNOPIS + +(internal use only) + +=head1 DESCRIPTION + +No user-serviceable parts inside. + +=cut + +# This package is heavily used. Be small. Be fast. Be good. + +# Comments added by Andy Wardley <abw@kfs.org> 09-Apr-98, based on an +# _almost_ complete understanding of the package. Corrections and +# comments are welcome. + +# longmess() crawls all the way up the stack reporting on all the function +# calls made. The error string, $error, is originally constructed from the +# arguments passed into longmess() via confess(), cluck() or shortmess(). +# This gets appended with the stack trace messages which are generated for +# each function call on the stack. + +sub longmess_heavy { + return @_ if ref $_[0]; + my $error = join '', @_; + my $mess = ""; + my $i = 1 + $CarpLevel; + my ($pack,$file,$line,$sub,$hargs,$eval,$require); + my (@a); + # + # crawl up the stack.... + # + while (do { { package DB; @a = caller($i++) } } ) { + # get copies of the variables returned from caller() + ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a; + # + # if the $error error string is newline terminated then it + # is copied into $mess. Otherwise, $mess gets set (at the end of + # the 'else {' section below) to one of two things. The first time + # through, it is set to the "$error at $file line $line" message. + # $error is then set to 'called' which triggers subsequent loop + # iterations to append $sub to $mess before appending the "$error + # at $file line $line" which now actually reads "called at $file line + # $line". Thus, the stack trace message is constructed: + # + # first time: $mess = $error at $file line $line + # subsequent times: $mess .= $sub $error at $file line $line + # ^^^^^^ + # "called" + if ($error =~ m/\n$/) { + $mess .= $error; + } else { + # Build a string, $sub, which names the sub-routine called. + # This may also be "require ...", "eval '...' or "eval {...}" + if (defined $eval) { + if ($require) { + $sub = "require $eval"; + } else { + $eval =~ s/([\\\'])/\\$1/g; + if ($MaxEvalLen && length($eval) > $MaxEvalLen) { + substr($eval,$MaxEvalLen) = '...'; + } + $sub = "eval '$eval'"; + } + } elsif ($sub eq '(eval)') { + $sub = 'eval {...}'; + } + # if there are any arguments in the sub-routine call, format + # them according to the format variables defined earlier in + # this file and join them onto the $sub sub-routine string + if ($hargs) { + # we may trash some of the args so we take a copy + @a = @DB::args; # must get local copy of args + # don't print any more than $MaxArgNums + if ($MaxArgNums and @a > $MaxArgNums) { + # cap the length of $#a and set the last element to '...' + $#a = $MaxArgNums; + $a[$#a] = "..."; + } + for (@a) { + # set args to the string "undef" if undefined + $_ = "undef", next unless defined $_; + if (ref $_) { + # force reference to string representation + $_ .= ''; + s/'/\\'/g; + } + else { + s/'/\\'/g; + # terminate the string early with '...' if too long + substr($_,$MaxArgLen) = '...' + if $MaxArgLen and $MaxArgLen < length; + } + # 'quote' arg unless it looks like a number + $_ = "'$_'" unless /^-?[\d.]+$/; + # print high-end chars as 'M-<char>' + s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + # print remaining control chars as ^<char> + s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + } + # append ('all', 'the', 'arguments') to the $sub string + $sub .= '(' . join(', ', @a) . ')'; + } + # here's where the error message, $mess, gets constructed + $mess .= "\t$sub " if $error eq "called"; + $mess .= "$error at $file line $line"; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $mess .= " thread $tid" if $tid; + } + $mess .= "\n"; + } + # we don't need to print the actual error message again so we can + # change this to "called" so that the string "$error at $file line + # $line" makes sense as "called at $file line $line". + $error = "called"; + } + # this kludge circumvents die's incorrect handling of NUL + my $msg = \($mess || $error); + $$msg =~ tr/\0//d; + $$msg; +} + + +# ancestors() returns the complete set of ancestors of a module + +sub ancestors($$); + +sub ancestors($$){ + my( $pack, $href ) = @_; + if( @{"${pack}::ISA"} ){ + my $risa = \@{"${pack}::ISA"}; + my %tree = (); + @tree{@$risa} = (); + foreach my $mod ( @$risa ){ + # visit ancestors - if not already in the gallery + if( ! defined( $$href{$mod} ) ){ + my @ancs = ancestors( $mod, $href ); + @tree{@ancs} = (); + } + } + return ( keys( %tree ) ); + } else { + return (); + } +} + + +# shortmess() is called by carp() and croak() to skip all the way up to +# the top-level caller's package and report the error from there. confess() +# and cluck() generate a full stack trace so they call longmess() to +# generate that. In verbose mode shortmess() calls longmess() so +# you always get a stack trace + +sub shortmess_heavy { # Short-circuit &longmess if called via multiple packages + goto &longmess_heavy if $Verbose; + return @_ if ref $_[0]; + my $error = join '', @_; + my ($prevpack) = caller(1); + my $extra = $CarpLevel; + + my @Clans = ( $prevpack ); + my $i = 2; + my ($pack,$file,$line); + # when reporting an error, we want to report it from the context of the + # calling package. So what is the calling package? Within a module, + # there may be many calls between methods and perhaps between sub-classes + # and super-classes, but the user isn't interested in what happens + # inside the package. We start by building a hash array which keeps + # track of all the packages to which the calling package belongs. We + # do this by examining its @ISA variable. Any call from a base class + # method (one of our caller's @ISA packages) can be ignored + my %isa; + + # merge all the caller's @ISA packages and ancestors into %isa. + my @pars = ancestors( $prevpack, \%isa ); + @isa{@pars} = () if @pars; + $isa{$prevpack} = 1; + + # now we crawl up the calling stack and look at all the packages in + # there. For each package, we look to see if it has an @ISA and then + # we see if our caller features in that list. That would imply that + # our caller is a derived class of that package and its calls can also + # be ignored +CALLER: + while (($pack,$file,$line) = caller($i++)) { + + # Chances are, the caller's caller (or its caller...) is already + # in the gallery - if so, ignore this caller. + next if exists( $isa{$pack} ); + + # no: collect this module's ancestors. + my @i = ancestors( $pack, \%isa ); + my %i; + if( @i ){ + @i{@i} = (); + # check whether our representative of one of the clans is + # in this family tree. + foreach my $cl (@Clans){ + if( exists( $i{$cl} ) ){ + # yes: merge all of the family tree into %isa + @isa{@i,$pack} = (); + # and here's where we do some more ignoring... + # if the package in question is one of our caller's + # base or derived packages then we can ignore it (skip it) + # and go onto the next. + next CALLER if exists( $isa{$pack} ); + last; + } + } + } + + # Hey! We've found a package that isn't one of our caller's + # clan....but wait, $extra refers to the number of 'extra' levels + # we should skip up. If $extra > 0 then this is a false alarm. + # We must merge the package into the %isa hash (so we can ignore it + # if it pops up again), decrement $extra, and continue. + if ($extra-- > 0) { + push( @Clans, $pack ); + @isa{@i,$pack} = (); + } + else { + # OK! We've got a candidate package. Time to construct the + # relevant error message and return it. die() doesn't like + # to be given NUL characters (which $msg may contain) so we + # remove them first. + my $msg; + $msg = "$error at $file line $line"; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $mess .= " thread $tid" if $tid; + } + $msg .= "\n"; + $msg =~ tr/\0//d; + return $msg; + } + } + + # uh-oh! It looks like we crawled all the way up the stack and + # never found a candidate package. Oh well, let's call longmess + # to generate a full stack trace. We use the magical form of 'goto' + # so that this shortmess() function doesn't appear on the stack + # to further confuse longmess() about it's calling package. + goto &longmess_heavy; +} + +1; |
