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