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