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