# 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.
#
# This script is normally invoked from regen.pl.
-$VERSION = '1.02_03';
+$VERSION = '1.02_05';
BEGIN {
require 'regen/regen_lib.pl';
'newline' => [ 5.008, DEFAULT_OFF],
'exec' => [ 5.008, DEFAULT_OFF],
'layer' => [ 5.008, DEFAULT_OFF],
+ 'syscalls' => [ 5.019, DEFAULT_OFF],
}],
'syntax' => [ 5.008, {
'ambiguous' => [ 5.008, DEFAULT_OFF],
}],
'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],
'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],
'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 ],
+ 'experimental::postderef' =>
+ [ 5.019, DEFAULT_ON ],
+ }],
#'default' => [ 5.008, DEFAULT_ON ],
}],
} ;
-###########################################################################
-sub tab {
- my($l, $t) = @_;
- $t .= "\t" x ($l - (length($t) + 1) / 8);
- $t;
-}
-
-###########################################################################
-
+my @def ;
my %list ;
my %Value ;
my %ValueToName ;
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} } ;
}
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))
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" ;
isWARNf_on(PL_curcop->cop_warnings, unpackWARN4(x))))
/* end of file warnings.h */
-/* ex: set ro: */
EOM
-close_and_rename($warn);
+read_only_bottom_close_and_rename($warn);
while (<DATA>) {
last if /^KEYWORDS$/ ;
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>) {
print $pm $_ ;
}
-print $pm "# ex: set ro:\n";
-close_and_rename($pm);
+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.20';
# Verify that we're called correctly so that warnings will work.
# see also strict.pm.
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.
{
shift;
- my $mask = ${^WARNING_BITS} ;
+ my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
if (vec($mask, $Offsets{'all'}, 1)) {
$mask |= $Bits{'all'} ;
shift;
my $catmask ;
- my $mask = ${^WARNING_BITS} ;
+ my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ;
if (vec($mask, $Offsets{'all'}, 1)) {
$mask |= $Bits{'all'} ;
$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) {
# 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;
https://perl5.git.perl.org / perl5.git / blobdiff