From 7e4f04509c6d4e8d2ed0e31eaf59004e5c930b39 Mon Sep 17 00:00:00 2001
From: Father Chrysostomos <sprout@cpan.org>
Date: Thu, 26 Jan 2012 20:43:17 -0800
Subject: [PATCH] Allow ${^WARNING_BITS} to turn off lexical warnings
MIME-Version: 1.0
Content-Type: text/plain; charset=utf8
Content-Transfer-Encoding: 8bit

Various magical modules copy hints from one scope to another.  But
copying ${^WARNING_BITS} doesn’t always copy the same hints.  If lexi-
cal warnings are not on at all, ${^WARNING_BITS} returns a different
value depending on the current value of $^W.  Setting ${^WARNING_BITS}
to its own value when $^W is true will stop $^W from being able to
control the warnings in the current compilation scope.  Setting
${^WARNING_BITS} to its own value when $^W is false causes even
default warnings to be suppressed.

This commit makes undef a special value that represents the default
state, in which $^W controls warnings.
---
 lib/warnings.pm   |  4 ++--
 mg.c              | 12 ++++--------
 regen/warnings.pl |  4 ++--
 t/comp/hints.t    | 22 ++++++++++++++++++++--
 4 files changed, 28 insertions(+), 14 deletions(-)

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 90a9d0a..2061c34 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -386,7 +386,7 @@ sub import
 {
     shift;
 
-    my $mask = ${^WARNING_BITS} ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -402,7 +402,7 @@ sub unimport
     shift;
 
     my $catmask ;
-    my $mask = ${^WARNING_BITS} ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
diff --git a/mg.c b/mg.c
index b72c74a..14e9705 100644
--- a/mg.c
+++ b/mg.c
@@ -943,11 +943,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 	        sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
 	    }
 	    else if (PL_compiling.cop_warnings == pWARN_STD) {
-		sv_setpvn(
-		    sv, 
-		    (PL_dowarn & G_WARN_ON) ? WARN_ALLstring : WARN_NONEstring,
-		    WARNsize
-		);
+		sv_setsv(sv, &PL_sv_undef);
+		break;
 	    }
             else if (PL_compiling.cop_warnings == pWARN_ALL) {
 		/* Get the bit mask for $warnings::Bits{all}, because
@@ -2665,9 +2662,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
 	}
 	else if (strEQ(mg->mg_ptr+1, "ARNING_BITS")) {
 	    if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
-		if (!SvPOK(sv) && PL_localizing) {
-	            sv_setpvn(sv, WARN_NONEstring, WARNsize);
-	            PL_compiling.cop_warnings = pWARN_NONE;
+		if (!SvPOK(sv)) {
+	            PL_compiling.cop_warnings = pWARN_STD;
 		    break;
 		}
 		{
diff --git a/regen/warnings.pl b/regen/warnings.pl
index 3d65d87..bf0833b 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -635,7 +635,7 @@ sub import
 {
     shift;
 
-    my $mask = ${^WARNING_BITS} ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -651,7 +651,7 @@ sub unimport
     shift;
 
     my $catmask ;
-    my $mask = ${^WARNING_BITS} ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
diff --git a/t/comp/hints.t b/t/comp/hints.t
index 835e1e2..8401ec9 100644
--- a/t/comp/hints.t
+++ b/t/comp/hints.t
@@ -6,7 +6,7 @@ BEGIN {
     @INC = qw(. ../lib);
 }
 
-BEGIN { print "1..28\n"; }
+BEGIN { print "1..29\n"; }
 BEGIN {
     print "not " if exists $^H{foo};
     print "ok 1 - \$^H{foo} doesn't exist initially\n";
@@ -198,6 +198,24 @@ print "ok 26 - no crash when cloning a tied hint hash\n";
     print "# got: $w" if $w;
 }
 
+# Setting ${^WARNING_HINTS} to its own value should not change things.
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w++ };
+    BEGIN {
+	# should have no effect:
+	my $x = ${^WARNING_BITS};
+	${^WARNING_BITS} = $x;
+    }
+    {
+	local $^W = 1;
+	() = 1 + undef;
+    }
+    print "# ", $w//'no', " warnings\nnot " unless $w == 1;
+    print "ok 28 - ",
+          "setting \${^WARNING_BITS} to its own value has no effect\n";
+}
+
 
 # Add new tests above this require, in case it fails.
 require './test.pl';
@@ -208,7 +226,7 @@ my $result = runperl(
     stderr => 1
 );
 print "not " if length $result;
-print "ok 28 - double-freeing hints hash\n";
+print "ok 29 - double-freeing hints hash\n";
 print "# got: $result\n" if length $result;
 
 __END__
-- 
2.7.4