X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCarp.pm;h=ba21d9c6252b0e45888179e32054bf07c5eadd45;hb=c296029969658ed2c8d9a223d4b09026463ca970;hp=5daba5c289b6c537763da10d12e66fe2fe3968d2;hpb=a0d0e21ea6ea90a22318550944fe6cb09ae10cda;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/Carp.pm b/lib/Carp.pm
index 5daba5c..ba21d9c 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -1,8 +1,34 @@
 package Carp;
 
+=head1 NAME
+
+carp - warn of errors (from perspective of caller)
+
+croak - die of errors (from perspective of caller)
+
+confess - die of errors with stack backtrace
+
+=head1 SYNOPSIS
+
+    use Carp;
+    croak "We're outta here!";
+
+=head1 DESCRIPTION
+
+The Carp routines are useful in your own modules because
+they act like die() or warn(), but report where the error
+was in the code they were called from.  Thus if you have a 
+routine Foo() that has a carp() in it, then the carp() 
+will report the error as occurring where Foo() was called, 
+not where carp() was called.
+
+=cut
+
 # This package implements handy routines for modules that wish to throw
 # exceptions outside of the current package.
 
+$CarpLevel = 0;		# How many extra package levels to skip on carp.
+
 require Exporter;
 @ISA = Exporter;
 @EXPORT = qw(confess croak carp);
@@ -10,7 +36,7 @@ require Exporter;
 sub longmess {
     my $error = shift;
     my $mess = "";
-    my $i = 2;
+    my $i = 1 + $CarpLevel;
     my ($pack,$file,$line,$sub);
     while (($pack,$file,$line,$sub) = caller($i++)) {
 	$mess .= "\t$sub " if $error eq "called";
@@ -20,18 +46,27 @@ sub longmess {
     $mess || $error;
 }
 
-sub shortmess {
-    my $error = shift;
+sub shortmess {	# Short-circuit &longmess if called via multiple packages
+    my $error = $_[0];	# Instead of "shift"
     my ($curpack) = caller(1);
+    my $extra = $CarpLevel;
     my $i = 2;
     my ($pack,$file,$line,$sub);
     while (($pack,$file,$line,$sub) = caller($i++)) {
-	return "$error at $file line $line\n" if $pack ne $curpack;
+	if ($pack ne $curpack) {
+	    if ($extra-- > 0) {
+		$curpack = $pack;
+	    }
+	    else {
+		return "$error at $file line $line\n";
+	    }
+	}
     }
-    longmess $error;
+    goto &longmess;
 }
 
 sub confess { die longmess @_; }
 sub croak { die shortmess @_; }
 sub carp { warn shortmess @_; }
 
+1;