This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add test to make sure everything that outputs an exception or warning has a matching...
[perl5.git] / t / pod / diag.t
CommitLineData
fe13d51d
JM
1#!/usr/bin/perl
2use warnings;
3use strict;
4use Test::More 'no_plan';
5$|=1;
6
7open my $diagfh, "<:raw", "pod/perldiag.pod"
8 or die "Can't open pod/perldiag.pod: $!";
9
10my %entries;
11my $cur_entry;
12while (<$diagfh>) {
13 if (m/^=item (.*)/) {
14 $cur_entry = $1;
15 } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) {
16 $entries{$cur_entry}{severity} = $1;
17 $entries{$cur_entry}{category} = $2;
18 }
19}
20
21my @todo = ('.');
22while (@todo) {
23 my $todo = shift @todo;
24 next if $todo ~~ ['./t', './lib', './ext'];
25 # opmini.c is just a copy of op.c, so there's no need to check again.
26 next if $todo eq './opmini.c';
27 if (-d $todo) {
28 push @todo, glob "$todo/*";
29 } elsif ($todo =~ m/\.(c|h)$/) {
30 check_file($todo);
31 }
32}
33
34sub check_file {
35 my ($codefn) = @_;
36
37 diag($codefn);
38
39 open my $codefh, "<:raw", $codefn
40 or die "Can't open $codefn: $!";
41
42 my $listed_as;
43 my $listed_as_line;
44 my $sub = 'top of file';
45 while (<$codefh>) {
46 chomp;
47 # Getting too much here isn't a problem; we only use this to skip
48 # errors inside of XS modules, which should get documented in the
49 # docs for the module.
50 if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) {
51 $sub = $1;
52 }
53 next if $sub =~ m/^XS/;
54 if (m</\* diag_listed_as: (.*) \*/>) {
55 $listed_as = $1;
56 $listed_as_line = $.+1;
57 }
58 next if /^#/;
59 next if /^ * /;
60 while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) {
61 my $nextline = <$codefh>;
62 # Means we fell off the end of the file. Not terribly surprising;
63 # this code tries to merge a lot of things that aren't regular C
64 # code (preprocessor stuff, long comments). That's OK; we don't
65 # need those anyway.
66 last if not defined $nextline;
67 chomp $nextline;
68 $nextline =~ s/^\s+//;
69 # Note that we only want to do this where *both* are true.
70 $_ =~ s/\\$//;
71 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
72 $_ =~ s/"$//;
73 $nextline =~ s/^"//;
74 }
75 $_ = "$_$nextline";
76 }
77 # This should happen *after* unwrapping, or we don't reformat the things
78 # in later lines.
79 # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
80 my %specialformats = (IVdf => 'd',
81 UVuf => 'd',
82 UVof => 'o',
83 UVxf => 'x',
84 UVXf => 'X',
85 NVef => 'f',
86 NVff => 'f',
87 NVgf => 'f',
88 SVf => 's');
89 for my $from (keys %specialformats) {
90 s/%"\s*$from\s*"/\%$specialformats{$from}/g;
91 s/%"\s*$from/\%$specialformats{$from}"/g;
92 }
93 # The %"foo" thing needs to happen *before* this regex.
94 if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s*
95 \(aTHX_ \s*
96 (?:packWARN\d*\((.*?)\),)? \s*
97 "((?:\\"|[^"])*?)"/x) {
98 # diag($_);
99 # DIE is just return Perl_die
100 my $severity = {croak => [qw/P F/],
101 die => [qw/P F/],
102 warn => [qw/W D S/],
103 }->{$1||'die'};
104 my @categories;
105 if ($2) {
106 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2;
107 }
108 my $name;
109 if ($listed_as and $listed_as_line == $.) {
110 $name = $listed_as;
111 } else {
112 $name = $3;
113 # The form listed in perldiag ignores most sorts of fancy printf formatting,
114 # or makes it more perlish.
115 $name =~ s/%%/\\%/g;
116 $name =~ s/%l[ud]/%d/g;
117 $name =~ s/%\.(\d+|\*)s/\%s/g;
118 $name =~ s/\\"/"/g;
119 $name =~ s/\\t/\t/g;
120 $name =~ s/\\n/\n/g;
121 $name =~ s/\n$//;
122 }
123
124 # Extra explanitory info on an already-listed error, doesn't need it's own listing.
125 next if $name =~ m/^\t/;
126
127 # Happens fairly often with PL_no_modify.
128 next if $name eq '%s';
129
130 # Special syntax for magic comment, allows ignoring the fact that it isn't listed.
131 # Only use in very special circumstances, like this script failing to notice that
132 # the Perl_croak call is inside an #if 0 block.
133 next if $name eq 'SKIPME';
134
135 if (!exists $entries{$name}) {
136 if ($name =~ m/^panic: /) {
137 # Just too many panic:s, they are hard to diagnose, and there is a generic "panic: %s" entry.
138 # Leave these for another pass.
139 ok("Presence of '$name' from $codefn line $., covered by panic: %s entry");
140 } else {
141 fail("Presence of '$name' from $codefn line $.");
142 }
143 } else {
144 ok("Presence of '$name' from $codefn line $.");
145 # Commented: "substr outside of string" has is either a warning
146 # or an error, depending how much was outside.
147 # Also, plenty of failures without forcing further hardship...
148# if ($entries{$name} and !($entries{$name}{severity} ~~ $severity)) {
149# fail("Severity for '$name' from $codefn line $.: got $entries{$name}{severity}, expected $severity");
150# } else {
151# ok("Severity for '$name' from $codefn line $.: got $entries{$name}{severity}, expected $severity");
152# }
153 }
154
155 die if $name =~ /%$/;
156 }
157 }
158}