This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perldiag: Document ‘Integer overflow in srand’
[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 = "(?<routine>\\bDIE\\b|$function_re)";
54 my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
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
219     my $multiline = 0;
220     # Loop to accumulate the message text all on one line.
221     if (m/$source_msg_re(?:_nocontext)?\s*\(/) {
222       while (not m/\);$/) {
223         my $nextline = <$codefh>;
224         # Means we fell off the end of the file.  Not terribly surprising;
225         # this code tries to merge a lot of things that aren't regular C
226         # code (preprocessor stuff, long comments).  That's OK; we don't
227         # need those anyway.
228         last if not defined $nextline;
229         chomp $nextline;
230         $nextline =~ s/^\s+//;
231         $_ =~ s/\\$//;
232         # Note that we only want to do this where *both* are true.
233         if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
234           $_ =~ s/"$//;
235           $nextline =~ s/^"//;
236         }
237         $_ .= $nextline;
238         ++$multiline;
239       }
240     }
241     # This should happen *after* unwrapping, or we don't reformat the things
242     # in later lines.
243
244     s/$specialformats_re/"%$specialformats{$1}" .  (defined $2 ? '' : '"')/ge;
245
246     # Remove any remaining format modifiers, but not in %%
247     s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
248
249     # The %"foo" thing needs to happen *before* this regex.
250     # diag($_);
251     # DIE is just return Perl_die
252     my ($name, $category);
253     if (/$source_msg_call_re/) {
254       ($name, $category) = ($+{'text'}, $+{'category'});
255     }
256     elsif (/$bad_version_re/) {
257       ($name, $category) = ($+{'text'}, undef);
258     }
259     else {
260       next;
261     }
262
263     my $severity = {croak => [qw/P F/],
264                       die   => [qw/P F/],
265                       warn  => [qw/W D S/],
266                      }->{$+{'routine'}||'die'};
267     my @categories;
268     if (defined $category) {
269       @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
270     }
271     if ($listed_as and $listed_as_line == $. - $multiline) {
272       $name = $listed_as;
273     } else {
274       # The form listed in perldiag ignores most sorts of fancy printf
275       # formatting, or makes it more perlish.
276       $name =~ s/%%/%/g;
277       $name =~ s/%l[ud]/%d/g;
278       $name =~ s/%\.(\d+|\*)s/\%s/g;
279       $name =~ s/(?:%s){2,}/%s/g;
280       $name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
281       $name =~ s/\\t/\t/g;
282       $name =~ s/\\n/\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     check_message(standardize($name),$codefn);
301   }
302 }
303
304 sub check_message {
305     my($name,$codefn,$partial) = @_;
306     my $key = $name =~ y/\n/ /r;
307     my $ret;
308
309     if (exists $entries{$key}) {
310       $ret = 1;
311       if ( $entries{$key}{seen}++ ) {
312         # no need to repeat entries we've tested
313       } elsif ($entries{$name}{todo}) {
314         TODO: {
315           no warnings 'once';
316           local $::TODO = 'in DATA';
317           # There is no listing, but it is in the list of exceptions.  TODO FAIL.
318           fail($name);
319           diag(
320             "    Message '$name'\n    from $codefn line $. is not listed in $pod\n".
321             "    (but it wasn't documented in 5.10 either, so marking it TODO)."
322           );
323         }
324       } else {
325         # We found an actual valid entry in perldiag.pod for this error.
326         pass($key);
327       }
328       # Later, should start checking that the severity is correct, too.
329     } elsif ($partial) {
330       # noop
331     } else {
332       my $ok;
333       if ($name =~ /\n/) {
334         $ok = 1;
335         check_message($_,$codefn,1) or $ok = 0, last for split /\n/, $name;
336       }
337       if ($ok) {
338         # noop
339       } elsif ($make_exceptions_list) {
340         # We're making an updated version of the exception list, to
341         # stick in the __DATA__ section.  I honestly can't think of
342         # a situation where this is the right thing to do, but I'm
343         # leaving it here, just in case one of my descendents thinks
344         # it's a good idea.
345         print STDERR "$key\n";
346       } else {
347         # No listing found, and no excuse either.
348         # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
349         fail($name);
350         diag("    Message '$name'\n    from $codefn line $. is not listed in $pod");
351       }
352       # seen it, so only fail once for this message
353       $entries{$name}{seen}++;
354     }
355
356     die if $name =~ /%$/;
357     return $ret;
358 }
359
360 # Lists all missing things as of the inauguration of this script, so we
361 # don't have to go from "meh" to perfect all at once.
362
363 # PLEASE DO NOT ADD TO THIS LIST.  Instead, write an entry in
364 # pod/perldiag.pod for your new (warning|error).
365
366 # Also FIXME this test, as the first entry in TODO *is* covered by the
367 # description: Malformed UTF-8 character (%s)
368 __DATA__
369 Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
370
371 '%c' allowed only after types %s in %s
372 bad top format reference
373 Cannot apply "%s" in non-PerlIO perl
374 Can't %s big-endian %ss on this
375 Can't call mro_isa_changed_in() on anonymous symbol table
376 Can't call mro_method_changed_in() on anonymous symbol table
377 Can't coerce readonly %s to string
378 Can't coerce readonly %s to string in %s
379 Can't find string terminator %c%s%c anywhere before EOF
380 Can't fix broken locale name "%s"
381 Can't get short module name from a handle
382 Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
383 Can't pipe "%s": %s
384 Can't spawn: %s
385 Can't spawn "%s": %s
386 Can't %s script `%s' with ARGV[0] being `%s'
387 Can't %s "%s": %s
388 Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
389 Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
390 \%c better written as $%c
391 Character(s) in '%c' format wrapped in %s
392 chown not implemented!
393 clear %s
394 Code missing after '/' in pack
395 Code missing after '/' in unpack
396 Corrupted regexp opcode %d > %d
397 '%c' outside of string in pack
398 Debug leaking scalars child failed%s with errno %d: %s
399 '/' does not take a repeat count in %s
400 Don't know how to get file name
401 Don't know how to handle magic of type \%o
402 -Dp not implemented on this platform
403 Error reading "%s": %s
404 execl not implemented!
405 EVAL without pos change exceeded limit in regex
406 Filehandle opened only for %sput
407 Filehandle %s opened only for %sput
408 Filehandle STD%s reopened as %s only for input
409 filter_del can only delete in reverse order (currently)
410 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!
411 fork() not implemented!
412 free %s
413 Free to wrong pool %p not %p
414 get %s %p %p %p
415 gethostent not implemented!
416 getpwnam returned invalid UIC %o for user "%s"
417 glob failed (can't start child: %s)
418 glob failed (child exited with status %d%s)
419 Goto undefined subroutine
420 Goto undefined subroutine &%s
421 Got signal %d
422 ()-group starts with a count in %s
423 Illegal binary digit '%c' ignored
424 Illegal character %sin prototype for %s : %s
425 Illegal hexadecimal digit '%c' ignored
426 Illegal octal digit '%c' ignored
427 Infinite recursion in regex
428 internal %<num>p might conflict with future printf extensions
429 Invalid argument to sv_cat_decode
430 Invalid range "%c-%c" in transliteration operator
431 Invalid separator character %c%c%c in PerlIO layer specification %s
432 Invalid TOKEN object ignored
433 Invalid type '%c' in pack
434 Invalid type '%c' in %s
435 Invalid type '%c' in unpack
436 Invalid type ',' in %s
437 ioctlsocket not implemented!
438 'j' not supported on this platform
439 'J' not supported on this platform
440 killpg not implemented!
441 length() used on %s (did you mean "scalar(%s)"?)
442 length() used on %hash (did you mean "scalar(keys %hash)"?)
443 length() used on @array (did you mean "scalar(@array)"?)
444 List form of pipe open not implemented
445 Malformed integer in [] in %s
446 Malformed UTF-8 character (fatal)
447 Missing (suid) fd script name
448 More than one argument to open
449 More than one argument to open(,':%s')
450 mprotect for %p %u failed with %d
451 mprotect RW for %p %u failed with %d
452 No %s allowed while running setgid
453 No %s allowed with (suid) fdscript
454 No such class field "%s"
455 Not an XSUB reference
456 Operator or semicolon missing before %c%s
457 Pattern subroutine nesting without pos change exceeded limit in regex
458 Perl %s required--this is only %s, stopped
459 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
460 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
461 Repeated format line will never terminate (~~ and @#)
462 Reversed %c= operator
463 %s(%f) failed
464 %sCompilation failed in require
465 set %s %p %p %p
466 %s free() ignored (RMAGIC, PERL_CORE)
467 %s has too many errors.
468 SIG%s handler "%s" not defined.
469 %s in %s
470 Size magic not implemented
471 %s number > %s non-portable
472 %srealloc() %signored
473 %s in regex m/%s/
474 %s on %s %s
475 socketpair not implemented!
476 Starting Full Screen process with flag=%d, mytype=%d
477 Starting PM process with flag=%d, mytype=%d
478 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
479 SWASHNEW didn't return an HV ref
480 switching effective gid is not implemented
481 switching effective uid is not implemented
482 System V IPC is not implemented on this machine
483 -T and -B not implemented on filehandles
484 Terminating on signal SIG%s(%d)
485 The crypt() function is unimplemented due to excessive paranoia.
486 The crypt() function is not implemented on NetWare
487 The flock() function is not implemented on NetWare
488 The rewinddir() function is not implemented on NetWare
489 The seekdir() function is not implemented on NetWare
490 The telldir() function is not implemented on NetWare
491 Too deeply nested ()-groups in %s
492 Too many args on %s line of "%s"
493 U0 mode on a byte string
494 unable to find VMSPIPE.COM for i/o piping
495 Unknown Unicode option value %d
496 Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
497 Unstable directory path, current directory changed unexpectedly
498 Unterminated compressed integer in unpack
499 Usage: CODE(0x%x)(%s)
500 Usage: %s(%s)
501 Usage: %s::%s(%s)
502 Usage: File::Copy::rmscopy(from,to[,date_flag])
503 Usage: VMS::Filespec::candelete(spec)
504 Usage: VMS::Filespec::fileify(spec)
505 Usage: VMS::Filespec::pathify(spec)
506 Usage: VMS::Filespec::rmsexpand(spec[,defspec])
507 Usage: VMS::Filespec::unixify(spec)
508 Usage: VMS::Filespec::unixpath(spec)
509 Usage: VMS::Filespec::unixrealpath(spec)
510 Usage: VMS::Filespec::vmsify(spec)
511 Usage: VMS::Filespec::vmspath(spec)
512 Usage: VMS::Filespec::vmsrealpath(spec)
513 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
514 utf8 "\x%X" does not map to Unicode
515 Value of logical "%s" too long. Truncating to %i bytes
516 waitpid: process %x is not a child of process %x
517 Wide character
518 Wide character in $/
519 Within []-length '*' not allowed in %s
520 Within []-length '%c' not allowed in %s
521 Wrong syntax (suid) fd script name "%s"
522 'X' outside of string in %s
523 'X' outside of string in unpack