Revert "regcomp.c: Add a constant 0 element before inversion lists"

[perl5.git] / regen / warnings.pl

diff --git a/regen/warnings.pl b/regen/warnings.pl
index 454035f..72d9a0b 100644 (file)
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -3,10 +3,16 @@
 # Regenerate (overwriting only if changed):
 #
 #    lib/warnings.pm
+#    pod/perllexwarn.pod
 #    warnings.h
 #
 # from information hardcoded into this script (the $tree hash), plus the
-# template for warnings.pm in the DATA section.
+# template for warnings.pm in the DATA section.  Only part of
+# pod/perllexwarn.pod (the warnings category hierarchy) is generated,
+# the other parts remaining untouched.
+#
+# When changing the number of warnings, t/op/caller.t should change to
+# correspond with the value of $BYTES in lib/warnings.pm
 #
 # With an argument of 'tree', just dump the contents of $tree and exits.
 # Also accepts the standard regen_lib -q and -v args.
@@ -50,11 +56,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],
@@ -63,7 +69,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],
@@ -71,17 +77,32 @@ my $tree = {
        'closure'       => [ 5.008, DEFAULT_OFF],
        'overflow'      => [ 5.008, DEFAULT_OFF],
        'portable'      => [ 5.008, DEFAULT_OFF],
-       'utf8'          => [ 5.008, DEFAULT_OFF],
+       'utf8'          => [ 5.008, {
+                                'surrogate' => [ 5.013, DEFAULT_OFF],
+                                'nonchar' => [ 5.013, DEFAULT_OFF],
+                                'non_unicode' => [ 5.013, DEFAULT_OFF],
+                        }],
                'exiting'       => [ 5.008, DEFAULT_OFF],
                'pack'          => [ 5.008, DEFAULT_OFF],
                'unpack'        => [ 5.008, DEFAULT_OFF],
                'threads'       => [ 5.008, DEFAULT_OFF],
                'imprecision'   => [ 5.011, DEFAULT_OFF],
+               'experimental'  => [ 5.017, {
+                                'experimental::lexical_subs' =>
+                                    [ 5.017, DEFAULT_ON ],
+                                'experimental::regex_sets' =>
+                                    [ 5.017, DEFAULT_ON ],
+                                'experimental::lexical_topic' =>
+                                    [ 5.017, DEFAULT_ON ],
+                                'experimental::smartmatch' =>
+                                    [ 5.017, DEFAULT_ON ],
+                        }],
 
                 #'default'     => [ 5.008, DEFAULT_ON ],
        }],
 } ;
 
+my @def ;
 my %list ;
 my %Value ;
 my %ValueToName ;
@@ -144,6 +165,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} } ;
     }
@@ -253,11 +276,11 @@ if (@ARGV && $ARGV[0] eq "tree")
     exit ;
 }
 
-my $warn = safer_open('warnings.h-new', 'warnings.h');
-my $pm = safer_open('lib/warnings.pm-new', 'lib/warnings.pm');
+my ($warn, $pm) = map {
+    open_new($_, '>', { by => 'regen/warnings.pl' });
+} 'warnings.h', 'lib/warnings.pm';
 
-print $pm read_only_top(lang => 'Perl', by => 'regen/warnings.pl');
-print $warn read_only_top(lang => 'C', by => 'regen/warnings.pl'), <<'EOM';
+print $warn <<'EOM';
 
 #define Off(x)                 ((x) / 8)
 #define Bit(x)                 (1 << ((x) % 8))
@@ -303,7 +326,8 @@ foreach $k (sort { $a <=> $b } keys %ValueToName) {
     my ($name, $version) = @{ $ValueToName{$k} };
     print $warn "\n/* Warnings Categories added in Perl $version */\n\n"
         if $last_ver != $version ;
-    print $warn tab(5, "#define WARN_$name"), "$k\n" ;
+    $name =~ y/:/_/;
+    print $warn tab(5, "#define WARN_$name"), " $k\n" ;
     $last_ver = $version ;
 }
 print $warn "\n" ;
@@ -409,6 +433,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>) {
@@ -417,10 +443,29 @@ while (<DATA>) {
 
 read_only_bottom_close_and_rename($pm);
 
+my $lexwarn = open_new 'pod/perllexwarn.pod', '>';
+open my $oldlexwarn, "pod/perllexwarn.pod"
+  or die "$0 cannot open pod/perllexwarn.pod for reading: $!";
+select +(select($lexwarn), do {
+    while(<$oldlexwarn>) {
+       print;
+       last if /=for warnings.pl begin/;
+    }
+    print "\n";
+    printTree($tree, "    ") ;
+    print "\n";
+    while(<$oldlexwarn>) {
+       last if /=for warnings.pl end/;
+    }
+    do { print } while <$oldlexwarn>;
+})[0];
+
+close_and_rename($lexwarn);
+
 __END__
 package warnings;
 
-our $VERSION = '1.12';
+our $VERSION = '1.18';
 
 # Verify that we're called correctly so that warnings will work.
 # see also strict.pm.
@@ -462,7 +507,8 @@ warnings - Perl pragma to control optional warnings
 
 The C<warnings> pragma is a replacement for the command line flag C<-w>,
 but the pragma is limited to the enclosing block, while the flag is global.
-See L<perllexwarn> for more information.
+See L<perllexwarn> for more information and the list of built-in warning
+categories.
 
 If no import list is supplied, all possible warnings are either enabled
 or disabled.
@@ -628,7 +674,7 @@ sub import
 {
     shift;
 
-    my $mask = ${^WARNING_BITS} ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -644,7 +690,7 @@ sub unimport
     shift;
 
     my $catmask ;
-    my $mask = ${^WARNING_BITS} ;
+    my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
 
     if (vec($mask, $Offsets{'all'}, 1)) {
         $mask |= $Bits{'all'} ;
@@ -723,8 +769,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) {
@@ -802,6 +851,6 @@ sub warnif
 
 # These are not part of any public interface, so we can delete them to save
 # space.
-delete $warnings::{$_} foreach qw(NORMAL FATAL MESSAGE);
+delete @warnings::{qw(NORMAL FATAL MESSAGE)};
 
 1;