fix handling of registered warning categories

There were some problems arising from some warning bitsets being shorter
than others, which happens when registration of a new warning category
makes new bitsets longer.  Most obviously, if a scope used "use warnings
'all'" to turn on all warnings and then turned off some specific warnings,
then that scope wouldn't get warnings for subsequently-registered warning
categories, because its bitset doesn't extend to the bit controlling
the new category.  (If just "use warnings 'all'" was used, without any
customisation, then a special hack made that work for new categories.)
It was also possible for a longer bitset to get truncated by a warnings
pragma, because the bitset editing code assumed that all bitsets are
the same length.

To fix this, first the warning bits for the "all" category have to change
meaning.  Unlike all other warning categories, the bits for "all" used to
be set only when there were no warning categories disabled; disabling any
would also clear the "all" bits.  That was supporting the special hack
mentioned above that the all-warnings bitset work for new categories.
This exception is now removed, so the meaning of the "all" bits is now the
more obvious meaning, of indicating the default treatment that the scope
wants for warnings not falling into any category known to the bitset.
In warnings::warnif() et al, if the caller's bitset is found to be too
short to have a bit for the relevant category, then the setting for the
"all" category is used instead.

Because the length of a bitset is an integral number of bytes, but
only two bits are used per category, the length of a bitset doesn't
precisely indicate which categories had been registered by the time it
was constructed.  So the standard bitsets for the "all" category are
now always filled to their byte length, with bits set preemptively for
categories not yet registered that fall within the current bitset length.

When a warnings pragma operates on a bitset, it first expands it to the
preferred length, by duplicating the "all" bits for the categories covered
by the new length.  It is careful to maintain the length when combining
the bitset with the standard bitsets for categories.  When a bitset is
read from ${^WARNING_BITS} or from caller(), the standard pWARN_ALL
setting is no longer expanded by the core to $warnings::Bits{all},
because the core's short WARN_ALLstring will now be expanded correctly
just like any other bitset.

Fixes [perl #108778].

1 files changed, 40 insertions, 31 deletions

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 2ae1bb4e06..64e6448a08 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -5,7 +5,7 @@
 
 package warnings;
 
-our $VERSION = "1.37";
+our $VERSION = "1.38";
 
 # Verify that we're called correctly so that warnings will work.
 # Can't use Carp, since Carp uses us!
@@ -99,7 +99,7 @@ our %Offsets = (
 );
 
 our %Bits = (
-    'all'				=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..66]
+    'all'				=> "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..67]
     'ambiguous'				=> "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
     'bareword'				=> "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
     'closed'				=> "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -169,7 +169,7 @@ our %Bits = (
 );
 
 our %DeadBits = (
-    'all'				=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..66]
+    'all'				=> "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..67]
     'ambiguous'				=> "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [29]
     'bareword'				=> "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [30]
     'closed'				=> "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -244,8 +244,6 @@ our $DEFAULT				=  "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x55\x51
 our $LAST_BIT				=  134 ;
 our $BYTES				=  17 ;
 
-our $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
-
 sub Croaker
 {
     require Carp; # this initializes %CarpInternal
@@ -254,12 +252,32 @@ sub Croaker
     Carp::croak(@_);
 }
 
