This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
diag.t: Ignore formatting precisions in messages
[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     # Convert from internal formats to ones that the readers will be familiar
220     # with, while removing any format modifiers, such as precision, the
221     # presence of which would just confuse the pod's explanation
222     my %specialformats = (IVdf => 'd',
223                           UVuf => 'd',
224                           UVof => 'o',
225                           UVxf => 'x',
226                           UVXf => 'X',
227                           NVef => 'f',
228                           NVff => 'f',
229                           NVgf => 'f',
230                           SVf  => 's');
231     my $format_modifiers = qr/ [#0\ +-]*              # optional flags
232                               (?: [1-9][0-9]* | \* )? # optional field width
233                               (?: \. \d* )? /x;       # optional precision
234     for my $from (keys %specialformats) {
235       s/%$format_modifiers"\s*$from\s*"/\%$specialformats{$from}/g;
236       s/%$format_modifiers"\s*$from/\%$specialformats{$from}"/g;
237     }
238
239     # Remove any remaining format modifiers, but not in %%
240     s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
241
242     # The %"foo" thing needs to happen *before* this regex.
243     if ( my $found = find_message($_) ) {
244     # diag($_);
245     # DIE is just return Perl_die
246     my ($name, $category) = @$found;
247     my $severity = {croak => [qw/P F/],
248                       die   => [qw/P F/],
249                       warn  => [qw/W D S/],
250                      }->{$+{'routine'}||'die'};
251     my @categories;
252     if (defined $category) {
253         @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
254     }
255     if ($listed_as and $listed_as_line == $. - $multiline) {
256         $name = $listed_as;
257     } else {
258         # The form listed in perldiag ignores most sorts of fancy printf
259         # formatting, or makes it more perlish.
260         $name =~ s/%%/\\%/g;
261         $name =~ s/%l[ud]/%d/g;
262         $name =~ s/%\.(\d+|\*)s/\%s/g;
263         $name =~ s/\\"/"/g;
264         $name =~ s/\\t/\t/g;
265         $name =~ s/\\n/ /g;
266         $name =~ s/\s+$//;
267         $name =~ s/(\\)\\/$1/g;
268       }
269
270       # Extra explanatory info on an already-listed error, doesn't
271       # need it's own listing.
272       next if $name =~ m/^\t/;
273
274       # Happens fairly often with PL_no_modify.
275       next if $name eq '%s';
276
277       # Special syntax for magic comment, allows ignoring the fact
278       # that it isn't listed.  Only use in very special circumstances,
279       # like this script failing to notice that the Perl_croak call is
280       # inside an #if 0 block.
281       next if $name eq 'SKIPME';
282
283       $name = standardize($name);
284
285       if (exists $entries{$name}) {
286         if ( $entries{$name}{seen}++ ) {
287           # no need to repeat entries we've tested
288         } elsif ($entries{$name}{todo}) {
289         TODO: {
290             no warnings 'once';
291             local $::TODO = 'in DATA';
292             # There is no listing, but it is in the list of exceptions.  TODO FAIL.
293             fail($name);
294             diag(
295               "    Message '$name'\n    from $codefn line $. is not listed in $pod\n".
296               "    (but it wasn't documented in 5.10 either, so marking it TODO)."
297             );
298           }
299         } else {
300           # We found an actual valid entry in perldiag.pod for this error.
301           pass($name);
302         }
303         # Later, should start checking that the severity is correct, too.
304       } else {
305         if ($make_exceptions_list) {
306           # We're making an updated version of the exception list, to
307           # stick in the __DATA__ section.  I honestly can't think of
308           # a situation where this is the right thing to do, but I'm
309           # leaving it here, just in case one of my descendents thinks
310           # it's a good idea.
311           print STDERR "$name\n";
312         } else {
313           # No listing found, and no excuse either.
314           # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
315           fail($name);
316           diag("    Message '$name'\n    from $codefn line $. is not listed in $pod");
317         }
318         # seen it, so only fail once for this message
319         $entries{$name}{seen}++;
320       }
321
322       die if $name =~ /%$/;
323     }
324   }
325 }
326 # Lists all missing things as of the inauguration of this script, so we
327 # don't have to go from "meh" to perfect all at once.
328
329 # PLEASE DO NOT ADD TO THIS LIST.  Instead, write an entry in
330 # pod/perldiag.pod for your new (warning|error).
331
332 # Also FIXME this test, as the first entry in TODO *is* covered by the
333 # description: Malformed UTF-8 character (%s)
334 __DATA__
335 Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
336
337 %s (%d) does not match %s (%d),
338 %s (%d) smaller than %s (%d),
339 Argument "%s" isn't numeric
340 Argument "%s" isn't numeric in %s
341 Attempt to clear deleted array
342 Attempt to free non-arena SV: 0x%x
343 Attempt to free non-existent shared string '%s'%s
344 Attempt to free temp prematurely: SV 0x%x
345 Attempt to free unreferenced scalar: SV 0x%x
346 Attempt to reload %s aborted. Compilation failed in require
347 av_reify called on tied array
348 Bad name after %s%s
349 Bad symbol for %s
350 bad top format reference
351 Bizarre copy of %s
352 Bizarre SvTYPE [%d]
353 Cannot copy to %s
354 Can't call method "%s" %s
355 Can't coerce readonly %s to string
356 Can't coerce readonly %s to string in %s
357 Can't fix broken locale name "%s"
358 Can't get short module name from a handle
359 Can't goto subroutine from an eval-block
360 Can't goto subroutine from an eval-string
361 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
362 Can't modify non-existent substring
363 Can't open
364 Can't open perl script "%s": %s
365 Can't open %s
366 Can't reset \%ENV on this system
367 Can't return array to lvalue scalar context
368 Can't return a %s from lvalue subroutine
369 Can't return hash to lvalue scalar context
370 Can't spawn "%s": %s
371 Can't %s script `%s' with ARGV[0] being `%s'
372 Can't %s "%s": %s
373 Can't %s %s%s%s
374 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
375 Can't take %s of %f
376 Can't use '%c' after -mname
377 Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
378 Can't use \%c to mean $%c in expression
379 Can't use when() outside a topicalizer
380 \%c better written as $%c
381 Character(s) in '%c' format wrapped in %s
382 $%c is no longer supported
383 Cloning substitution context is unimplemented
384 Code missing after '/' in pack
385 Code missing after '/' in unpack
386 Compilation failed in require
387 Corrupted regexp opcode %d > %d
388 '%c' outside of string in pack
389 Debug leaking scalars child failed%s%s with errno %d: %s
390 Deep recursion on anonymous subroutine
391 defined(\%hash) is deprecated
392 Don't know how to handle magic of type \%o
393 -Dp not implemented on this platform
394 entering effective gid failed
395 entering effective uid failed
396 Error reading "%s": %s
397 Exiting %s via %s
398 Filehandle opened only for %sput
399 Filehandle %s opened only for %sput
400 Filehandle STD%s reopened as %s only for input
401 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!
402 Format STDOUT redefined
403 Free to wrong pool %p not %p
404 get %s %p %p %p
405 glob failed (can't start child: %s)
406 glob failed (child exited with status %d%s)
407 Goto undefined subroutine
408 Goto undefined subroutine &%s
409 Hash \%%s missing the \% in argument %d of %s()
410 Illegal character %sin prototype for %s : %s
411 Integer overflow in binary number
412 Integer overflow in decimal number
413 Integer overflow in hexadecimal number
414 Integer overflow in octal number
415 Integer overflow in version %d
416 internal \%<num>p might conflict with future printf extensions
417 invalid control request: '\%o'
418 Invalid module name %s with -%c option: contains single ':'
419 invalid option -D%c, use -D'' to see choices
420 Invalid range "%c-%c" in transliteration operator
421 Invalid separator character %c%c%c in PerlIO layer specification %s
422 Invalid TOKEN object ignored
423 Invalid type '%c' in pack
424 Invalid type '%c' in %s
425 Invalid type '%c' in unpack
426 Invalid type ',' in %s
427 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 ";"
428 'j' not supported on this platform
429 'J' not supported on this platform
430 leaving effective gid failed
431 leaving effective uid failed
432 List form of piped open not implemented
433 Lost precision when decrementing %f by 1
434 Lost precision when incrementing %f by 1
435 %lx
436 Malformed UTF-16 surrogate
437 Malformed UTF-8 character (fatal)
438 '\%' may not be used in pack
439 Missing (suid) fd script name
440 More than one argument to open
441 More than one argument to open(,':%s')
442 mprotect for %p %d failed with %d
443 mprotect RW for %p %d failed with %d
444 No code specified for -%c
445 No directory specified for -I
446 No such class field "%s"
447 Not an XSUB reference
448 Not %s reference
449 Offset outside string
450 Opening dirhandle %s also as a file
451 Opening filehandle %s also as a directory
452 Operator or semicolon missing before %c%s
453 PERL_SIGNALS illegal: "%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 Possible unintended interpolation of $\ in regex
458 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
459 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
460 Recursive call to Perl_load_module in PerlIO_find_layer
461 refcnt_dec: fd %d < 0
462 refcnt_dec: fd %d: %d <= 0
463 refcnt_dec: fd %d >= refcnt_size %d
464 refcnt_inc: fd %d < 0
465 refcnt_inc: fd %d: %d <= 0
466 Reversed %c= operator
467 Runaway prototype
468 %s(%.0
469 %s(%f) failed
470 %s(%f) too large
471 %s(%f) too small
472 Scalar value %s better written as $%s
473 %sCompilation failed in regexp
474 %sCompilation failed in require
475 set %s %p %p %p
476 %s free() ignored (RMAGIC, PERL_CORE)
477 %s has too many errors.
478 SIG%s handler "%s" not defined.
479 %s: illegal mapping '%s'
480 %s in %s
481 Size magic not implemented
482 %s limit (%d) exceeded
483 %s method "%s" overloading "%s" in package "%s"
484 %s number > %s non-portable
485 %s object version %s does not match %s%s%s%s %s
486 %srealloc() %signored
487 %s returned from lvalue subroutine in scalar context
488 %s%s has too many errors.
489 %s%s on %s %s
490 %s%s on %s %s %s
491 Starting Full Screen process with flag=%d, mytype=%d
492 Starting PM process with flag=%d, mytype=%d
493 strxfrm() gets absurd
494 SWASHNEW didn't return an HV ref
495 -T and -B not implemented on filehandles
496 The flock() function is not implemented on NetWare
497 The rewinddir() function is not implemented on NetWare
498 The seekdir() function is not implemented on NetWare
499 The stat preceding lstat() wasn't an lstat
500 The telldir() function is not implemented on NetWare
501 Too deeply nested ()-groups in %s
502 Too late to run CHECK block
503 Too late to run INIT block
504 Too many args on %s line of "%s"
505 U0 mode on a byte string
506 Unbalanced string table refcount: (%d) for "%s"
507 Undefined top format called
508 Unexpected constant lvalue entersub entry via type/targ %d:%d
509 Unicode non-character 0x%X
510 Unknown PerlIO layer "scalar"
511 Unknown Unicode option letter '%c'
512 Unstable directory path, current directory changed unexpectedly
513 Unsupported script encoding UTF-16BE
514 Unsupported script encoding UTF-16LE
515 Unsupported script encoding UTF-32BE
516 Unsupported script encoding UTF-32LE
517 Unterminated compressed integer in unpack
518 Usage: CODE(0x%x)(%s)
519 Usage: %s(%s)
520 Usage: %s::%s(%s)
521 Usage: VMS::Filespec::unixrealpath(spec)
522 Usage: VMS::Filespec::vmsrealpath(spec)
523 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
524 utf8 "\x%X" does not map to Unicode
525 Value of logical "%s" too long. Truncating to %i bytes
526 value of node is %d in Offset macro
527 Value of %s%s can be "0"; test with defined()
528 Variable "%c%s" is not imported
529 vector argument not supported with alpha versions
530 Wide character
531 Wide character in $/
532 Wide character in print
533 Wide character in %s
534 Within []-length '%c' not allowed in %s
535 Wrong syntax (suid) fd script name "%s"
536 'X' outside of string in unpack