diff options
Diffstat (limited to 'contrib/perl5/lib/Carp/Heavy.pm')
| -rw-r--r-- | contrib/perl5/lib/Carp/Heavy.pm | 247 |
1 files changed, 0 insertions, 247 deletions
diff --git a/contrib/perl5/lib/Carp/Heavy.pm b/contrib/perl5/lib/Carp/Heavy.pm deleted file mode 100644 index 4d12bd7..0000000 --- a/contrib/perl5/lib/Carp/Heavy.pm +++ /dev/null @@ -1,247 +0,0 @@ -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"; - } - $mess || $error; -} - - -# 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. - my $msg; - $msg = "$error at $file line $line"; - if (defined &Thread::tid) { - my $tid = Thread->self->tid; - $msg .= " thread $tid" if $tid; - } - $msg .= "\n"; - 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; |
