This is my patch patch.1j for perl5.001.

[p5sagit/p5-mst-13.2.git] / lib / Carp.pm

diff --git a/lib/Carp.pm b/lib/Carp.pm
index 5daba5c..ba21d9c 100644 (file)
--- 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;