X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCarp%2FHeavy.pm;h=c3d3c26fa1ae61ab10d6ee898410549278eabe42;hb=98e3f270ffa30af1413b4c0412a1027dbc9b03ed;hp=8cfdcb48f0748f18d2dfaa85b8ef12bdbcf7a73d;hpb=ee8c7f5465f003860e2347a2946abacac39bd9b9;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Carp/Heavy.pm b/lib/Carp/Heavy.pm
index 8cfdcb4..c3d3c26 100644
--- a/lib/Carp/Heavy.pm
+++ b/lib/Carp/Heavy.pm
@@ -1,247 +1,247 @@
+# Carp::Heavy uses some variables in common with Carp.
 package Carp;
 
 =head1 NAME
 
-Carp::Heavy - Carp guts
+Carp heavy machinery - no user serviceable parts inside
 
-=head1 SYNOPIS
+=cut
 
-(internal use only)
+# use strict; # not yet
+
+# On one line so MakeMaker will see it.
+use Carp;  our $VERSION = $Carp::VERSION;
+
+our ($CarpLevel, $MaxArgNums, $MaxEvalLen, $MaxArgLen, $Verbose);
+
+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}) {
+    my @args = map {Carp::format_arg($_)} @DB::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 DESCRIPTION
+# 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 = defined($overload::VERSION) ? overload::StrVal($arg) : "$arg";
+  }
+  $arg =~ s/'/\\'/g;
+  $arg = str_len_trim($arg, $MaxArgLen);
+  
+  # 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/([[:cntrl:]]|[[:^ascii:]])/sprintf("\\x{%x}",ord($1))/eg;
+  return $arg;
+}
 
-No user-serviceable parts inside.
+# 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}};
+}
 
-=cut
+# Takes the info from caller() and figures out the name of
+# the sub/require/eval
+sub get_subname {
+  my $info = shift;
+  if (defined($info->{evaltext})) {
+    my $eval = $info->{evaltext};
+    if ($info->{is_require}) {
+      return "require $eval";
+    }
+    else {
+      $eval =~ s/([\\\'])/\\$1/g;
+      return "eval '" . str_len_trim($eval, $MaxEvalLen) . "'";
+    }
+  }
 
-# This package is heavily used. Be small. Be fast. Be good.
+  return ($info->{sub} eq '(eval)') ? 'eval {...}' : $info->{sub};
+}
 
-# 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.
+# 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;
+}
 
-# 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;
+  return @_ if ref($_[0]); # don't break references as exceptions
+  my $i = long_error_loc();
+  return ret_backtrace($i, @_);
 }
 
+# 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$/) {	# extra block to localise $1 etc
+    $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;
+}
 
-# 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 ret_summary {
+  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;
+  }
+
+  my %i = caller_info($i);
+  return "$err at $i{file} line $i{line}$tid_msg\n";
+}
+
+
+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]); # don't break references as exceptions
+  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;
-		$mess .= " 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;
+    no strict 'refs';
+    no warnings 'once'; 
+    return @{"$class\::CARP_NOT"}
+      ? @{"$class\::CARP_NOT"}
+      : @{"$class\::ISA"};
 }
 
 1;
+