diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | regen/warnings.pl | 226 | ||||
| -rw-r--r-- | t/porting/deprecation.t | 145 |
3 files changed, 260 insertions, 112 deletions
@@ -6220,6 +6220,7 @@ t/porting/copyright.t Check that copyright years match t/porting/corelist.t Check that Module-CoreList has perl versions for the current perl t/porting/customized.dat Data file for porting/customized.t t/porting/customized.t Check all CUSTOMIZED files are as they should be +t/porting/deprecation.t Test that deprecation warnings are handled right t/porting/diag.t Test completeness of perldiag.pod t/porting/dual-life.t Check that dual-life bins are in utils/ t/porting/exec-bit.t Check that exec-bit bins are identified diff --git a/regen/warnings.pl b/regen/warnings.pl index 1d1aa1de66..4b598bbc31 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -5,13 +5,13 @@ # lib/warnings.pm # warnings.h # -# from information hardcoded into this script (the $TREE hash), plus the +# from information hardcoded into this script (the $WARNING_TREE hash), plus the # template for warnings.pm in the DATA section. # # 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. +# With an argument of 'tree', just dump the contents of $WARNING_TREE and exits. # Also accepts the standard regen_lib -q and -v args. # # This script is normally invoked from regen.pl. @@ -44,7 +44,7 @@ sub DEFAULT_OFF () { 2 } # created. But the warnings category 'io' WILL include all the mask bits # necessary to turn on 'pipe', 'unopened' etc. -my $TREE = { +our $WARNING_TREE = { 'all' => [ 5.008, { 'io' => [ 5.008, { 'pipe' => [ 5.008, DEFAULT_OFF], @@ -334,7 +334,7 @@ sub warningsTree if !ref $v || ref $v ne 'ARRAY' ; my $offset ; - if ($tree ne $TREE) { + if ($tree ne $WARNING_TREE) { $rv .= $prefix . "|\n" ; $rv .= $prefix . "+- $k" ; $offset = ' ' x ($max + 4) ; @@ -404,149 +404,151 @@ sub mkOct ########################################################################### +sub main { -if (@ARGV && $ARGV[0] eq "tree") -{ - print warningsTree($TREE, " ") ; - exit ; -} - -my ($warn_h, $warn_pm) = map { - open_new($_, '>', { by => 'regen/warnings.pl' }); -} 'warnings.h', 'lib/warnings.pm'; + if (@ARGV && $ARGV[0] eq "tree") + { + print warningsTree($WARNING_TREE, " ") ; + exit ; + } -my ($index, $warn_size); + my ($warn_h, $warn_pm) = map { + open_new($_, '>', { by => 'regen/warnings.pl' }); + } 'warnings.h', 'lib/warnings.pm'; -# generate warnings.h + my ($index, $warn_size); -print $warn_h warnings_h_boilerplate_1(); + # generate warnings.h -$index = orderValues($TREE); + print $warn_h warnings_h_boilerplate_1(); -die <<EOM if $index > 255 ; -Too many warnings categories -- max is 255 -rewrite packWARN* & unpackWARN* macros -EOM + $index = orderValues($WARNING_TREE); -walk ($TREE) ; -for (my $i = $index; $i & 3; $i++) { - push @{$CATEGORIES{all}}, $i; -} + die <<~EOM if $index > 255 ; + Too many warnings categories -- max is 255 + rewrite packWARN* & unpackWARN* macros + EOM -$index *= 2 ; -$warn_size = int($index / 8) + ($index % 8 != 0) ; - -my $k ; -my $last_ver = 0; -my @names; -foreach $k (sort { $a <=> $b } keys %VALUE_TO_NAME) { - my ($name, $version) = @{ $VALUE_TO_NAME{$k} }; - print $warn_h "\n/* Warnings Categories added in Perl $version */\n\n" - if $last_ver != $version ; - $name =~ y/:/_/; - $name = "WARN_$name"; - print $warn_h tab(6, "#define $name"), " $k\n" ; - push @names, $name; - $last_ver = $version ; -} + walk ($WARNING_TREE) ; + for (my $i = $index; $i & 3; $i++) { + push @{$CATEGORIES{all}}, $i; + } -print $warn_h tab(6, '#define WARNsize'), " $warn_size\n" ; -print $warn_h tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ; -print $warn_h tab(6, '#define WARN_NONEstring'), ' "', ('\0' x $warn_size) , "\"\n" ; + $index *= 2 ; + $warn_size = int($index / 8) + ($index % 8 != 0) ; + + my $k ; + my $last_ver = 0; + my @names; + foreach $k (sort { $a <=> $b } keys %VALUE_TO_NAME) { + my ($name, $version) = @{ $VALUE_TO_NAME{$k} }; + print $warn_h "\n/* Warnings Categories added in Perl $version */\n\n" + if $last_ver != $version ; + $name =~ y/:/_/; + $name = "WARN_$name"; + print $warn_h tab(6, "#define $name"), " $k\n" ; + push @names, $name; + $last_ver = $version ; + } -print $warn_h warnings_h_boilerplate_2(); + print $warn_h tab(6, '#define WARNsize'), " $warn_size\n" ; + print $warn_h tab(6, '#define WARN_ALLstring'), ' "', ('\125' x $warn_size) , "\"\n" ; + print $warn_h tab(6, '#define WARN_NONEstring'), ' "', ('\0' x $warn_size) , "\"\n" ; -print $warn_h "\n\n/*\n" ; -print $warn_h map { "=for apidoc Amnh||$_\n" } @names; -print $warn_h "\n=cut\n*/\n\n" ; -print $warn_h "/* end of file warnings.h */\n"; + print $warn_h warnings_h_boilerplate_2(); -read_only_bottom_close_and_rename($warn_h); + print $warn_h "\n\n/*\n" ; + print $warn_h map { "=for apidoc Amnh||$_\n" } @names; + print $warn_h "\n=cut\n*/\n\n" ; + print $warn_h "/* end of file warnings.h */\n"; + read_only_bottom_close_and_rename($warn_h); -# generate warnings.pm -while (<DATA>) { - last if /^VERSION$/ ; - print $warn_pm $_ ; -} + # generate warnings.pm -print $warn_pm qq(our \$VERSION = "$::VERSION";\n); + while (<DATA>) { + last if /^VERSION$/ ; + print $warn_pm $_ ; + } -while (<DATA>) { - last if /^KEYWORDS$/ ; - print $warn_pm $_ ; -} + print $warn_pm qq(our \$VERSION = "$::VERSION";\n); -$last_ver = 0; -print $warn_pm "our %Offsets = (" ; -foreach my $k (sort { $a <=> $b } keys %VALUE_TO_NAME) { - my ($name, $version) = @{ $VALUE_TO_NAME{$k} }; - $name = lc $name; - $k *= 2 ; - if ( $last_ver != $version ) { - print $warn_pm "\n"; - print $warn_pm tab(6, " # Warnings Categories added in Perl $version"); - print $warn_pm "\n"; + while (<DATA>) { + last if /^KEYWORDS$/ ; + print $warn_pm $_ ; } - print $warn_pm tab(6, " '$name'"), "=> $k,\n" ; - $last_ver = $version; -} -print $warn_pm ");\n\n" ; + $last_ver = 0; + print $warn_pm "our %Offsets = (" ; + foreach my $k (sort { $a <=> $b } keys %VALUE_TO_NAME) { + my ($name, $version) = @{ $VALUE_TO_NAME{$k} }; + $name = lc $name; + $k *= 2 ; + if ( $last_ver != $version ) { + print $warn_pm "\n"; + print $warn_pm tab(6, " # Warnings Categories added in Perl $version"); + print $warn_pm "\n"; + } + print $warn_pm tab(6, " '$name'"), "=> $k,\n" ; + $last_ver = $version; + } -print $warn_pm "our %Bits = (\n" ; -foreach my $k (sort keys %CATEGORIES) { + print $warn_pm ");\n\n" ; - my $v = $CATEGORIES{$k} ; - my @list = sort { $a <=> $b } @$v ; + print $warn_pm "our %Bits = (\n" ; + foreach my $k (sort keys %CATEGORIES) { - print $warn_pm tab(6, " '$k'"), '=> "', - mkHex($warn_size, map $_ * 2 , @list), - '", # [', mkRange(@list), "]\n" ; -} + my $v = $CATEGORIES{$k} ; + my @list = sort { $a <=> $b } @$v ; -print $warn_pm ");\n\n" ; + print $warn_pm tab(6, " '$k'"), '=> "', + mkHex($warn_size, map $_ * 2 , @list), + '", # [', mkRange(@list), "]\n" ; + } -print $warn_pm "our %DeadBits = (\n" ; -foreach my $k (sort keys %CATEGORIES) { + print $warn_pm ");\n\n" ; - my $v = $CATEGORIES{$k} ; - my @list = sort { $a <=> $b } @$v ; + print $warn_pm "our %DeadBits = (\n" ; + foreach my $k (sort keys %CATEGORIES) { - print $warn_pm tab(6, " '$k'"), '=> "', - mkHex($warn_size, map $_ * 2 + 1 , @list), - '", # [', mkRange(@list), "]\n" ; -} + my $v = $CATEGORIES{$k} ; + my @list = sort { $a <=> $b } @$v ; -print $warn_pm ");\n\n" ; + print $warn_pm tab(6, " '$k'"), '=> "', + mkHex($warn_size, map $_ * 2 + 1 , @list), + '", # [', mkRange(@list), "]\n" ; + } -print $warn_pm "our %NoOp = (\n" ; -foreach my $k ( grep /\A[a-z:_]+\z/, sort keys %NO_BIT_FOR ) { - print $warn_pm tab(6, " '$k'"), "=> 1,\n"; -} + print $warn_pm ");\n\n" ; -print $warn_pm ");\n\n" ; -print $warn_pm "# These are used by various things, including our own tests\n"; -print $warn_pm tab(6, 'our $NONE'), '= "', ('\0' x $warn_size) , "\";\n" ; -print $warn_pm tab(6, 'our $DEFAULT'), '= "', - mkHex($warn_size, map $_ * 2, @DEFAULTS), - '"; # [', mkRange(sort { $a <=> $b } @DEFAULTS), "]\n" ; -print $warn_pm tab(6, 'our $LAST_BIT'), '= ' . "$index ;\n" ; -print $warn_pm tab(6, 'our $BYTES'), '= ' . "$warn_size ;\n" ; -while (<DATA>) { - if ($_ eq "=for warnings.pl tree-goes-here\n") { - print $warn_pm warningsTree($TREE, " "); - next; + print $warn_pm "our %NoOp = (\n" ; + foreach my $k ( grep /\A[a-z:_]+\z/, sort keys %NO_BIT_FOR ) { + print $warn_pm tab(6, " '$k'"), "=> 1,\n"; } - print $warn_pm $_ ; -} -read_only_bottom_close_and_rename($warn_pm); + print $warn_pm ");\n\n" ; + print $warn_pm "# These are used by various things, including our own tests\n"; + print $warn_pm tab(6, 'our $NONE'), '= "', ('\0' x $warn_size) , "\";\n" ; + print $warn_pm tab(6, 'our $DEFAULT'), '= "', + mkHex($warn_size, map $_ * 2, @DEFAULTS), + '"; # [', mkRange(sort { $a <=> $b } @DEFAULTS), "]\n" ; + print $warn_pm tab(6, 'our $LAST_BIT'), '= ' . "$index ;\n" ; + print $warn_pm tab(6, 'our $BYTES'), '= ' . "$warn_size ;\n" ; + while (<DATA>) { + if ($_ eq "=for warnings.pl tree-goes-here\n") { + print $warn_pm warningsTree($WARNING_TREE, " "); + next; + } + print $warn_pm $_ ; + } -exit(0); + read_only_bottom_close_and_rename($warn_pm); + exit(0); +} +main() unless caller(); # ----------------------------------------------------------------- sub warnings_h_boilerplate_1 { return <<'EOM'; } diff --git a/t/porting/deprecation.t b/t/porting/deprecation.t new file mode 100644 index 0000000000..109818fe6f --- /dev/null +++ b/t/porting/deprecation.t @@ -0,0 +1,145 @@ +#!/usr/bin/perl + +BEGIN { + if (-f './TestInit.pm') { + @INC = '.'; + } elsif (-f '../TestInit.pm') { + @INC = '..'; + } +} +use TestInit qw(T); # T is chdir to the top level + +use warnings; +use strict; +use Config; +use Data::Dumper; +require './t/test.pl'; + +plan("no_plan"); + +# Test that all deprecations in regen/warnings.pl are mentioned in +# pod/perldeprecation.pod and that there is sufficient time between them. + +my $pod_file = "./pod/perldeprecation.pod"; +my $warnings_file = "./regen/warnings.pl"; + +do $warnings_file; +our $WARNING_TREE; + +my $deprecated = $WARNING_TREE->{all}[1]{deprecated}[2]; + +open my $fh, "<", $pod_file + or die "failed to open '$pod_file': $!"; +my $removed_in_version; +my $subject; +my %category_seen; +my %subject_has_category; +my $in_legacy; + +while (<$fh>) { + if (/^=head2 (?|Perl (5\.\d+)(?:\.\d+)?|(Unscheduled))/) { # ignore minor version + $removed_in_version = lc $1; + if ($removed_in_version eq "5.38") { + $in_legacy = 1; + } + } + elsif (/^=head3 (.*)/) { + my $new_subject = $1; + if (!$in_legacy and $subject) { + ok($subject_has_category{$subject}, + "Subject '$subject' has a category specified"); + } + $subject = $new_subject; + } + elsif (/^Category: "([::\w]+)"/) { + my $category = $1; + $category_seen{$category} = $removed_in_version; + $subject_has_category{$subject} = $category; + next if $removed_in_version eq "unscheduled"; + my $tuple = $deprecated->{$category}; + ok( $tuple, "Deprecated category '$category' ($subject) exists in $warnings_file") + or next; + my $added_in_version = $tuple->[0]; + $added_in_version =~ s/(5\.\d{3})\d+/$1/; + + my $diff = $removed_in_version - $added_in_version; + cmp_ok($diff, ">=", 0.004, # two production cycles + "Version change for '$category' ($subject) is sufficiently after deprecation date") + } +} +# make sure that all the deprecated categories have an entry of some sort +foreach my $category (sort keys %$deprecated) { + ok($category_seen{$category},"Deprecated category '$category' is documented in $pod_file"); +} +# make sure that there arent any new uses of WARN_DEPRECATED, +# note that \< and \> are ERE expressions roughly equivalent to perl regex \b +if (-e ".git") { + chomp(my @warn_deprecated = `git grep "\<WARN_DEPRECATED\>"`); + my %files; + foreach my $line (@warn_deprecated) { + my ($file, $text) = split /:/, $line, 2; + if ($file =~ m!^dist/Devel-PPPort! || + $file eq "t/porting/diag.t" || + ($file eq "warnings.h" && $text=~/^[=#]/) + ) { + next; + } + $files{$file}++; + } + is(0+keys %files, 0, + "There should not be any new files which mention WARN_DEPRECATED"); +} + +# Test that deprecation warnings are produced under "use warnings" +# (set above) +{ + my $warning = "nada"; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + my $count = 0; + while ($count<1) { + LABEL: $count++; + goto DONE if $count>1; + } + goto LABEL; + DONE: + like($warning, + qr/Use of "goto" to jump into a construct is deprecated/, + "Got expected deprecation warning"); +} +# Test that we can silence deprecation warnings with "no warnings 'deprecated'" +# as we used to. +{ + no warnings 'deprecated'; + my $warning = "nada"; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + my $count = 0; + while ($count<1) { + LABEL: $count++; + goto DONE if $count>1; + } + goto LABEL; + DONE: + like($warning, qr/nada/, + "no warnings 'deprecated'; silenced deprecation warning as expected"); +} + +# Test that we can silence a specific deprecation warnings with "no warnings 'deprecated::$subcategory'" +# and that by doing so we don't silence any other deprecation warnings. +{ + no warnings 'deprecated::goto_construct'; + my $warning = "nada"; + local $SIG{__WARN__} = sub { $warning = $_[0] }; + my $count = 0; + while ($count<1) { + LABEL: $count++; + goto DONE if $count>1; + } + goto LABEL; + DONE: + like($warning, qr/nada/, + "no warnings 'deprecated::goto_construct'; silenced deprecation warning as expected"); + @INC = (); + do "regen.pl"; # this should produce a deprecation warning + like($warning, qr/is no longer in \@INC/, + "no warnings 'deprecated::goto_construct'; did not silence deprecated::dot_in_inc warnings"); +} |