fix warning + carp interaction

From: "Paul Marquess" <paul_marquess@yahoo.co.uk>       
Message-ID: <AIEAJICLCBDNAAOLLOKLGEKCEAAA.paul_marquess@yahoo.co.uk>

p4raw-id: //depot/perl@15481

4 files changed, 72 insertions, 45 deletions

diff --git a/lib/Carp.pm b/lib/Carp.pm
index 5dbae299fd..6199f89448 100644
--- a/lib/Carp.pm
+++ b/lib/Carp.pm
@@ -119,6 +119,7 @@ call die() or warn(), as appropriate.
 # text and function arguments should be formatted when printed.
 
 $CarpInternal{Carp}++;
+$CarpInternal{warnings}++;
 $CarpLevel = 0;		# How many extra package levels to skip on carp.
                         # How many calls to skip on confess.
                         # Reconciling these notions is hard, use
diff --git a/lib/warnings.pm b/lib/warnings.pm
index 0b32815e25..8c4791370e 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -278,6 +278,12 @@ $BYTES    = 12 ;
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 
+sub Croaker
+{
+    delete $Carp::CarpInternal{'warnings'};
+    croak @_ ;
+}
+
 sub bits {
     my $mask ;
     my $catmask ;
@@ -291,7 +297,7 @@ sub bits {
 	    $mask |= $DeadBits{$word} if $fatal ;
 	}
 	else
-          { croak("Unknown warnings category '$word'")}
+          { Croaker("Unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -327,19 +333,19 @@ sub __chk
         # check the category supplied.
         $category = shift ;
         if (ref $category) {
-            croak ("not an object")
+            Croaker ("not an object")
                 if $category !~ /^([^=]+)=/ ;
 	    $category = $1 ;
             $isobj = 1 ;
         }
         $offset = $Offsets{$category};
-        croak("Unknown warnings category '$category'")
+        Croaker("Unknown warnings category '$category'")
 	    unless defined $offset;
     }
     else {
         $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
-        croak("package '$category' not registered for warnings")
+        Croaker("package '$category' not registered for warnings")
 	    unless defined $offset ;
     }
 
@@ -367,7 +373,7 @@ sub __chk
 
 sub enabled
 {
-    croak("Usage: warnings::enabled([category])")
+    Croaker("Usage: warnings::enabled([category])")
 	unless @_ == 1 || @_ == 0 ;
 
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
@@ -380,12 +386,11 @@ sub enabled
 
 sub warn
 {
-    croak("Usage: warnings::warn([category,] 'message')")
+    Croaker("Usage: warnings::warn([category,] 'message')")
 	unless @_ == 2 || @_ == 1 ;
 
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
-    local $Carp::CarpLevel = $i ;
     croak($message)
 	if vec($callers_bitmask, $offset+1, 1) ||
 	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
@@ -394,12 +399,11 @@ sub warn
 
 sub warnif
 {
-    croak("Usage: warnings::warnif([category,] 'message')")
+    Croaker("Usage: warnings::warnif([category,] 'message')")
 	unless @_ == 2 || @_ == 1 ;
 
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
-    local $Carp::CarpLevel = $i ;
 
     return
         unless defined $callers_bitmask &&
diff --git a/t/lib/warnings/9enabled b/t/lib/warnings/9enabled
index fdce8cd84f..99d32e54e8 100755
--- a/t/lib/warnings/9enabled
+++ b/t/lib/warnings/9enabled
@@ -198,7 +198,9 @@ sub check {
 --FILE-- 
 use warnings 'syntax' ;
 use abc ;
-eval { abc::check() ; };
+eval { 
+  abc::check() ; 
+};
 print $@ ;
 EXPECT
 ok1
@@ -217,7 +219,9 @@ sub check {
 --FILE-- 
 use warnings 'syntax' ;
 use abc ;
-eval { abc::check() ; } ;
+eval { 
+  abc::check() ; 
+  } ;
 print $@ ;
 EXPECT
 ok1
@@ -236,7 +240,9 @@ sub check {
 --FILE-- 
 use warnings 'syntax' ;
 require "abc" ;
-eval { abc::check() ; } ;
+eval { 
+  abc::check() ; 
+  } ;
 print $@ ;
 EXPECT
 ok1
@@ -255,7 +261,10 @@ sub check {
 --FILE-- 
 use warnings 'syntax' ;
 require "abc" ;
-eval { use warnings 'io' ; abc::check() ; };
+eval { 
+  use warnings 'io' ; 
+  abc::check() ; 
+};
 abc::check() ; 
 print $@ ;
 EXPECT
@@ -326,24 +335,32 @@ ok4
 
 # check warnings::warn
 use warnings ;
-eval { warnings::warn() } ;
+eval { 
+    warnings::warn() 
+  } ;
 print $@ ;
-eval { warnings::warn("fred", "joe") } ;
+eval { 
+  warnings::warn("fred", "joe") 
+  } ;
 print $@ ;
 EXPECT
-Usage: warnings::warn([category,] 'message') at - line 4
-Unknown warnings category 'fred' at - line 6
+Usage: warnings::warn([category,] 'message') at - line 5
+Unknown warnings category 'fred' at - line 9
 ########
 
 # check warnings::warnif
 use warnings ;
-eval { warnings::warnif() } ;
+eval { 
+  warnings::warnif() 
+} ;
 print $@ ;
-eval { warnings::warnif("fred", "joe") } ;
+eval { 
+  warnings::warnif("fred", "joe") 
+} ;
 print $@ ;
 EXPECT
-Usage: warnings::warnif([category,] 'message') at - line 4
-Unknown warnings category 'fred' at - line 6
+Usage: warnings::warnif([category,] 'message') at - line 5
+Unknown warnings category 'fred' at - line 9
 ########
 
 --FILE-- abc.pm
@@ -380,11 +397,12 @@ sub check { warnings::warn("io", "hello") }
 --FILE--
 use warnings qw( FATAL deprecated ) ;
 use abc;
-eval { abc::check() ; } ;
+eval { 
+    abc::check() ; 
+  } ;
 print "[[$@]]\n";
 EXPECT
-hello at - line 3
-	eval {...} called at - line 3
+hello at - line 4
 [[]]
 ########
 
@@ -396,11 +414,12 @@ sub check { warnings::warn("io", "hello") }
 --FILE--
 use warnings qw( FATAL io ) ;
 use abc;
-eval { abc::check() ; } ;
+eval { 
+  abc::check() ; 
+} ;
 print "[[$@]]\n";
 EXPECT
-[[hello at - line 3
-	eval {...} called at - line 3
+[[hello at - line 4
 ]]
 ########
 -W
@@ -656,11 +675,12 @@ sub check { warnings::warn("hello") }
 --FILE--
 use abc;
 use warnings qw( FATAL deprecated ) ;
-eval { abc::check() ; } ;
+eval {
+    abc::check() ; 
+  } ;
 print "[[$@]]\n";
 EXPECT
-hello at - line 3
-	eval {...} called at - line 3
+hello at - line 4
 [[]]
 ########
 
@@ -672,11 +692,12 @@ sub check { warnings::warn("hello") }
 --FILE--
 use abc;
 use warnings qw( FATAL abc ) ;
-eval { abc::check() ; } ;
+eval { 
+  abc::check() ; 
+  } ;
 print "[[$@]]\n";
 EXPECT
-[[hello at - line 3
-	eval {...} called at - line 3
+[[hello at - line 4
 ]]
 ########
 -W
@@ -1024,11 +1045,8 @@ ok2
 ok3
 ok4
 my message 1 at abc.pm line 5
-	abc::in1() called at - line 3
 my message 2 at abc.pm line 5
-	abc::in1() called at - line 3
 my message 3 at abc.pm line 5
-	abc::in1() called at - line 3
 ########
 
 --FILE-- def.pm
diff --git a/warnings.pl b/warnings.pl
index 9a13cf01c4..9149f69194 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -522,6 +522,12 @@ KEYWORDS
 
 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
 
+sub Croaker
+{
+    delete $Carp::CarpInternal{'warnings'};
+    croak @_ ;
+}
+
 sub bits {
     my $mask ;
     my $catmask ;
@@ -535,7 +541,7 @@ sub bits {
 	    $mask |= $DeadBits{$word} if $fatal ;
 	}
 	else
-          { croak("Unknown warnings category '$word'")}
+          { Croaker("Unknown warnings category '$word'")}
     }
 
     return $mask ;
@@ -571,19 +577,19 @@ sub __chk
         # check the category supplied.
         $category = shift ;
         if (ref $category) {
-            croak ("not an object")
+            Croaker ("not an object")
                 if $category !~ /^([^=]+)=/ ;
 	    $category = $1 ;
             $isobj = 1 ;
         }
         $offset = $Offsets{$category};
-        croak("Unknown warnings category '$category'")
+        Croaker("Unknown warnings category '$category'")
 	    unless defined $offset;
     }
     else {
         $category = (caller(1))[0] ;
         $offset = $Offsets{$category};
-        croak("package '$category' not registered for warnings")
+        Croaker("package '$category' not registered for warnings")
 	    unless defined $offset ;
     }
 
@@ -611,7 +617,7 @@ sub __chk
 
 sub enabled
 {
-    croak("Usage: warnings::enabled([category])")
+    Croaker("Usage: warnings::enabled([category])")
 	unless @_ == 1 || @_ == 0 ;
 
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
@@ -624,12 +630,11 @@ sub enabled
 
 sub warn
 {
-    croak("Usage: warnings::warn([category,] 'message')")
+    Croaker("Usage: warnings::warn([category,] 'message')")
 	unless @_ == 2 || @_ == 1 ;
 
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
-    local $Carp::CarpLevel = $i ;
     croak($message)
 	if vec($callers_bitmask, $offset+1, 1) ||
 	   vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
@@ -638,12 +643,11 @@ sub warn
 
 sub warnif
 {
-    croak("Usage: warnings::warnif([category,] 'message')")
+    Croaker("Usage: warnings::warnif([category,] 'message')")
 	unless @_ == 2 || @_ == 1 ;
 
     my $message = pop ;
     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
-    local $Carp::CarpLevel = $i ;
 
     return
         unless defined $callers_bitmask &&