This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
570114170f7a5134d7019a2b303913bc66e58cf1
[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 $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?\b';
54 my $source_msg_re =
55    "(?<routine>\\bDIE\\b|$function_re|$regcomp_fail_re)";
56 my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
57 my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
58     \(aTHX_ \s*
59     (?:packWARN\d*\((?<category>.*?)\),)? \s*
60     $text_re /x;
61 my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
62    $regcomp_fail_re = qr/$regcomp_fail_re\([^"]*$text_re/;
63
64 my %entries;
65
66 # Get the ignores that are compiled into this file
67 while (<DATA>) {
68   chomp;
69   $entries{$_}{todo}=1;
70 }
71
72 my $pod = "pod/perldiag.pod";
73 my $cur_entry;
74 open my $diagfh, "<", $pod
75   or die "Can't open $pod: $!";
76
77 my $category_re = qr/ [a-z0-9_]+?/;      # Note: requires an initial space
78 my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
79                                         # be of the form 'S|P|W'
80 while (<$diagfh>) {
81   if (m/^=item (.*)/) {
82     $cur_entry = $1 =~ s/\s+\z//r;
83
84     if (exists $entries{$cur_entry}) {
85         TODO: {
86             local $::TODO = "Remove the TODO entry \"$cur_entry\" from DATA as it is already in $pod near line $.";
87             ok($cur_entry);
88         }
89     }
90     # Make sure to init this here, so an actual entry in perldiag
91     # overwrites one in DATA.
92     $entries{$cur_entry}{todo} = 0;
93     $entries{$cur_entry}{line_number} = $.;
94     next;
95   }
96
97   next if ! defined $cur_entry;
98
99   if (! $entries{$cur_entry}{severity}) {
100     if (/^ \( ( $severity_re )
101
102         # Can have multiple categories separated by commas
103         (?: ( $category_re ) (?: , $category_re)* )? \) /x)
104     {
105       $entries{$cur_entry}{severity} = $1;
106       $entries{$cur_entry}{category} = $2;
107     }
108     elsif (! $entries{$cur_entry}{first_line} && $_ =~ /\S/) {
109
110       # Keep track of first line of text if doesn't contain a severity, so
111       # that can later examine it to determine if that is ok or not
112       $entries{$cur_entry}{first_line} = $_;
113     }
114   }
115 }
116
117 foreach my $cur_entry ( keys %entries) {
118     next if $entries{$cur_entry}{todo}; # If in this file, won't have a severity
119     if (! exists $entries{$cur_entry}{severity}
120
121             # If there is no first line, it was two =items in a row, so the
122             # second one is the one with with text, not this one.
123         && exists $entries{$cur_entry}{first_line}
124
125             # If the first line refers to another message, no need for severity
126         && $entries{$cur_entry}{first_line} !~ /^See/)
127     {
128         fail($cur_entry);
129         diag(
130             "   $pod entry at line $entries{$cur_entry}{line_number}\n"
131           . "       \"$cur_entry\"\n"
132           . "   is missing a severity and/or category"
133         );
134     }
135 }
136
137 # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
138 # Convert from internal formats to ones that the readers will be familiar
139 # with, while removing any format modifiers, such as precision, the
140 # presence of which would just confuse the pod's explanation
141 my %specialformats = (IVdf => 'd',
142                       UVuf => 'd',
143                       UVof => 'o',
144                       UVxf => 'x',
145                       UVXf => 'X',
146                       NVef => 'f',
147                       NVff => 'f',
148                       NVgf => 'f',
149                       HEKf256=>'s',
150                       HEKf => 's',
151                       SVf256=>'s',
152                       SVf32=> 's',
153                       SVf  => 's');
154 my $format_modifiers = qr/ [#0\ +-]*              # optional flags
155                           (?: [1-9][0-9]* | \* )? # optional field width
156                           (?: \. \d* )?           # optional precision
157                           (?: h|l )?              # optional length modifier
158                         /x;
159
160 my $specialformats =
161  join '|', sort { length $b cmp length $a } keys %specialformats;
162 my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
163
164 # Recursively descend looking for source files.
165 my @todo = sort <*>;
166 while (@todo) {
167   my $todo = shift @todo;
168   next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
169   # opmini.c is just a copy of op.c, so there's no need to check again.
170   next if $todo eq 'opmini.c';
171   if (-d $todo) {
172     unshift @todo, sort glob "$todo/*";
173   } elsif ($todo =~ m/\.[ch]$/) {
174     check_file($todo);
175   }
176 }
177
178 # Standardize messages with variants into the form that appears
179 # in perldiag.pod -- useful for things without a diag_listed_as annotation
180 sub standardize {
181   my ($name) = @_;
182
183   if    ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
184     $name = "$1 (\%s)";
185   }
186   elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
187     $name = "$1 (\%s)";
188   }
189   elsif ($name =~ m/^panic: /) {
190     $name = "panic: \%s";
191   }
192
193   return $name;
194 }
195
196 sub check_file {
197   my ($codefn) = @_;
198
199   print "# Checking $codefn\n";
200
201   open my $codefh, "<", $codefn
202     or die "Can't open $codefn: $!";
203
204   my $listed_as;
205   my $listed_as_line;
206   my $sub = 'top of file';
207   while (<$codefh>) {
208     chomp;
209     # Getting too much here isn't a problem; we only use this to skip
210     # errors inside of XS modules, which should get documented in the
211     # docs for the module.
212     if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
213       $sub = $_;
214     }
215     next if $sub =~ m/^XS/;
216     if (m</\* diag_listed_as: (.*) \*/>) {
217       $listed_as = $1;
218       $listed_as_line = $.+1;
219     }
220     next if /^#/;
221
222     my $multiline = 0;
223     # Loop to accumulate the message text all on one line.
224     if (m/$source_msg_re(?:_nocontext)?\s*\(/) {
225       while (not m/\);$/) {
226         my $nextline = <$codefh>;
227         # Means we fell off the end of the file.  Not terribly surprising;
228         # this code tries to merge a lot of things that aren't regular C
229         # code (preprocessor stuff, long comments).  That's OK; we don't
230         # need those anyway.
231         last if not defined $nextline;
232         chomp $nextline;
233         $nextline =~ s/^\s+//;
234         $_ =~ s/\\$//;
235         # Note that we only want to do this where *both* are true.
236         if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
237           $_ =~ s/"$//;
238           $nextline =~ s/^"//;
239         }
240         $_ .= $nextline;
241         ++$multiline;
242       }
243     }
244     # This should happen *after* unwrapping, or we don't reformat the things
245     # in later lines.
246
247     s/$specialformats_re/"%$specialformats{$1}" .  (defined $2 ? '' : '"')/ge;
248
249     # Remove any remaining format modifiers, but not in %%
250     s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
251
252     # The %"foo" thing needs to happen *before* this regex.
253     # diag($_);
254     # DIE is just return Perl_die
255     my ($name, $category);
256     if (/$source_msg_call_re/) {
257       ($name, $category) = ($+{'text'}, $+{'category'});
258     }
259     elsif (/$bad_version_re/) {
260       ($name, $category) = ($+{'text'}, undef);
261     }
262     elsif (/$regcomp_fail_re/) {
263       #  FAIL("foo") -> "foo in regex m/%s/"
264       # vFAIL("foo") -> "foo in regex; marked by <-- HERE in m/%s/"
265       ($name, $category) = ($+{'text'}, undef);
266       $name .=
267         " in regex" . ("; marked by <-- HERE in" x /vFAIL/) . " m/%s/";
268     }
269     else {
270       next;
271     }
272
273     my $severity = {croak => [qw/P F/],
274                       die   => [qw/P F/],
275                       warn  => [qw/W D S/],
276                      }->{$+{'routine'}||'die'};
277     my @categories;
278     if (defined $category) {
279       @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
280     }
281     if ($listed_as and $listed_as_line == $. - $multiline) {
282       $name = $listed_as;
283     } else {
284       # The form listed in perldiag ignores most sorts of fancy printf
285       # formatting, or makes it more perlish.
286       $name =~ s/%%/%/g;
287       $name =~ s/%l[ud]/%d/g;
288       $name =~ s/%\.(\d+|\*)s/\%s/g;
289       $name =~ s/(?:%s){2,}/%s/g;
290       $name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
291       $name =~ s/\\t/\t/g;
292       $name =~ s/\\n/\n/g;
293       $name =~ s/\s+$//;
294       $name =~ s/(\\)\\/$1/g;
295     }
296
297     # Extra explanatory info on an already-listed error, doesn't
298     # need it's own listing.
299     next if $name =~ m/^\t/;
300
301     # Happens fairly often with PL_no_modify.
302     next if $name eq '%s';
303
304     # Special syntax for magic comment, allows ignoring the fact
305     # that it isn't listed.  Only use in very special circumstances,
306     # like this script failing to notice that the Perl_croak call is
307     # inside an #if 0 block.
308     next if $name eq 'SKIPME';
309
310     check_message(standardize($name),$codefn);
311   }
312 }
313
314 sub check_message {
315     my($name,$codefn,$partial) = @_;
316     my $key = $name =~ y/\n/ /r;
317     my $ret;
318
319     if (exists $entries{$key}) {
320       $ret = 1;
321       if ( $entries{$key}{seen}++ ) {
322         # no need to repeat entries we've tested
323       } elsif ($entries{$name}{todo}) {
324         TODO: {
325           no warnings 'once';
326           local $::TODO = 'in DATA';
327           # There is no listing, but it is in the list of exceptions.  TODO FAIL.
328           fail($name);
329           diag(
330             "    Message '$name'\n    from $codefn line $. is not listed in $pod\n".
331             "    (but it wasn't documented in 5.10 either, so marking it TODO)."
332           );
333         }
334       } else {
335         # We found an actual valid entry in perldiag.pod for this error.
336         pass($key);
337       }
338       # Later, should start checking that the severity is correct, too.
339     } elsif ($partial) {
340       # noop
341     } else {
342       my $ok;
343       if ($name =~ /\n/) {
344         $ok = 1;
345         check_message($_,$codefn,1) or $ok = 0, last for split /\n/, $name;
346       }
347       if ($ok) {
348         # noop
349       } elsif ($make_exceptions_list) {
350         # We're making an updated version of the exception list, to
351         # stick in the __DATA__ section.  I honestly can't think of
352         # a situation where this is the right thing to do, but I'm
353         # leaving it here, just in case one of my descendents thinks
354         # it's a good idea.
355         print STDERR "$key\n";
356       } else {
357         # No listing found, and no excuse either.
358         # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
359         fail($name);
360         diag("    Message '$name'\n    from $codefn line $. is not listed in $pod");
361       }
362       # seen it, so only fail once for this message
363       $entries{$name}{seen}++;
364     }
365
366     die if $name =~ /%$/;
367     return $ret;
368 }
369
370 # Lists all missing things as of the inauguration of this script, so we
371 # don't have to go from "meh" to perfect all at once.
372
373 # PLEASE DO NOT ADD TO THIS LIST.  Instead, write an entry in
374 # pod/perldiag.pod for your new (warning|error).
375
376 # Also FIXME this test, as the first entry in TODO *is* covered by the
377 # description: Malformed UTF-8 character (%s)
378 __DATA__
379 Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
380
381 '%c' allowed only after types %s in %s
382 bad top format reference
383 Cannot apply "%s" in non-PerlIO perl
384 Can't %s big-endian %ss on this
385 Can't call mro_isa_changed_in() on anonymous symbol table
386 Can't call mro_method_changed_in() on anonymous symbol table
387 Can't coerce readonly %s to string
388 Can't coerce readonly %s to string in %s
389 Can't find string terminator %c%s%c anywhere before EOF
390 Can't fix broken locale name "%s"
391 Can't get short module name from a handle
392 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
393 Can't pipe "%s": %s
394 Can't spawn: %s
395 Can't spawn "%s": %s
396 Can't %s script `%s' with ARGV[0] being `%s'
397 Can't %s "%s": %s
398 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
399 Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
400 \%c better written as $%c
401 Character(s) in '%c' format wrapped in %s
402 chown not implemented!
403 clear %s
404 Code missing after '/' in pack
405 Code missing after '/' in unpack
406 Corrupted regexp opcode %d > %d
407 '%c' outside of string in pack
408 Debug leaking scalars child failed%s with errno %d: %s
409 '/' does not take a repeat count in %s
410 Don't know how to get file name
411 Don't know how to handle magic of type \%o
412 -Dp not implemented on this platform
413 Empty \%c{} in regex; marked by <-- HERE in m/%s/
414 Error reading "%s": %s
415 execl not implemented!
416 EVAL without pos change exceeded limit in regex
417 Expecting close bracket in regex; marked by <-- HERE in m/%s/
418 Filehandle opened only for %sput
419 Filehandle %s opened only for %sput
420 Filehandle STD%s reopened as %s only for input
421 filter_del can only delete in reverse order (currently)
422 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!
423 fork() not implemented!
424 free %s
425 Free to wrong pool %p not %p
426 get %s %p %p %p
427 gethostent not implemented!
428 getpwnam returned invalid UIC %o for user "%s"
429 glob failed (can't start child: %s)
430 glob failed (child exited with status %d%s)
431 Goto undefined subroutine
432 Goto undefined subroutine &%s
433 Got signal %d
434 ()-group starts with a count in %s
435 Illegal binary digit '%c' ignored
436 Illegal character %sin prototype for %s : %s
437 Illegal hexadecimal digit '%c' ignored
438 Illegal octal digit '%c' ignored
439 Illegal pattern in regex; marked by <-- HERE in m/%s/
440 Infinite recursion in regex
441 internal %<num>p might conflict with future printf extensions
442 Invalid argument to sv_cat_decode
443 Invalid [::] class in regex; marked by <-- HERE in m/%s/
444 Invalid [] range "%*.*s" in regex; marked by <-- HERE in m/%s/
445 Invalid range "%c-%c" in transliteration operator
446 Invalid separator character %c%c%c in PerlIO layer specification %s
447 Invalid TOKEN object ignored
448 Invalid type '%c' in pack
449 Invalid type '%c' in %s
450 Invalid type '%c' in unpack
451 Invalid type ',' in %s
452 ioctlsocket not implemented!
453 'j' not supported on this platform
454 'J' not supported on this platform
455 Junk on end of regexp in regex m/%s/
456 killpg not implemented!
457 length() used on %s (did you mean "scalar(%s)"?)
458 length() used on %hash (did you mean "scalar(keys %hash)"?)
459 length() used on @array (did you mean "scalar(@array)"?)
460 List form of pipe open not implemented
461 Malformed integer in [] in %s
462 Malformed UTF-8 character (fatal)
463 Missing (suid) fd script name
464 More than one argument to open
465 More than one argument to open(,':%s')
466 mprotect for %p %u failed with %d
467 mprotect RW for %p %u failed with %d
468 No %s allowed while running setgid
469 No %s allowed with (suid) fdscript
470 No such class field "%s"
471 Not an XSUB reference
472 Operator or semicolon missing before %c%s
473 Pattern subroutine nesting without pos change exceeded limit in regex
474 Perl %s required--this is only %s, stopped
475 POSIX syntax [%c %c] is reserved for future extensions in regex; marked by <-- HERE in m/%s/
476 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
477 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
478 Reference to invalid group 0 in regex; marked by <-- HERE in m/%s/
479 Regexp modifier "%c" may appear a maximum of twice in regex; marked by <-- HERE in m/%s/
480 Regexp modifier "%c" may not appear twice in regex; marked by <-- HERE in m/%s/
481 Regexp modifiers "%c" and "%c" are mutually exclusive in regex; marked by <-- HERE in m/%s/
482 Regexp *+ operand could be empty in regex; marked by <-- HERE in m/%s/
483 Repeated format line will never terminate (~~ and @#)
484 Reversed %c= operator
485 %s(%f) failed
486 %sCompilation failed in require
487 Sequence (?%c...) not implemented in regex; marked by <-- HERE in m/%s/
488 Sequence (%s...) not recognized in regex; marked by <-- HERE in m/%s/
489 Sequence %s... not terminated in regex; marked by <-- HERE in m/%s/
490 Sequence (?%c... not terminated in regex; marked by <-- HERE in m/%s/
491 Sequence (?(%c... not terminated in regex; marked by <-- HERE in m/%s/
492 Sequence (?R) not terminated in regex m/%s/
493 set %s %p %p %p
494 %s free() ignored (RMAGIC, PERL_CORE)
495 %s has too many errors.
496 SIG%s handler "%s" not defined.
497 %s in %s
498 Size magic not implemented
499 %s number > %s non-portable
500 %srealloc() %signored
501 %s in regex m/%s/
502 %s on %s %s
503 socketpair not implemented!
504 Starting Full Screen process with flag=%d, mytype=%d
505 Starting PM process with flag=%d, mytype=%d
506 sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%f U_V is 0x%x, IV_MAX is 0x%x
507 SWASHNEW didn't return an HV ref
508 switching effective gid is not implemented
509 switching effective uid is not implemented
510 System V IPC is not implemented on this machine
511 -T and -B not implemented on filehandles
512 Terminating on signal SIG%s(%d)
513 The crypt() function is unimplemented due to excessive paranoia.
514 The crypt() function is not implemented on NetWare
515 The flock() function is not implemented on NetWare
516 The rewinddir() function is not implemented on NetWare
517 The seekdir() function is not implemented on NetWare
518 The telldir() function is not implemented on NetWare
519 Too deeply nested ()-groups in %s
520 Too many args on %s line of "%s"
521 U0 mode on a byte string
522 unable to find VMSPIPE.COM for i/o piping
523 Unknown Unicode option value %d
524 Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
525 Unstable directory path, current directory changed unexpectedly
526 Unterminated compressed integer in unpack
527 Unterminated \g... pattern in regex; marked by <-- HERE in m/%s/
528 Usage: CODE(0x%x)(%s)
529 Usage: %s(%s)
530 Usage: %s::%s(%s)
531 Usage: File::Copy::rmscopy(from,to[,date_flag])
532 Usage: VMS::Filespec::candelete(spec)
533 Usage: VMS::Filespec::fileify(spec)
534 Usage: VMS::Filespec::pathify(spec)
535 Usage: VMS::Filespec::rmsexpand(spec[,defspec])
536 Usage: VMS::Filespec::unixify(spec)
537 Usage: VMS::Filespec::unixpath(spec)
538 Usage: VMS::Filespec::unixrealpath(spec)
539 Usage: VMS::Filespec::vmsify(spec)
540 Usage: VMS::Filespec::vmspath(spec)
541 Usage: VMS::Filespec::vmsrealpath(spec)
542 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
543 utf8 "\x%X" does not map to Unicode
544 Value of logical "%s" too long. Truncating to %i bytes
545 waitpid: process %x is not a child of process %x
546 Wide character
547 Wide character in $/
548 Within []-length '*' not allowed in %s
549 Within []-length '%c' not allowed in %s
550 Wrong syntax (suid) fd script name "%s"
551 'X' outside of string in %s
552 'X' outside of string in unpack