Stop lexical warnings from turning off deprecations

Some warnings, such as deprecation warnings, are on by default:

$ perl5.16.0 -e '$*'
$* is no longer supported at -e line 1.

But turning *on* other warnings will turn them off:

$ perl5.16.0 -e 'use warnings "void"; $*'
Useless use of a variable in void context at -e line 1.

Either all warnings in any given scope are controlled by lexical
hints, or none of them are.

When a single warnings category is turned on or off, if the warn-
ings were controlled by $^W, then all warnings are first turned on
lexically if $^W is 1 and all warnings are turned off lexically
if $^W is 0.

That has the unfortunate affect of turning off warnings when it was
only requested that warnings be turned on.

These categories contain default warnings:

ambiguous
debugging
deprecated
inplace
internal
io
malloc
utf8
redefine
syntax
glob
inplace
overflow
precedence
prototype
threads
misc

Most also contain regular warnings, but these contain *only*
default warnings:

debugging
deprecated
glob
inplace
malloc

So we can treat $^W==0 as equivalent to qw(debugging deprecated glob
inplace malloc) when enabling lexical warnings.

While this means that some default warnings will still be turned off
by ‘use warnings "void"’, it won’t be as many as before.  So at least
this is a step in the right direction.

(The real solution, of course, is to allow each warning to be turned
off or on on its own.)

diff --git a/dist/IO/t/IO.t b/dist/IO/t/IO.t
index 382e282..2551b24 100644 (file)
--- a/dist/IO/t/IO.t
+++ b/dist/IO/t/IO.t
@@ -49,6 +49,7 @@ local $SIG{__WARN__} = sub { $warn = "@_" } ;
 
 {
     local $^W = 0;
+    no if $^V >= 5.17.4, warnings => "deprecated";
     IO->import();
     is( $warn, '', "... import default, should not warn");
     $warn = '' ;

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 3b2d87d..934bdd4 100644 (file)
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -336,6 +336,7 @@ our %DeadBits = (
   );
 
 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0\0";
+$DEFAULT  = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00", # [2,4,22,23,25]
 $LAST_BIT = 102 ;
 $BYTES    = 13 ;
 
@@ -387,7 +388,7 @@ sub import
 {
     shift;
 
-    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -403,7 +404,7 @@ sub unimport
     shift;
 
     my $catmask ;
-    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -482,8 +483,11 @@ sub __chk
         $i = _error_loc(); # see where Carp will allocate the error
     }
 
-    # Defaulting this to 0 reduces complexity in code paths below.
-    my $callers_bitmask = (caller($i))[9] || 0 ;
+    # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
+    # explicitly returns undef.
+    my(@callers_bitmask) = (caller($i))[9] ;
+    my $callers_bitmask =
+        @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
 
     my @results;
     foreach my $type (FATAL, NORMAL) {

diff --git a/regen/warnings.pl b/regen/warnings.pl
index d990a6c..70a35d3 100644 (file)
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -53,11 +53,11 @@ my $tree = {
                           }],
                'severe'        => [ 5.008, {   
                                'inplace'       => [ 5.008, DEFAULT_ON],
-                               'internal'      => [ 5.008, DEFAULT_ON],
+                               'internal'      => [ 5.008, DEFAULT_OFF],
                                'debugging'     => [ 5.008, DEFAULT_ON],
                                'malloc'        => [ 5.008, DEFAULT_ON],
                           }],
-        'deprecated'   => [ 5.008, DEFAULT_OFF],
+        'deprecated'   => [ 5.008, DEFAULT_ON],
                'void'          => [ 5.008, DEFAULT_OFF],
                'recursion'     => [ 5.008, DEFAULT_OFF],
                'redefine'      => [ 5.008, DEFAULT_OFF],
@@ -66,7 +66,7 @@ my $tree = {
                'once'          => [ 5.008, DEFAULT_OFF],
                'misc'          => [ 5.008, DEFAULT_OFF],
                'regexp'        => [ 5.008, DEFAULT_OFF],
-               'glob'          => [ 5.008, DEFAULT_OFF],
+               'glob'          => [ 5.008, DEFAULT_ON],
                'untie'         => [ 5.008, DEFAULT_OFF],
        'substr'        => [ 5.008, DEFAULT_OFF],
        'taint'         => [ 5.008, DEFAULT_OFF],
@@ -89,6 +89,7 @@ my $tree = {
        }],
 } ;
 
+my @def ;
 my %list ;
 my %Value ;
 my %ValueToName ;
