From: Ben Tilly Date: Tue, 5 Dec 2000 01:35:54 +0000 (-0500) Subject: Need help with warnings :-( X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=66a4a569cc2ea11fe85bfadbec79dcd4fbf36d17;p=p5sagit%2Fp5-mst-13.2.git Need help with warnings :-( Date: Tue, 05 Dec 2000 01:35:54 -0500 Message-ID: Subject: UPDATE: Carp/Heavy now passes all tests From: "Ben Tilly" Date: Tue, 05 Dec 2000 07:59:41 -0500 Message-ID: The Brave New Carp. p4raw-id: //depot/perl@7993 --- diff --git a/lib/Carp.pm b/lib/Carp.pm index 43524dd..f7e9bf1 100644 --- a/lib/Carp.pm +++ b/lib/Carp.pm @@ -68,6 +68,8 @@ $MaxArgLen = 64; # How much of each argument to print. 0 = all. $MaxArgNums = 8; # How many arguments to print. 0 = all. $Verbose = 0; # If true then make shortmess call longmess instead +$CarpInternal{Carp}++; + require Exporter; @ISA = ('Exporter'); @EXPORT = qw(confess croak carp); diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm index 4d12bd7..d7b8990 100644 --- a/lib/Carp/Heavy.pm +++ b/lib/Carp/Heavy.pm @@ -1,247 +1,231 @@ package Carp; -=head1 NAME -Carp::Heavy - Carp guts +sub caller_info { + my $i = shift(@_) + 1; + package DB; + my %call_info; + @call_info{ + qw(pack file line sub has_args wantarray evaltext is_require) + } = caller($i); + + unless (defined $call_info{pack}) { + return (); + } + + my $sub_name = Carp::get_subname(\%call_info); + if ($call_info{has_args}) { + # Reuse the @args array to avoid warnings. :-) + local @args = map {Carp::format_arg($_)} @args; + if ($MaxArgNums and @args > $MaxArgNums) { # More than we want to show? + $#args = $MaxArgNums; + push @args, '...'; + } + # Push the args onto the subroutine + $sub_name .= '(' . join (',', @args) . ')'; + } + $call_info{sub_name} = $sub_name; + return wantarray() ? %call_info : \%call_info; +} -=head1 SYNOPIS +# Transform an argument to a function into a string. +sub format_arg { + my $arg = shift; + if (not defined($arg)) { + $arg = 'undef'; + } + elsif (ref($arg)) { + $arg .= ''; # Make it a string; + } + $arg =~ s/'/\\'/g; + $arg = str_len_trim($arg, $MaxLenArg); + + # Quote it? + $arg = "'$arg'" unless $arg =~ /^-?[\d.]+\z/; + + # The following handling of "control chars" is direct from + # the original code - I think it is broken on Unicode though. + # Suggestions? + $arg =~ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; + $arg =~ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; + return $arg; +} -(internal use only) +# Takes an inheritance cache and a package and returns +# an anon hash of known inheritances and anon array of +# inheritances which consequences have not been figured +# for. +sub get_status { + my $cache = shift; + my $pkg = shift; + $cache->{$pkg} ||= [{$pkg => $pkg}, [trusts_directly($pkg)]]; + return @{$cache->{$pkg}}; +} -=head1 DESCRIPTION +# Takes the info from caller() and figures out the name of +# the sub/require/eval +sub get_subname { + my $info = shift; + if (defined($info->{eval})) { + my $eval = $info->{eval}; + if ($info->{is_require}) { + return "require $eval"; + } + else { + $eval =~ s/([\\\'])/\\$1/g; + return str_len_trim($eval, $MaxEvalLen); + } + } + + return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub}; +} + +# Figures out what call (from the point of view of the caller) +# the long error backtrace should start at. +sub long_error_loc { + my $i; + my $lvl = $CarpLevel; + { + my $pkg = caller(++$i); + unless(defined($pkg)) { + # This *shouldn't* happen. + if (%Internal) { + local %Internal; + $i = long_error_loc(); + last; + } + else { + # OK, now I am irritated. + return 2; + } + } + redo if $CarpInternal{$pkg}; + redo unless 0 > --$lvl; + redo if $Internal{$pkg}; + } + return $i - 1; +} -No user-serviceable parts inside. -=cut +sub longmess_heavy { + return @_ if ref($_[0]); # WHAT IS THIS FOR??? + my $i = long_error_loc(); + return ret_backtrace($i, @_); +} -# This package is heavily used. Be small. Be fast. Be good. +# Returns a full stack backtrace starting from where it is +# told. +sub ret_backtrace { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; + + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } + + if ($err =~ /\n$/) { + $mess = $err; + } + else { + my %i = caller_info($i); + $mess = "$err at $i{file} line $i{line}$tid_msg\n"; + } + + while (my %i = caller_info(++$i)) { + $mess .= "\t$i{sub_name} called at $i{file} line $i{line}$tid_msg\n"; + + return $mess || $err; +} -# Comments added by Andy Wardley 09-Apr-98, based on an -# _almost_ complete understanding of the package. Corrections and -# comments are welcome. +sub ret_summary { + my ($i, @error) = @_; + my $mess; + my $err = join '', @error; + $i++; -# 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. + my $tid_msg = ''; + if (defined &Thread::tid) { + my $tid = Thread->self->tid; + $tid_msg = " thread $tid" if $tid; + } -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-' - s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; - # print remaining control chars as ^ - 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; + my %i = caller_info($i); + return "$err at $i{file} line $i{line}$tid_msg\n"; } -# 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 (); - } +sub short_error_loc { + my $cache; + my $i = 1; + my $lvl = $CarpLevel; + { + my $called = caller($i++); + my $caller = caller($i); + return 0 unless defined($caller); # What happened? + redo if $Internal{$caller}; + redo if $CarpInternal{$called}; + redo if trusts($called, $caller, $cache); + redo if trusts($caller, $called, $cache); + redo unless 0 > --$lvl; + } + return $i - 1; } +sub shortmess_heavy { + return longmess_heavy(@_) if $Verbose; + return @_ if ref($_[0]); # WHAT IS THIS FOR??? + my $i = short_error_loc(); + if ($i) { + ret_summary($i, @_); + } + else { + longmess_heavy(@_); + } +} + +# If a string is too long, trims it with ... +sub str_len_trim { + my $str = shift; + my $max = shift || 0; + if (2 < $max and $max < length($str)) { + substr($str, $max - 3) = '...'; + } + return $str; +} -# 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; - } +# Takes two packages and an optional cache. Says whether the +# first inherits from the second. +# +# Recursive versions of this have to work to avoid certain +# possible endless loops, and when following long chains of +# inheritance are less efficient. +sub trusts { + my $child = shift; + my $parent = shift; + my $cache = shift || {}; + my ($known, $partial) = get_status($cache, $child); + # Figure out consequences until we have an answer + while (@$partial and not exists $known->{$parent}) { + my $anc = shift @$partial; + next if exists $known->{$anc}; + $known->{$anc}++; + my ($anc_knows, $anc_partial) = get_status($cache, $anc); + my @found = keys %$anc_knows; + @$known{@found} = (); + push @$partial, @$anc_partial; } + return exists $known->{$parent}; +} - # 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; +# Takes a package and gives a list of those trusted directly +sub trusts_directly { + my $class = shift; + return @{"$class\::ISA"}; } 1; +