X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCarp.pm;h=de586489bad0305a6cbf448e71b824392b402287;hb=9d17b0a6244cecb9ba7d42c6a1a882fd933f6f45;hp=2d857ba4e769453afc85334b2231802c5a78e491;hpb=c1bce5d7c4f10bb970b094ec986540c244295278;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Carp.pm b/lib/Carp.pm
index 2d857ba..de58648 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -28,6 +28,9 @@ not where carp() was called.
 # exceptions outside of the current package.
 
 $CarpLevel = 0;		# How many extra package levels to skip on carp.
+$MaxEvalLen = 0;	# How much eval '...text...' to show. 0 = all.
+$MaxArgLen = 64;        # How much of each argument to print. 0 = all.
+$MaxArgNums = 8;        # How many arguments to print. 0 = all.
 
 require Exporter;
 @ISA = Exporter;
@@ -37,11 +40,42 @@ sub longmess {
     my $error = shift;
     my $mess = "";
     my $i = 1 + $CarpLevel;
-    my ($pack,$file,$line,$sub);
-    while (($pack,$file,$line,$sub) = caller($i++)) {
+    my ($pack,$file,$line,$sub,$hargs,$eval,$require);
+    my (@a);
+    while (do { { package DB; @a = caller($i++) } } ) {
+      ($pack,$file,$line,$sub,$hargs,undef,$eval,$require) = @a;
 	if ($error =~ m/\n$/) {
 	    $mess .= $error;
 	} else {
+	    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 ($hargs) {
+	      @a = @DB::args;	# must get local copy of args
+	      if ($MaxArgNums and @a > $MaxArgNums) {
+		$#a = $MaxArgNums;
+		$a[$#a] = "...";
+	      }
+	      for (@a) {
+		$_ = "undef", next unless defined $_;
+		s/'/\\'/g;
+		substr($_,$MaxArgLen) = '...' if $MaxArgLen and $MaxArgLen < length;
+		s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/;
+		s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+		s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+	      }
+	      $sub .= '(' . join(', ', @a) . ')';
+	    }
 	    $mess .= "\t$sub " if $error eq "called";
 	    $mess .= "$error at $file line $line\n";
 	}
@@ -52,20 +86,40 @@ sub longmess {
 
 sub shortmess {	# Short-circuit &longmess if called via multiple packages
     my $error = $_[0];	# Instead of "shift"
-    my ($curpack) = caller(1);
+    my ($prevpack) = caller(1);
     my $extra = $CarpLevel;
     my $i = 2;
-    my ($pack,$file,$line,$sub);
-    while (($pack,$file,$line,$sub) = caller($i++)) {
-	if ($pack ne $curpack) {
-	    if ($extra-- > 0) {
-		$curpack = $pack;
-	    }
-	    else {
-		return "$error at $file line $line\n";
-	    }
+    my ($pack,$file,$line);
+    my %isa = ($prevpack,1);
+
+    @isa{@{"${prevpack}::ISA"}} = ()
+	if(defined @{"${prevpack}::ISA"});
+
+    while (($pack,$file,$line) = caller($i++)) {
+	if(defined @{$pack . "::ISA"}) {
+	    my @i = @{$pack . "::ISA"};
+	    my %i;
+	    @i{@i} = ();
+	    @isa{@i,$pack} = ()
+		if(exists $i{$prevpack} || exists $isa{$pack});
+	}
+
+	next
+	    if(exists $isa{$pack});
+
+	if ($extra-- > 0) {
+	    %isa = ($pack,1);
+	    @isa{@{$pack . "::ISA"}} = ()
+		if(defined @{$pack . "::ISA"});
+	}
+	else {
+	    return "$error at $file line $line\n";
 	}
     }
+    continue {
+	$prevpack = $pack;
+    }
+
     goto &longmess;
 }