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