1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
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");
}
|
