This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix handling of registered warning categories
[perl5.git] / regen / warnings.pl
index 5721c17..b9692ab 100644 (file)
@@ -16,7 +16,7 @@
 #
 # This script is normally invoked from regen.pl.
 
-$VERSION = '1.37';
+$VERSION = '1.38';
 
 BEGIN {
     require './regen/regen_lib.pl';
@@ -338,6 +338,9 @@ Too many warnings categories -- max is 255
 EOM
 
   walk ($tree) ;
+  for (my $i = $index; $i & 3; $i++) {
+      push @{$list{all}}, $i;
+  }
 
   $index *= 2 ;
   $warn_size = int($index / 8) + ($index % 8 != 0) ;
@@ -462,13 +465,15 @@ is by default enabled even if not within the scope of S<C<use warnings>>.
 #define unpackWARN4(x)         (((x) >>24) & 0xFF)
 
 #define ckDEAD(x)                                                      \
-          (PL_curcop &&                                                \
-            !specialWARN(PL_curcop->cop_warnings) &&                   \
-           ( isWARNf_on(PL_curcop->cop_warnings, WARN_ALL) ||          \
-             isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||    \
-             isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||    \
-             isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||    \
-             isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
+   (PL_curcop &&                                                        \
+    !specialWARN(PL_curcop->cop_warnings) &&                           \
+    (isWARNf_on(PL_curcop->cop_warnings, unpackWARN1(x)) ||            \
+      (unpackWARN2(x) &&                                                \
+       (isWARNf_on(PL_curcop->cop_warnings, unpackWARN2(x)) ||         \
+         (unpackWARN3(x) &&                                            \
+           (isWARNf_on(PL_curcop->cop_warnings, unpackWARN3(x)) ||     \
+             (unpackWARN4(x) &&                                        \
+               isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x)))))))))
 
 /* end of file warnings.h */
 EOM
@@ -561,8 +566,6 @@ die sprintf "Incorrect use of pragma '%s' at %s line %d.\n", __PACKAGE__, +(call
 
 KEYWORDS
 
-our $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
-
 sub Croaker
 {
     require Carp; # this initializes %CarpInternal
@@ -571,12 +574,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;
@@ -589,7 +612,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'")}
@@ -602,7 +625,7 @@ sub bits
 {
     # called from B::Deparse.pm
     push @_, 'all' unless @_ ;
-    return _bits(undef, @_) ;
+    return _bits("", @_) ;
 }
 
 sub import
@@ -611,16 +634,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
@@ -630,20 +649,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'")}
@@ -713,13 +728,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
@@ -751,14 +766,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;
        }
     }
 }