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