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