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