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