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