This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
331b356828c9fc7513810bd21cdb31b214e9504a
[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                       HEKf256=>'s',
146                       HEKf => 's',
147                       SVf256=>'s',
148                       SVf32=> 's',
149                       SVf  => 's');
150 my $format_modifiers = qr/ [#0\ +-]*              # optional flags
151                           (?: [1-9][0-9]* | \* )? # optional field width
152                           (?: \. \d* )?           # optional precision
153                           (?: h|l )?              # optional length modifier
154                         /x;
155
156 my $specialformats =
157  join '|', sort { length $b cmp length $a } keys %specialformats;
158 my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
159
160 # Recursively descend looking for source files.
161 my @todo = sort <*>;
162 while (@todo) {
163   my $todo = shift @todo;
164   next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
165   # opmini.c is just a copy of op.c, so there's no need to check again.
166   next if $todo eq 'opmini.c';
167   if (-d $todo) {
168     unshift @todo, sort glob "$todo/*";
169   } elsif ($todo =~ m/\.[ch]$/) {
170     check_file($todo);
171   }
172 }
173
174 # Standardize messages with variants into the form that appears
175 # in perldiag.pod -- useful for things without a diag_listed_as annotation
176 sub standardize {
177   my ($name) = @_;
178
179   if    ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
180     $name = "$1 (\%s)";
181   }
182   elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
183     $name = "$1 (\%s)";
184   }
185   elsif ($name =~ m/^panic: /) {
186     $name = "panic: \%s";
187   }
188
189   return $name;
190 }
191
192 sub check_file {
193   my ($codefn) = @_;
194
195   print "# Checking $codefn\n";
196
197   open my $codefh, "<", $codefn
198     or die "Can't open $codefn: $!";
199
200   my $listed_as;
201   my $listed_as_line;
202   my $sub = 'top of file';
203   while (<$codefh>) {
204     chomp;
205     # Getting too much here isn't a problem; we only use this to skip
206     # errors inside of XS modules, which should get documented in the
207     # docs for the module.
208     if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
209       $sub = $_;
210     }
211     next if $sub =~ m/^XS/;
212     if (m</\* diag_listed_as: (.*) \*/>) {
213       $listed_as = $1;
214       $listed_as_line = $.+1;
215     }
216     next if /^#/;
217     next if /^ +/;
218
219     my $multiline = 0;
220     # Loop to accumulate the message text all on one line.
221     if (m/$source_msg_re/) {
222       while (not m/\);$/) {
223         my $nextline = <$codefh>;
224         # Means we fell off the end of the file.  Not terribly surprising;
225         # this code tries to merge a lot of things that aren't regular C
226         # code (preprocessor stuff, long comments).  That's OK; we don't
227         # need those anyway.
228         last if not defined $nextline;
229         chomp $nextline;
230         $nextline =~ s/^\s+//;
231         $_ =~ s/\\$//;
232         # Note that we only want to do this where *both* are true.
233         if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
234           $_ =~ s/"$//;
235           $nextline =~ s/^"//;
236         }
237         $_ .= $nextline;
238         ++$multiline;
239       }
240     }
241     # This should happen *after* unwrapping, or we don't reformat the things
242     # in later lines.
243
244     s/$specialformats_re/"%$specialformats{$1}" .  (defined $2 ? '' : '"')/ge;
245
246     # Remove any remaining format modifiers, but not in %%
247     s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
248
249     # The %"foo" thing needs to happen *before* this regex.
250     # diag($_);
251     # DIE is just return Perl_die
252     my ($name, $category);
253     if (/$source_msg_call_re/) {
254       ($name, $category) = ($+{'text'}, $+{'category'});
255     }
256     elsif (/$bad_version_re/) {
257       ($name, $category) = ($+{'text'}, undef);
258     }
259     else {
260       next;
261     }
262
263     my $severity = {croak => [qw/P F/],
264                       die   => [qw/P F/],
265                       warn  => [qw/W D S/],
266                      }->{$+{'routine'}||'die'};
267     my @categories;
268     if (defined $category) {
269       @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
270     }
271     if ($listed_as and $listed_as_line == $. - $multiline) {
272       $name = $listed_as;
273     } else {
274       # The form listed in perldiag ignores most sorts of fancy printf
275       # formatting, or makes it more perlish.
276       $name =~ s/%%/\\%/g;
277       $name =~ s/%l[ud]/%d/g;
278       $name =~ s/%\.(\d+|\*)s/\%s/g;
279       $name =~ s/\\"/"/g;
280       $name =~ s/\\t/\t/g;
281       $name =~ s/\\n/ /g;
282       $name =~ s/\s+$//;
283       $name =~ s/(\\)\\/$1/g;
284     }
285
286     # Extra explanatory info on an already-listed error, doesn't
287     # need it's own listing.
288     next if $name =~ m/^\t/;
289
290     # Happens fairly often with PL_no_modify.
291     next if $name eq '%s';
292
293     # Special syntax for magic comment, allows ignoring the fact
294     # that it isn't listed.  Only use in very special circumstances,
295     # like this script failing to notice that the Perl_croak call is
296     # inside an #if 0 block.
297     next if $name eq 'SKIPME';
298
299     $name = standardize($name);
300
301     if (exists $entries{$name}) {
302       if ( $entries{$name}{seen}++ ) {
303         # no need to repeat entries we've tested
304       } elsif ($entries{$name}{todo}) {
305         TODO: {
306           no warnings 'once';
307           local $::TODO = 'in DATA';
308           # There is no listing, but it is in the list of exceptions.  TODO FAIL.
309           fail($name);
310           diag(
311             "    Message '$name'\n    from $codefn line $. is not listed in $pod\n".
312             "    (but it wasn't documented in 5.10 either, so marking it TODO)."
313           );
314         }
315       } else {
316         # We found an actual valid entry in perldiag.pod for this error.
317         pass($name);
318       }
319       # Later, should start checking that the severity is correct, too.
320     } else {
321       if ($make_exceptions_list) {
322         # We're making an updated version of the exception list, to
323         # stick in the __DATA__ section.  I honestly can't think of
324         # a situation where this is the right thing to do, but I'm
325         # leaving it here, just in case one of my descendents thinks
326         # it's a good idea.
327         print STDERR "$name\n";
328       } else {
329         # No listing found, and no excuse either.
330         # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
331         fail($name);
332         diag("    Message '$name'\n    from $codefn line $. is not listed in $pod");
333       }
334       # seen it, so only fail once for this message
335       $entries{$name}{seen}++;
336     }
337
338     die if $name =~ /%$/;
339   }
340 }
341
342 # Lists all missing things as of the inauguration of this script, so we
343 # don't have to go from "meh" to perfect all at once.
344
345 # PLEASE DO NOT ADD TO THIS LIST.  Instead, write an entry in
346 # pod/perldiag.pod for your new (warning|error).
347
348 # Also FIXME this test, as the first entry in TODO *is* covered by the
349 # description: Malformed UTF-8 character (%s)
350 __DATA__
351 Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
352
353 %s (%d) does not match %s (%d),
354 %s (%d) smaller than %s (%d),
355 Argument "%s" isn't numeric
356 Argument "%s" isn't numeric in %s
357 Attempt to clear deleted array
358 Attempt to free non-existent shared string '%s'%s
359 Attempt to free temp prematurely: SV 0x%x
360 Attempt to free unreferenced scalar: SV 0x%x
361 Attempt to reload %s aborted. Compilation failed in require
362 av_reify called on tied array
363 Bad name after %s%s
364 Bad symbol for %s
365 bad top format reference
366 Bizarre copy of %s
367 Bizarre SvTYPE [%d]
368 Cannot copy to %s
369 Can't call method "%s" %s
370 Can't coerce readonly %s to string
371 Can't coerce readonly %s to string in %s
372 Can't fix broken locale name "%s"
373 Can't get short module name from a handle
374 Can't goto subroutine from an eval-block
375 Can't goto subroutine from an eval-string
376 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
377 Can't modify non-existent substring
378 Can't open
379 Can't open perl script "%s": %s
380 Can't open %s
381 Can't reset \%ENV on this system
382 Can't return array to lvalue scalar context
383 Can't return a %s from lvalue subroutine
384 Can't return hash to lvalue scalar context
385 Can't spawn "%s": %s
386 Can't %s script `%s' with ARGV[0] being `%s'
387 Can't %s "%s": %s
388 Can't %s %s%s%s
389 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
390 Can't take %s of %f
391 Can't use '%c' after -mname
392 Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
393 Can't use when() outside a topicalizer
394 \%c better written as $%c
395 Character(s) in '%c' format wrapped in %s
396 $%c is no longer supported
397 Cloning substitution context is unimplemented
398 Code missing after '/' in pack
399 Code missing after '/' in unpack
400 Corrupted regexp opcode %d > %d
401 '%c' outside of string in pack
402 Debug leaking scalars child failed%s%s with errno %d: %s
403 Deep recursion on anonymous subroutine
404 defined(\%hash) is deprecated
405 Don't know how to handle magic of type \%o
406 -Dp not implemented on this platform
407 entering effective gid failed
408 entering effective uid failed
409 Error reading "%s": %s
410 Exiting %s via %s
411 Filehandle opened only for %sput
412 Filehandle %s opened only for %sput
413 Filehandle STD%s reopened as %s only for input
414 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!
415 Format STDOUT redefined
416 Free to wrong pool %p not %p
417 get %s %p %p %p
418 glob failed (can't start child: %s)
419 glob failed (child exited with status %d%s)
420 Goto undefined subroutine
421 Goto undefined subroutine &%s
422 Hash \%%s missing the \% in argument %d of %s()
423 Illegal character %sin prototype for %s : %s
424 Integer overflow in binary number
425 Integer overflow in decimal number
426 Integer overflow in hexadecimal number
427 Integer overflow in octal number
428 Integer overflow in version %d
429 internal \%<num>p might conflict with future printf extensions
430 invalid control request: '\%o'
431 Invalid module name %s with -%c option: contains single ':'
432 invalid option -D%c, use -D'' to see choices
433 Invalid range "%c-%c" in transliteration operator
434 Invalid separator character %c%c%c in PerlIO layer specification %s
435 Invalid TOKEN object ignored
436 Invalid type '%c' in pack
437 Invalid type '%c' in %s
438 Invalid type '%c' in unpack
439 Invalid type ',' in %s
440 'j' not supported on this platform
441 'J' not supported on this platform
442 leaving effective gid failed
443 leaving effective uid failed
444 List form of piped open not implemented
445 Lost precision when decrementing %f by 1
446 Lost precision when incrementing %f by 1
447 %lx
448 Malformed UTF-8 character (fatal)
449 '\%' may not be used in pack
450 Missing (suid) fd script name
451 More than one argument to open
452 More than one argument to open(,':%s')
453 mprotect for %p %u failed with %d
454 mprotect RW for %p %u failed with %d
455 No code specified for -%c
456 No directory specified for -I
457 No such class field "%s"
458 Not an XSUB reference
459 Not %s reference
460 Operator or semicolon missing before %c%s
461 Perl %s required (did you mean %s?)--this is only %s, stopped
462 Perl %s required--this is only %s, stopped
463 Perls since %s too modern--this is %s, stopped
464 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
465 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
466 Recursive call to Perl_load_module in PerlIO_find_layer
467 Reversed %c= operator
468 Runaway prototype
469 %s(%.0
470 %s(%f) failed
471 %s(%f) too large
472 %s(%f) too small
473 Scalar value %s better written as $%s
474 %sCompilation failed in regexp
475 %sCompilation failed in require
476 set %s %p %p %p
477 %s free() ignored (RMAGIC, PERL_CORE)
478 %s has too many errors.
479 SIG%s handler "%s" not defined.
480 %s: illegal mapping '%s'
481 %s in %s
482 Size magic not implemented
483 %s limit (%d) exceeded
484 %s method "%s" overloading "%s" in package "%s"
485 %s number > %s non-portable
486 %s object version %s does not match %s%s%s%s %s
487 %srealloc() %signored
488 %s returned from lvalue subroutine in scalar context
489 %s%s has too many errors.
490 %s%s on %s %s
491 %s%s on %s %s %s
492 Starting Full Screen process with flag=%d, mytype=%d
493 Starting PM process with flag=%d, mytype=%d
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 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