1#!/usr/bin/perl 2 3BEGIN { 4 if (-f './TestInit.pm') { 5 @INC = '.'; 6 } elsif (-f '../TestInit.pm') { 7 @INC = '..'; 8 } 9} 10use TestInit qw(T); # T is chdir to the top level 11 12use warnings; 13use strict; 14use Config; 15use Data::Dumper; 16require './t/test.pl'; 17 18plan("no_plan"); 19 20# Test that all deprecations in regen/warnings.pl are mentioned in 21# pod/perldeprecation.pod and that there is sufficient time between them. 22 23my $pod_file = "./pod/perldeprecation.pod"; 24my $warnings_file = "./regen/warnings.pl"; 25 26do $warnings_file; 27our $WARNING_TREE; 28 29my $deprecated = $WARNING_TREE->{all}[1]{deprecated}[2]; 30 31open my $fh, "<", $pod_file 32 or die "failed to open '$pod_file': $!"; 33my $removed_in_version; 34my $subject; 35my %category_seen; 36my %subject_has_category; 37my $in_legacy; 38 39while (<$fh>) { 40 if (/^=head2 (?|Perl (5\.\d+)(?:\.\d+)?|(Unscheduled))/) { # ignore minor version 41 $removed_in_version = lc $1; 42 if ($removed_in_version eq "5.38") { 43 $in_legacy = 1; 44 } 45 } 46 elsif (/^=head3 (.*)/) { 47 my $new_subject = $1; 48 if (!$in_legacy and $subject) { 49 ok($subject_has_category{$subject}, 50 "Subject '$subject' has a category specified"); 51 } 52 $subject = $new_subject; 53 } 54 elsif (/^Category: "([::\w]+)"/) { 55 my $category = $1; 56 $category_seen{$category} = $removed_in_version; 57 $subject_has_category{$subject} = $category; 58 next if $removed_in_version eq "unscheduled"; 59 my $tuple = $deprecated->{$category}; 60 ok( $tuple, "Deprecated category '$category' ($subject) exists in $warnings_file") 61 or next; 62 my $added_in_version = $tuple->[0]; 63 $added_in_version =~ s/(5\.\d{3})\d+/$1/; 64 65 my $diff = $removed_in_version - $added_in_version; 66 cmp_ok($diff, ">=", 0.004, # two production cycles 67 "Version change for '$category' ($subject) is sufficiently after deprecation date") 68 } 69} 70# make sure that all the deprecated categories have an entry of some sort 71foreach my $category (sort keys %$deprecated) { 72 ok($category_seen{$category},"Deprecated category '$category' is documented in $pod_file"); 73} 74# make sure that there arent any new uses of WARN_DEPRECATED, 75# note that \< and \> are ERE expressions roughly equivalent to perl regex \b 76if (-e ".git") { 77 chomp(my @warn_deprecated = `git grep "\<WARN_DEPRECATED\>"`); 78 my %files; 79 foreach my $line (@warn_deprecated) { 80 my ($file, $text) = split /:/, $line, 2; 81 if ($file =~ m!^dist/Devel-PPPort! || 82 $file eq "t/porting/diag.t" || 83 ($file eq "warnings.h" && $text=~/^[=#]/) 84 ) { 85 next; 86 } 87 $files{$file}++; 88 } 89 is(0+keys %files, 0, 90 "There should not be any new files which mention WARN_DEPRECATED"); 91} 92 93# Test that deprecation warnings are produced under "use warnings" 94# (set above) 95{ 96 my $warning = "nada"; 97 local $SIG{__WARN__} = sub { $warning = $_[0] }; 98 my $count = 0; 99 while ($count<1) { 100 LABEL: $count++; 101 goto DONE if $count>1; 102 } 103 goto LABEL; 104 DONE: 105 like($warning, 106 qr/Use of "goto" to jump into a construct is deprecated/, 107 "Got expected deprecation warning"); 108} 109# Test that we can silence deprecation warnings with "no warnings 'deprecated'" 110# as we used to. 111{ 112 no warnings 'deprecated'; 113 my $warning = "nada"; 114 local $SIG{__WARN__} = sub { $warning = $_[0] }; 115 my $count = 0; 116 while ($count<1) { 117 LABEL: $count++; 118 goto DONE if $count>1; 119 } 120 goto LABEL; 121 DONE: 122 like($warning, qr/nada/, 123 "no warnings 'deprecated'; silenced deprecation warning as expected"); 124} 125 126# Test that we can silence a specific deprecation warnings with "no warnings 'deprecated::$subcategory'" 127# and that by doing so we don't silence any other deprecation warnings. 128{ 129 no warnings 'deprecated::goto_construct'; 130 my $warning = "nada"; 131 local $SIG{__WARN__} = sub { $warning = $_[0] }; 132 my $count = 0; 133 while ($count<1) { 134 LABEL: $count++; 135 goto DONE if $count>1; 136 } 137 goto LABEL; 138 DONE: 139 like($warning, qr/nada/, 140 "no warnings 'deprecated::goto_construct'; silenced deprecation warning as expected"); 141 @INC = (); 142 do "regen.pl"; # this should produce a deprecation warning 143 like($warning, qr/is no longer in \@INC/, 144 "no warnings 'deprecated::goto_construct'; did not silence deprecated::dot_in_inc warnings"); 145} 146