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