Commit | Line | Data |
---|---|---|
fe13d51d JM |
1 | #!/usr/bin/perl |
2 | use warnings; | |
3 | use strict; | |
4 | use Test::More 'no_plan'; | |
5 | $|=1; | |
6 | ||
f7223e8e | 7 | my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list'; |
87a63fff | 8 | |
38ec24b4 | 9 | open my $diagfh, "<", "../pod/perldiag.pod" |
87a63fff | 10 | or die "Can't open ../pod/perldiag.pod: $!"; |
fe13d51d JM |
11 | |
12 | my %entries; | |
87a63fff JM |
13 | while (<DATA>) { |
14 | chomp; | |
15 | $entries{$_}{todo}=1; | |
16 | } | |
17 | ||
fe13d51d JM |
18 | my $cur_entry; |
19 | while (<$diagfh>) { | |
20 | if (m/^=item (.*)/) { | |
21 | $cur_entry = $1; | |
22 | } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) { | |
87a63fff JM |
23 | # Make sure to init this here, so an actual entry in perldiag overwrites |
24 | # one in DATA. | |
25 | $entries{$cur_entry}{todo} = 0; | |
fe13d51d JM |
26 | $entries{$cur_entry}{severity} = $1; |
27 | $entries{$cur_entry}{category} = $2; | |
28 | } | |
29 | } | |
30 | ||
87a63fff | 31 | my @todo = ('..'); |
fe13d51d JM |
32 | while (@todo) { |
33 | my $todo = shift @todo; | |
a193a2db | 34 | next if $todo ~~ ['../t', '../lib', '../ext', '../dist', '../cpan']; |
fe13d51d | 35 | # opmini.c is just a copy of op.c, so there's no need to check again. |
87a63fff | 36 | next if $todo eq '../opmini.c'; |
fe13d51d JM |
37 | if (-d $todo) { |
38 | push @todo, glob "$todo/*"; | |
87a63fff | 39 | } elsif ($todo =~ m/\.[ch]$/) { |
fe13d51d JM |
40 | check_file($todo); |
41 | } | |
42 | } | |
43 | ||
44 | sub check_file { | |
45 | my ($codefn) = @_; | |
46 | ||
f7223e8e | 47 | print "# $codefn\n"; |
fe13d51d | 48 | |
38ec24b4 | 49 | open my $codefh, "<", $codefn |
fe13d51d JM |
50 | or die "Can't open $codefn: $!"; |
51 | ||
52 | my $listed_as; | |
53 | my $listed_as_line; | |
54 | my $sub = 'top of file'; | |
55 | while (<$codefh>) { | |
56 | chomp; | |
57 | # Getting too much here isn't a problem; we only use this to skip | |
58 | # errors inside of XS modules, which should get documented in the | |
59 | # docs for the module. | |
60 | if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) { | |
61 | $sub = $1; | |
62 | } | |
63 | next if $sub =~ m/^XS/; | |
64 | if (m</\* diag_listed_as: (.*) \*/>) { | |
65 | $listed_as = $1; | |
66 | $listed_as_line = $.+1; | |
67 | } | |
68 | next if /^#/; | |
69 | next if /^ * /; | |
70 | while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) { | |
71 | my $nextline = <$codefh>; | |
72 | # Means we fell off the end of the file. Not terribly surprising; | |
73 | # this code tries to merge a lot of things that aren't regular C | |
74 | # code (preprocessor stuff, long comments). That's OK; we don't | |
75 | # need those anyway. | |
76 | last if not defined $nextline; | |
77 | chomp $nextline; | |
78 | $nextline =~ s/^\s+//; | |
79 | # Note that we only want to do this where *both* are true. | |
80 | $_ =~ s/\\$//; | |
81 | if ($_ =~ m/"$/ and $nextline =~ m/^"/) { | |
82 | $_ =~ s/"$//; | |
83 | $nextline =~ s/^"//; | |
84 | } | |
85 | $_ = "$_$nextline"; | |
86 | } | |
87 | # This should happen *after* unwrapping, or we don't reformat the things | |
88 | # in later lines. | |
89 | # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs" | |
90 | my %specialformats = (IVdf => 'd', | |
91 | UVuf => 'd', | |
92 | UVof => 'o', | |
93 | UVxf => 'x', | |
94 | UVXf => 'X', | |
95 | NVef => 'f', | |
96 | NVff => 'f', | |
97 | NVgf => 'f', | |
98 | SVf => 's'); | |
99 | for my $from (keys %specialformats) { | |
100 | s/%"\s*$from\s*"/\%$specialformats{$from}/g; | |
101 | s/%"\s*$from/\%$specialformats{$from}"/g; | |
102 | } | |
103 | # The %"foo" thing needs to happen *before* this regex. | |
104 | if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s* | |
105 | \(aTHX_ \s* | |
106 | (?:packWARN\d*\((.*?)\),)? \s* | |
107 | "((?:\\"|[^"])*?)"/x) { | |
108 | # diag($_); | |
109 | # DIE is just return Perl_die | |
110 | my $severity = {croak => [qw/P F/], | |
111 | die => [qw/P F/], | |
112 | warn => [qw/W D S/], | |
113 | }->{$1||'die'}; | |
114 | my @categories; | |
115 | if ($2) { | |
116 | @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2; | |
117 | } | |
118 | my $name; | |
119 | if ($listed_as and $listed_as_line == $.) { | |
120 | $name = $listed_as; | |
121 | } else { | |
122 | $name = $3; | |
123 | # The form listed in perldiag ignores most sorts of fancy printf formatting, | |
124 | # or makes it more perlish. | |
125 | $name =~ s/%%/\\%/g; | |
126 | $name =~ s/%l[ud]/%d/g; | |
127 | $name =~ s/%\.(\d+|\*)s/\%s/g; | |
128 | $name =~ s/\\"/"/g; | |
129 | $name =~ s/\\t/\t/g; | |
87a63fff JM |
130 | $name =~ s/\\n/ /g; |
131 | $name =~ s/\s+$//; | |
fe13d51d JM |
132 | } |
133 | ||
87a63fff JM |
134 | # Extra explanatory info on an already-listed error, doesn't |
135 | # need it's own listing. | |
fe13d51d JM |
136 | next if $name =~ m/^\t/; |
137 | ||
138 | # Happens fairly often with PL_no_modify. | |
139 | next if $name eq '%s'; | |
140 | ||
87a63fff JM |
141 | # Special syntax for magic comment, allows ignoring the fact |
142 | # that it isn't listed. Only use in very special circumstances, | |
143 | # like this script failing to notice that the Perl_croak call is | |
144 | # inside an #if 0 block. | |
fe13d51d JM |
145 | next if $name eq 'SKIPME'; |
146 | ||
87a63fff JM |
147 | if (exists $entries{$name}) { |
148 | if ($entries{$name}{todo}) { | |
149 | TODO: { | |
150 | local $TODO = 'in DATA'; | |
151 | fail("Presence of '$name' from $codefn line $."); | |
152 | } | |
fe13d51d | 153 | } else { |
87a63fff | 154 | ok("Presence of '$name' from $codefn line $."); |
fe13d51d | 155 | } |
87a63fff JM |
156 | # Later, should start checking that the severity is correct, too. |
157 | } elsif ($name =~ m/^panic: /) { | |
158 | # Just too many panic:s, they are hard to diagnose, and there | |
159 | # is a generic "panic: %s" entry. Leave these for another | |
160 | # pass. | |
161 | ok("Presence of '$name' from $codefn line $., covered by panic: %s entry"); | |
fe13d51d | 162 | } else { |
87a63fff JM |
163 | if ($make_exceptions_list) { |
164 | print STDERR "$name\n"; | |
165 | } else { | |
166 | fail("Presence of '$name' from $codefn line $."); | |
167 | } | |
fe13d51d JM |
168 | } |
169 | ||
170 | die if $name =~ /%$/; | |
171 | } | |
172 | } | |
173 | } | |
f7223e8e | 174 | # Lists all missing things as of the inaguration of this script, so we |
87a63fff JM |
175 | # don't have to go from "meh" to perfect all at once. |
176 | __DATA__ | |
177 | Ambiguous call resolved as CORE::%s(), %s | |
178 | Ambiguous use of %c resolved as operator %c | |
179 | Ambiguous use of %c{%s} resolved to %c%s | |
180 | Ambiguous use of %c{%s%s} resolved to %c%s%s | |
181 | Ambiguous use of -%s resolved as -&%s() | |
182 | Argument "%s" isn't numeric | |
183 | Argument "%s" isn't numeric in %s | |
184 | Assertion: marks beyond string end | |
185 | Assertion: string is shorter than advertised | |
186 | Attempt to clear deleted array | |
187 | Attempt to free non-arena SV: 0x%x | |
188 | Attempt to free non-existent shared string '%s'%s | |
189 | Attempt to free temp prematurely: SV 0x%x | |
190 | Attempt to free unreferenced scalar: SV 0x%x | |
191 | Attempt to reload %s aborted. Compilation failed in require | |
192 | av_reify called on tied array | |
193 | Bad name after %s%s | |
d5713896 | 194 | Bad symbol for %s |
87a63fff JM |
195 | bad top format reference |
196 | Bizarre copy of %s | |
197 | Bizarre SvTYPE [%d] | |
198 | Cannot copy to %s | |
199 | Can't call method "%s" %s | |
200 | Can't coerce readonly %s to string | |
201 | Can't coerce readonly %s to string in %s | |
202 | Can't fix broken locale name "%s" | |
203 | Can't get short module name from a handle | |
204 | Can't goto subroutine from an eval-block | |
205 | Can't goto subroutine from an eval-string | |
206 | Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?) | |
207 | Can't modify non-existent substring | |
208 | Can't open | |
209 | Can't open perl script "%s": %s | |
210 | Can't open %s | |
211 | Can't reset \%ENV on this system | |
212 | Can't return array to lvalue scalar context | |
213 | Can't return a %s from lvalue subroutine | |
214 | Can't return hash to lvalue scalar context | |
215 | Can't spawn "%s": %s | |
216 | Can't %s script `%s' with ARGV[0] being `%s' | |
217 | Can't %s "%s": %s | |
218 | Can't %s %s%s%s | |
219 | Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found) | |
220 | Can't take %s of %f | |
221 | Can't use '%c' after -mname | |
222 | Can't use \\%c to mean $%c in expression | |
223 | Can't use when() outside a topicalizer | |
224 | \\%c better written as $%c | |
225 | Character(s) in '%c' format wrapped in %s | |
226 | $%c is no longer supported | |
227 | Cloning substitution context is unimplemented | |
228 | Code missing after '/' in pack | |
229 | Code missing after '/' in unpack | |
230 | Compilation failed in require | |
231 | Corrupted regexp opcode %d > %d | |
232 | '%c' outside of string in pack | |
233 | Debug leaking scalars child failed%s%s with errno %d: %s | |
234 | Deep recursion on anonymous subroutine | |
235 | defined(\%hash) is deprecated | |
236 | Don't know how to handle magic of type \\%o | |
237 | -Dp not implemented on this platform | |
238 | entering effective gid failed | |
239 | entering effective uid failed | |
240 | Error reading "%s": %s | |
241 | Exiting %s via %s | |
242 | Filehandle opened only for %sput | |
243 | Filehandle %s opened only for %sput | |
244 | Filehandle STD%s reopened as %s only for input | |
245 | YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET! FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP! | |
246 | Format STDOUT redefined | |
247 | Free to wrong pool %p not %p | |
248 | get %s %p %p %p | |
249 | glob failed (can't start child: %s) | |
250 | glob failed (child exited with status %d%s) | |
251 | Goto undefined subroutine | |
252 | Goto undefined subroutine &%s | |
253 | Hash \%%s missing the \% in argument %d of %s() | |
254 | Illegal character \\%03o (carriage return) | |
255 | Illegal character %sin prototype for %s : %s | |
256 | Integer overflow in decimal number | |
257 | Integer overflow in version %d | |
258 | internal \%<num>p might conflict with future printf extensions | |
259 | invalid control request: '\\%03o' | |
260 | Invalid module name %s with -%c option: contains single ':' | |
261 | invalid option -D%c, use -D'' to see choices | |
262 | Invalid range "%c-%c" in transliteration operator | |
263 | Invalid separator character %c%c%c in PerlIO layer specification %s | |
264 | Invalid TOKEN object ignored | |
265 | Invalid type '%c' in pack | |
266 | Invalid type '%c' in %s | |
267 | Invalid type '%c' in unpack | |
268 | Invalid type ',' in %s | |
269 | Invalid version format (alpha without decimal) | |
270 | Invalid version format (misplaced _ in number) | |
271 | Invalid version object | |
272 | 'j' not supported on this platform | |
273 | 'J' not supported on this platform | |
274 | Layer does not match this perl | |
275 | leaving effective gid failed | |
276 | leaving effective uid failed | |
277 | List form of piped open not implemented | |
278 | Lost precision when decrementing %f by 1 | |
279 | Lost precision when incrementing %f by 1 | |
280 | %lx | |
281 | Malformed UTF-16 surrogate | |
282 | Malformed UTF-8 character (fatal) | |
283 | '\%' may not be used in pack | |
284 | Missing (suid) fd script name | |
285 | More than one argument to open | |
286 | More than one argument to open(,':%s') | |
287 | mprotect for %p %d failed with %d | |
288 | mprotect RW for %p %d failed with %d | |
289 | No code specified for -%c | |
290 | No directory specified for -I | |
291 | No such class field "%s" | |
292 | Not an XSUB reference | |
293 | Not %s reference | |
294 | Offset outside string | |
295 | Opening dirhandle %s also as a file | |
296 | Opening filehandle %s also as a directory | |
297 | Operator or semicolon missing before %c%s | |
298 | Overloaded dereference did not return a reference | |
299 | Perl bug: predicted utf8 length not available | |
300 | PERL_SIGNALS illegal: "%s" | |
301 | Perl %s required (did you mean %s?)--this is only %s, stopped | |
302 | Perl %s required--this is only %s, stopped | |
303 | Perls since %s too modern--this is %s, stopped | |
304 | Possible unintended interpolation of $\\ in regex | |
305 | ptr wrong %p != %p fl=%08 | |
306 | Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?) | |
307 | Recursive call to Perl_load_module in PerlIO_find_layer | |
308 | refcnt_dec: fd %d < 0 | |
309 | refcnt_dec: fd %d: %d <= 0 | |
310 | refcnt_dec: fd %d >= refcnt_size %d | |
311 | refcnt_inc: fd %d < 0 | |
312 | refcnt_inc: fd %d: %d <= 0 | |
313 | Reversed %c= operator | |
314 | Runaway prototype | |
315 | %s(%.0f) failed | |
316 | %s(%.0f) too large | |
317 | Scalar value %s better written as $%s | |
318 | %sCompilation failed in regexp | |
319 | %sCompilation failed in require | |
320 | set %s %p %p %p | |
321 | %s free() ignored (RMAGIC, PERL_CORE) | |
322 | %s has too many errors. | |
323 | SIG%s handler "%s" not defined. | |
324 | %s: illegal mapping '%s' | |
325 | %s in %s | |
326 | Size magic not implemented | |
327 | %s limit (%d) exceeded | |
328 | %s method "%s" overloading "%s" in package "%s" | |
329 | %s number > %s non-portable | |
330 | %s object version %s does not match %s%s%s%s %s | |
331 | %srealloc() %signored | |
332 | %s returned from lvalue subroutine in scalar context | |
333 | %s%s has too many errors. | |
334 | %s%s on %s %s | |
335 | %s%s on %s %s %s | |
336 | Starting Full Screen process with flag=%d, mytype=%d | |
337 | Starting PM process with flag=%d, mytype=%d | |
338 | strxfrm() gets absurd | |
339 | SWASHNEW didn't return an HV ref | |
340 | -T and -B not implemented on filehandles | |
341 | The flock() function is not implemented on NetWare | |
342 | The rewinddir() function is not implemented on NetWare | |
343 | The seekdir() function is not implemented on NetWare | |
344 | The stat preceding lstat() wasn't an lstat | |
345 | The telldir() function is not implemented on NetWare | |
346 | Too deeply nested ()-groups in %s | |
347 | Too late to run CHECK block | |
348 | Too late to run INIT block | |
349 | Too many args on %s line of "%s" | |
350 | U0 mode on a byte string | |
351 | Unbalanced string table refcount: (%d) for "%s" | |
352 | Undefined top format called | |
353 | Unexpected constant lvalue entersub entry via type/targ %d:%d | |
6f6ac1de | 354 | Unicode non-character 0x%04 |
87a63fff JM |
355 | Unknown PerlIO layer "scalar" |
356 | Unknown Unicode option letter '%c' | |
357 | unrecognised control character '%c' | |
358 | Unstable directory path, current directory changed unexpectedly | |
359 | Unsupported script encoding UTF16-BE | |
360 | Unsupported script encoding UTF16-LE | |
361 | Unsupported script encoding UTF32-BE | |
362 | Unsupported script encoding UTF32-LE | |
363 | Unterminated compressed integer in unpack | |
364 | Usage: CODE(0x%x)(%s) | |
365 | Usage: %s(%s) | |
366 | Usage: %s::%s(%s) | |
367 | Usage: VMS::Filespec::unixrealpath(spec) | |
368 | Usage: VMS::Filespec::vmsrealpath(spec) | |
369 | Use of inherited AUTOLOAD for non-method %s::%s() is deprecated | |
370 | UTF-16 surrogate 0x%04 | |
371 | utf8 "\\x%02X" does not map to Unicode | |
372 | Value of logical "%s" too long. Truncating to %i bytes | |
373 | value of node is %d in Offset macro | |
374 | Value of %s%s can be "0"; test with defined() | |
375 | Variable "%c%s" is not imported | |
376 | vector argument not supported with alpha versions | |
377 | Wide character | |
378 | Wide character in $/ | |
379 | Wide character in print | |
380 | Wide character in %s | |
381 | Within []-length '%c' not allowed in %s | |
382 | Wrong syntax (suid) fd script name "%s" | |
383 | 'X' outside of string in unpack |