Re: [perl #15395] lexical warnings and inheritance

Message-Id: <200308312208.WAA25312@lublin.zrz.TU-Berlin.DE>

The test has been moved into warnings.pm's test suite. Note
that this patch fixed as well the behaviour of warnings::enabled
regarding lexical scoping and different files; hence the expected
results in a few tests in /t/lib/warnings/9enabled has been
reverted.

p4raw-id: //depot/perl@21167

diff --git a/lib/warnings.pm b/lib/warnings.pm
index edbe1a7..9e9b3b5 100644 (file)
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -439,17 +439,18 @@ sub __chk
        $i -= 2 ;
     }
     else {
-        for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
-            last if $pkg ne $this_pkg ;
-        }
-        $i = 2
-            if !$pkg || $pkg eq $this_pkg ;
+        $i = _error_loc(); # see where Carp will allocate the error
     }
 
     my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
+sub _error_loc {
+    require Carp::Heavy;
+    goto &Carp::short_error_loc; # don't introduce another stack frame
+}                                                             
+
 sub enabled
 {
     Croaker("Usage: warnings::enabled([category])")

diff --git a/t/lib/warnings/9enabled b/t/lib/warnings/9enabled
index 99d32e5..6d15948 100755 (executable)
--- a/t/lib/warnings/9enabled
+++ b/t/lib/warnings/9enabled
@@ -47,7 +47,7 @@ ok2
 --FILE-- abc
 no warnings ;
 print "ok1\n" if !warnings::enabled('all') ;
-print "ok2\n" if warnings::enabled("syntax") ;
+print "ok2\n" if !warnings::enabled("syntax") ;
 1;
 --FILE-- 
 use warnings 'syntax' ;
@@ -61,7 +61,7 @@ ok2
 use warnings 'syntax' ;
 print "ok1\n" if ! warnings::enabled('all') ;
 print "ok2\n" if ! warnings::enabled("syntax") ;
-print "ok3\n" if   warnings::enabled("io") ;
+print "ok3\n" if ! warnings::enabled("io") ;
 1;
 --FILE-- 
 use warnings 'io' ;
@@ -173,7 +173,7 @@ print "ok3\n" if !warnings::enabled("io") ;
 --FILE-- def.pm
 use warnings 'syntax' ;
 print "ok4\n" if !warnings::enabled('all') ;
-print "ok5\n" if warnings::enabled("io") ;
+print "ok5\n" if !warnings::enabled("io") ;
 use abc ;
 1;
 --FILE--
@@ -1179,3 +1179,51 @@ ok5
 my message 1 at - line 8
 my message 2 at - line 8
 my message 4 at - line 8
+########
+
+--FILE--
+# test for bug [perl #15395]
+my ( $warn_cat, # warning category we'll try to control
+     $warn_msg, # the error message to catch
+);
+
+package SomeModule;
+use warnings::register;
+
+BEGIN {
+    $warn_cat = __PACKAGE__;
+    $warn_msg = 'from ' . __PACKAGE__;
+}
+
+# a sub that generates a random warning
+sub gen_warning {
+    warnings::warnif( $warn_msg );
+}
+
+package ClientModule;
+# use SomeModule; (would go here)
+our @CARP_NOT = ( $warn_cat ); # deliver warnings to *our* client
+
+# call_warner provokes a warning.  It is delivered to its caller,
+# who should also be able to control it
+sub call_warner {
+    SomeModule::gen_warning();
+}
+
+# user
+
+package main;
+my $warn_line = __LINE__ + 3; # this line should be in the error message
+eval {
+    use warnings FATAL => $warn_cat; # we want to know if this works
+    ClientModule::call_warner();
+};
+
+# have we caught an error, and is it the one we generated?
+print "ok1\n" if $@ =~ /$warn_msg/;
+
+# does it indicate the right line?
+print "ok2\n" if $@ =~ /line $warn_line/; 
+EXPECT
+ok1
+ok2

diff --git a/warnings.pl b/warnings.pl
index 6177952..7feccb5 100644 (file)
--- a/warnings.pl
+++ b/warnings.pl
@@ -747,17 +747,18 @@ sub __chk
        $i -= 2 ;
     }
     else {
-        for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
-            last if $pkg ne $this_pkg ;
-        }
-        $i = 2
-            if !$pkg || $pkg eq $this_pkg ;
+        $i = _error_loc(); # see where Carp will allocate the error
     }
 
     my $callers_bitmask = (caller($i))[9] ;
     return ($callers_bitmask, $offset, $i) ;
 }
 
+sub _error_loc {
+    require Carp::Heavy;
+    goto &Carp::short_error_loc; # don't introduce another stack frame
+}                                                             
+
 sub enabled
 {
     Croaker("Usage: warnings::enabled([category])")