@@ -151,6 +152,8 @@ sub walk
        my ($ver, $rest) = @{ $v } ;
        if (ref $rest)
          { push (@{ $list{$k} }, walk ($rest)) }
+       elsif ($rest == DEFAULT_ON)
+         { push @def, $NameToValue{uc $k} }
 
        push @list, @{ $list{$k} } ;
     }
@@ -416,6 +419,8 @@ foreach $k (sort keys  %list) {
 
 print $pm "  );\n\n" ;
 print $pm '$NONE     = "', ('\0' x $warn_size) , "\";\n" ;
+print $pm '$DEFAULT  = "', mkHex($warn_size, map $_ * 2, @def),
+                          '", # [', mkRange(@def), "]\n" ;
 print $pm '$LAST_BIT = ' . "$index ;\n" ;
 print $pm '$BYTES    = ' . "$warn_size ;\n" ;
 while (<DATA>) {
@@ -636,7 +641,7 @@ sub import
 {
     shift;
 
-    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -652,7 +657,7 @@ sub unimport
     shift;
 
     my $catmask ;
-    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -731,8 +736,11 @@ sub __chk
         $i = _error_loc(); # see where Carp will allocate the error
     }
 
-    # Defaulting this to 0 reduces complexity in code paths below.
-    my $callers_bitmask = (caller($i))[9] || 0 ;
+    # Default to 0 if caller returns nothing.  Default to $DEFAULT if it
+    # explicitly returns undef.
+    my(@callers_bitmask) = (caller($i))[9] ;
+    my $callers_bitmask =
+        @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
 
     my @results;
     foreach my $type (FATAL, NORMAL) {

diff --git a/t/lib/warnings/2use b/t/lib/warnings/2use
index e5a8103..c0d203a 100644 (file)
--- a/t/lib/warnings/2use
+++ b/t/lib/warnings/2use
@@ -358,3 +358,22 @@ $a =+ 1 ;
 EXPECT
 Reversed += operator at - line 6.
 Use of uninitialized value $c in scalar chop at - line 9.
+########
+
+# Check that deprecation warnings are not implicitly disabled by use
+$*;
+use warnings "void";
+$#;
+EXPECT
+$* is no longer supported at - line 3.
+$# is no longer supported at - line 5.
+Useless use of a variable in void context at - line 5.
+########
+
+# Check that deprecation warnings are not implicitly disabled by no
+$*;
+no warnings "void";
+$#;
+EXPECT
+$* is no longer supported at - line 3.
+$# is no longer supported at - line 5.

diff --git a/t/lib/warnings/regcomp b/t/lib/warnings/regcomp
index a329639..15a658f 100644 (file)
--- a/t/lib/warnings/regcomp
+++ b/t/lib/warnings/regcomp
@@ -54,7 +54,7 @@ Unrecognized escape \m passed through in regex; marked by <-- HERE in m/a\m <--
 ########
 # regcomp.c [S_regatom]
 # The \q should warn, the \_ should NOT warn.
-use warnings 'regexp';
+use warnings 'regexp'; no warnings "deprecated";
 "foo" =~ /\q/;
 "foo" =~ /\q{/;
 "foo" =~ /\w{/;

diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke
index e436cec..8a8fb05 100644 (file)
--- a/t/lib/warnings/toke
+++ b/t/lib/warnings/toke
@@ -1085,7 +1085,7 @@ Number found where operator expected at (eval 1) line 1, near "5 6"
        (Missing operator before  6?)
 ########
 # toke.c
-use warnings "syntax";
+use warnings "syntax"; no warnings "deprecated";
 $_ = $a = 1;
 $a !=~  /1/;
 $a !=~ m#1#;

diff --git a/t/op/universal.t b/t/op/universal.t
index bbee79e..9db10c8 100644 (file)
--- a/t/op/universal.t
+++ b/t/op/universal.t
@@ -175,6 +175,7 @@ ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH');
 
 {
     package Pickup;
+    no warnings "deprecated";
     use UNIVERSAL qw( isa can VERSION );
 
     ::ok isa "Pickup", UNIVERSAL;

diff --git a/t/uni/universal.t b/t/uni/universal.t
index 8f158e9..626c30f 100644 (file)
--- a/t/uni/universal.t
+++ b/t/uni/universal.t
@@ -119,6 +119,7 @@ ok $a->can("slèèp");
 
 {
     package Pìckùp;
+    no warnings "deprecated";
     use UNIVERSAL qw( isa can VERSION );
 
     ::ok isa "Pìckùp", UNIVERSAL;