Commit | Line | Data |
---|---|---|
fe13d51d JM |
1 | #!/usr/bin/perl |
2 | use warnings; | |
3 | use strict; | |
4 | use Test::More 'no_plan'; | |
5 | $|=1; | |
6 | ||
7 | open my $diagfh, "<:raw", "pod/perldiag.pod" | |
8 | or die "Can't open pod/perldiag.pod: $!"; | |
9 | ||
10 | my %entries; | |
11 | my $cur_entry; | |
12 | while (<$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 | ||
21 | my @todo = ('.'); | |
22 | while (@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 | ||
34 | sub 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 | } |