+sub _expand_bits {
+    my $bits = shift;
+    my $want_len = ($LAST_BIT + 7) >> 3;
+    my $len = length($bits);
+    if ($len != $want_len) {
+	if ($bits eq "") {
+	    $bits = "\x00" x $want_len;
+	} elsif ($len > $want_len) {
+	    substr $bits, $want_len, $len-$want_len, "";
+	} else {
+	    my $a = vec($bits, $Offsets{all} >> 1, 2);
+	    $a |= $a << 2;
+	    $a |= $a << 4;
+	    $bits .= chr($a) x ($want_len - $len);
+	}
+    }
+    return $bits;
+}
+
 sub _bits {
     my $mask = shift ;
     my $catmask ;
     my $fatal = 0 ;
     my $no_fatal = 0 ;
 
+    $mask = _expand_bits($mask);
     foreach my $word ( @_ ) {
 	if ($word eq 'FATAL') {
 	    $fatal = 1;
@@ -272,7 +290,7 @@ sub _bits {
 	elsif ($catmask = $Bits{$word}) {
 	    $mask |= $catmask ;
 	    $mask |= $DeadBits{$word} if $fatal ;
-	    $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
+	    $mask = ~(~$mask | $DeadBits{$word}) if $no_fatal ;
 	}
 	else
 	  { Croaker("Unknown warnings category '$word'")}
@@ -285,7 +303,7 @@ sub bits
 {
     # called from B::Deparse.pm
     push @_, 'all' unless @_ ;
-    return _bits(undef, @_) ;
+    return _bits("", @_) ;
 }
 
 sub import
@@ -294,16 +312,12 @@ sub import
 
     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
-    if (vec($mask, $Offsets{'all'}, 1)) {
-	$mask |= $Bits{'all'} ;
-	$mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
-    }
-
-    # append 'all' when implied (after a lone "FATAL" or "NONFATAL")
-    push @_, 'all' if @_==1 && ( $_[0] eq 'FATAL' || $_[0] eq 'NONFATAL' );
+    # append 'all' when implied (empty import list or after a lone
+    # "FATAL" or "NONFATAL")
+    push @_, 'all'
+	if !@_ || (@_==1 && ($_[0] eq 'FATAL' || $_[0] eq 'NONFATAL'));
 
-    # Empty @_ is equivalent to @_ = 'all' ;
-    ${^WARNING_BITS} = @_ ? _bits($mask, @_) : $mask | $Bits{all} ;
+    ${^WARNING_BITS} = _bits($mask, @_);
 }
 
 sub unimport
@@ -313,20 +327,16 @@ sub unimport
     my $catmask ;
     my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
-    if (vec($mask, $Offsets{'all'}, 1)) {
-	$mask |= $Bits{'all'} ;
-	$mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
-    }
-
     # append 'all' when implied (empty import list or after a lone "FATAL")
     push @_, 'all' if !@_ || @_==1 && $_[0] eq 'FATAL';
 
+    $mask = _expand_bits($mask);
     foreach my $word ( @_ ) {
 	if ($word eq 'FATAL') {
 	    next;
 	}
 	elsif ($catmask = $Bits{$word}) {
-	    $mask &= ~($catmask | $DeadBits{$word} | $All);
+	    $mask = ~(~$mask | $catmask | $DeadBits{$word});
 	}
 	else
 	  { Croaker("Unknown warnings category '$word'")}
@@ -396,13 +406,13 @@ sub __chk
     my(@callers_bitmask) = (caller($i))[9] ;
     my $callers_bitmask =
 	 @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ;
+    length($callers_bitmask) > ($offset >> 3) or $offset = $Offsets{all};
 
     my @results;
     foreach my $type (FATAL, NORMAL) {
 	next unless $wanted & $type;
 
-	push @results, (vec($callers_bitmask, $offset + $type - 1, 1) ||
-			vec($callers_bitmask, $Offsets{'all'} + $type - 1, 1));
+	push @results, vec($callers_bitmask, $offset + $type - 1, 1);
     }
 
     # &enabled and &fatal_enabled
@@ -434,14 +444,13 @@ sub register_categories
 
     for my $name (@names) {
 	if (! defined $Bits{$name}) {
-	    $Bits{$name}     = _mkMask($LAST_BIT);
-	    vec($Bits{'all'}, $LAST_BIT, 1) = 1;
-	    $Offsets{$name}  = $LAST_BIT ++;
-	    foreach my $k (keys %Bits) {
-		vec($Bits{$k}, $LAST_BIT, 1) = 0;
+	    $Offsets{$name}  = $LAST_BIT;
+	    $Bits{$name}     = _mkMask($LAST_BIT++);
+	    $DeadBits{$name} = _mkMask($LAST_BIT++);
+	    if (length($Bits{$name}) > length($Bits{all})) {
+		$Bits{all} .= "\x55";
+		$DeadBits{all} .= "\xaa";
 	    }
-	    $DeadBits{$name} = _mkMask($LAST_BIT);
-	    vec($DeadBits{'all'}, $LAST_BIT++, 1) = 1;
 	}
     }
 }