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
CommitLineData
fe13d51d
JM
1#!/usr/bin/perl
2use warnings;
3use strict;
f7b649f0 4
ef1ab675 5chdir 't';
f7b649f0
NC
6require './test.pl';
7
8plan('no_plan');
9
fe13d51d
JM
10$|=1;
11
1eb3f3ad
JM
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.
f7223e8e 18my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
87a63fff 19
45f1c7ba 20chdir '..' or die "Can't chdir ..: $!";
47f6eaac 21BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
45f1c7ba 22
1b1ee2ef
KW
23my @functions;
24
25open 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.
28while (<$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
50close $func_fh;
51
52my $function_re = join '|', @functions;
47b03dba 53my $source_msg_re = "(?<routine>\\bDIE\\b|$function_re)";
de53a0ea 54my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
78cd53af
DM
55my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
56 \(aTHX_ \s*
57 (?:packWARN\d*\((?<category>.*?)\),)? \s*
58 $text_re /x;
59my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
fe13d51d
JM
60
61my %entries;
1b1ee2ef
KW
62
63# Get the ignores that are compiled into this file
87a63fff
JM
64while (<DATA>) {
65 chomp;
66 $entries{$_}{todo}=1;
67}
68
808910a9 69my $pod = "pod/perldiag.pod";
fe13d51d 70my $cur_entry;
808910a9
KW
71open my $diagfh, "<", $pod
72 or die "Can't open $pod: $!";
1b1ee2ef 73
aef36ea3 74my $category_re = qr/ [a-z0-9_]+?/; # Note: requires an initial space
4cf67031
KW
75my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
76 # be of the form 'S|P|W'
fe13d51d
JM
77while (<$diagfh>) {
78 if (m/^=item (.*)/) {
79 $cur_entry = $1;
4cf67031 80
9c3e8e01 81 if (exists $entries{$cur_entry}) {
b61b433c
KW
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 }
9c3e8e01 86 }
4cf67031
KW
87 # Make sure to init this here, so an actual entry in perldiag
88 # overwrites one in DATA.
87a63fff 89 $entries{$cur_entry}{todo} = 0;
4cf67031
KW
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 }
fe13d51d
JM
111 }
112}
113
4cf67031
KW
114foreach 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
78cd53af
DM
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
138my %specialformats = (IVdf => 'd',
139 UVuf => 'd',
140 UVof => 'o',
141 UVxf => 'x',
142 UVXf => 'X',
143 NVef => 'f',
144 NVff => 'f',
145 NVgf => 'f',
b8fa5213 146 HEKf256=>'s',
fa871b03 147 HEKf => 's',
f0eec8b8
FC
148 SVf256=>'s',
149 SVf32=> 's',
78cd53af
DM
150 SVf => 's');
151my $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
f0eec8b8
FC
157my $specialformats =
158 join '|', sort { length $b cmp length $a } keys %specialformats;
78cd53af
DM
159my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
160
1b1ee2ef 161# Recursively descend looking for source files.
abd65dc0 162my @todo = sort <*>;
fe13d51d
JM
163while (@todo) {
164 my $todo = shift @todo;
45f1c7ba 165 next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
fe13d51d 166 # opmini.c is just a copy of op.c, so there's no need to check again.
45f1c7ba 167 next if $todo eq 'opmini.c';
fe13d51d 168 if (-d $todo) {
abd65dc0 169 unshift @todo, sort glob "$todo/*";
87a63fff 170 } elsif ($todo =~ m/\.[ch]$/) {
fe13d51d
JM
171 check_file($todo);
172 }
173}
174
abd65dc0
DG
175# Standardize messages with variants into the form that appears
176# in perldiag.pod -- useful for things without a diag_listed_as annotation
177sub 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
fe13d51d
JM
193sub check_file {
194 my ($codefn) = @_;
195
abd65dc0 196 print "# Checking $codefn\n";
fe13d51d 197
38ec24b4 198 open my $codefh, "<", $codefn
fe13d51d
JM
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.
78cd53af
DM
209 if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
210 $sub = $_;
fe13d51d
JM
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 /^#/;
1b1ee2ef 218
c4ea5f2e 219 my $multiline = 0;
1b1ee2ef 220 # Loop to accumulate the message text all on one line.
6ad282c7 221 if (m/$source_msg_re(?:_nocontext)?\s*\(/) {
78cd53af
DM
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;
fe13d51d 239 }
fe13d51d
JM
240 }
241 # This should happen *after* unwrapping, or we don't reformat the things
242 # in later lines.
78cd53af
DM
243
244 s/$specialformats_re/"%$specialformats{$1}" . (defined $2 ? '' : '"')/ge;
78d0fecf
KW
245
246 # Remove any remaining format modifiers, but not in %%
247 s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
248
fe13d51d 249 # The %"foo" thing needs to happen *before* this regex.
1b1ee2ef
KW
250 # diag($_);
251 # DIE is just return Perl_die
78cd53af
DM
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
1b1ee2ef 263 my $severity = {croak => [qw/P F/],
fe13d51d
JM
264 die => [qw/P F/],
265 warn => [qw/W D S/],
1b1ee2ef
KW
266 }->{$+{'routine'}||'die'};
267 my @categories;
49a5993e 268 if (defined $category) {
c0a76f06 269 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
1b1ee2ef 270 }
c4ea5f2e 271 if ($listed_as and $listed_as_line == $. - $multiline) {
c0a76f06 272 $name = $listed_as;
1b1ee2ef 273 } else {
c0a76f06
DM
274 # The form listed in perldiag ignores most sorts of fancy printf
275 # formatting, or makes it more perlish.
4111bb7b 276 $name =~ s/%%/%/g;
c0a76f06
DM
277 $name =~ s/%l[ud]/%d/g;
278 $name =~ s/%\.(\d+|\*)s/\%s/g;
ca53083a 279 $name =~ s/(?:%s){2,}/%s/g;
de78ba8e 280 $name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
c0a76f06 281 $name =~ s/\\t/\t/g;
366fc280 282 $name =~ s/\\n/\n/g;
c0a76f06
DM
283 $name =~ s/\s+$//;
284 $name =~ s/(\\)\\/$1/g;
285 }
fe13d51d 286
c0a76f06
DM
287 # Extra explanatory info on an already-listed error, doesn't
288 # need it's own listing.
289 next if $name =~ m/^\t/;
fe13d51d 290
c0a76f06
DM
291 # Happens fairly often with PL_no_modify.
292 next if $name eq '%s';
fe13d51d 293
c0a76f06
DM
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';
fe13d51d 299
366fc280
FC
300 check_message(standardize($name),$codefn);
301 }
302}
303
304sub check_message {
305 my($name,$codefn,$partial) = @_;
306 my $key = $name =~ y/\n/ /r;
307 my $ret;
2c86d456 308
366fc280
FC
309 if (exists $entries{$key}) {
310 $ret = 1;
311 if ( $entries{$key}{seen}++ ) {
c0a76f06
DM
312 # no need to repeat entries we've tested
313 } elsif ($entries{$name}{todo}) {
87a63fff 314 TODO: {
c0a76f06
DM
315 no warnings 'once';
316 local $::TODO = 'in DATA';
317 # There is no listing, but it is in the list of exceptions. TODO FAIL.
abd65dc0 318 fail($name);
c0a76f06
DM
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 );
87a63fff 323 }
c0a76f06
DM
324 } else {
325 # We found an actual valid entry in perldiag.pod for this error.
b8d24c3d 326 pass($key);
fe13d51d 327 }
c0a76f06 328 # Later, should start checking that the severity is correct, too.
366fc280
FC
329 } elsif ($partial) {
330 # noop
c0a76f06 331 } else {
366fc280
FC
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) {
c0a76f06
DM
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.
366fc280 345 print STDERR "$key\n";
c0a76f06
DM
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 }
fe13d51d 355
c0a76f06 356 die if $name =~ /%$/;
366fc280 357 return $ret;
fe13d51d 358}
c0a76f06 359
93f09d7b 360# Lists all missing things as of the inauguration of this script, so we
87a63fff 361# don't have to go from "meh" to perfect all at once.
b0227916
JM
362#
363# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
364# pod/perldiag.pod for your new (warning|error).
fed3ba5d
NC
365
366# Also FIXME this test, as the first entry in TODO *is* covered by the
367# description: Malformed UTF-8 character (%s)
87a63fff 368__DATA__
78d0fecf 369Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
fed3ba5d 370
5f2c6f7e 371'%c' allowed only after types %s in %s
87a63fff 372bad top format reference
5f2c6f7e
FC
373Cannot apply "%s" in non-PerlIO perl
374Can't %s big-endian %ss on this
375Can't call mro_isa_changed_in() on anonymous symbol table
376Can't call mro_method_changed_in() on anonymous symbol table
87a63fff
JM
377Can't coerce readonly %s to string
378Can't coerce readonly %s to string in %s
5f2c6f7e 379Can't find string terminator %c%s%c anywhere before EOF
87a63fff
JM
380Can't fix broken locale name "%s"
381Can't get short module name from a handle
87a63fff 382Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
5f2c6f7e
FC
383Can't pipe "%s": %s
384Can't spawn: %s
87a63fff
JM
385Can't spawn "%s": %s
386Can't %s script `%s' with ARGV[0] being `%s'
387Can't %s "%s": %s
87a63fff 388Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
973a7615 389Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
4a68bf9d 390\%c better written as $%c
87a63fff 391Character(s) in '%c' format wrapped in %s
5f2c6f7e
FC
392chown not implemented!
393clear %s
87a63fff
JM
394Code missing after '/' in pack
395Code missing after '/' in unpack
87a63fff
JM
396Corrupted regexp opcode %d > %d
397'%c' outside of string in pack
ca53083a 398Debug leaking scalars child failed%s with errno %d: %s
5f2c6f7e
FC
399'/' does not take a repeat count in %s
400Don't know how to get file name
4a68bf9d 401Don't know how to handle magic of type \%o
87a63fff 402-Dp not implemented on this platform
87a63fff 403Error reading "%s": %s
5f2c6f7e
FC
404execl not implemented!
405EVAL without pos change exceeded limit in regex
87a63fff
JM
406Filehandle opened only for %sput
407Filehandle %s opened only for %sput
408Filehandle STD%s reopened as %s only for input
5f2c6f7e 409filter_del can only delete in reverse order (currently)
87a63fff 410YOU 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!
5f2c6f7e
FC
411fork() not implemented!
412free %s
87a63fff
JM
413Free to wrong pool %p not %p
414get %s %p %p %p
5f2c6f7e
FC
415gethostent not implemented!
416getpwnam returned invalid UIC %o for user "%s"
87a63fff
JM
417glob failed (can't start child: %s)
418glob failed (child exited with status %d%s)
419Goto undefined subroutine
420Goto undefined subroutine &%s
5f2c6f7e
FC
421Got signal %d
422()-group starts with a count in %s
423Illegal binary digit '%c' ignored
87a63fff 424Illegal character %sin prototype for %s : %s
5f2c6f7e
FC
425Illegal hexadecimal digit '%c' ignored
426Illegal octal digit '%c' ignored
427Infinite recursion in regex
4111bb7b 428internal %<num>p might conflict with future printf extensions
5f2c6f7e 429Invalid argument to sv_cat_decode
87a63fff
JM
430Invalid range "%c-%c" in transliteration operator
431Invalid separator character %c%c%c in PerlIO layer specification %s
432Invalid TOKEN object ignored
433Invalid type '%c' in pack
434Invalid type '%c' in %s
435Invalid type '%c' in unpack
436Invalid type ',' in %s
5f2c6f7e 437ioctlsocket not implemented!
87a63fff
JM
438'j' not supported on this platform
439'J' not supported on this platform
5f2c6f7e
FC
440killpg not implemented!
441length() used on %s (did you mean "scalar(%s)"?)
442length() used on %hash (did you mean "scalar(keys %hash)"?)
443length() used on @array (did you mean "scalar(@array)"?)
444List form of pipe open not implemented
445Malformed integer in [] in %s
87a63fff 446Malformed UTF-8 character (fatal)
87a63fff
JM
447Missing (suid) fd script name
448More than one argument to open
449More than one argument to open(,':%s')
de42a5a9
KW
450mprotect for %p %u failed with %d
451mprotect RW for %p %u failed with %d
5f2c6f7e
FC
452No %s allowed while running setgid
453No %s allowed with (suid) fdscript
47b03dba 454No such class field "%s"
87a63fff 455Not an XSUB reference
87a63fff 456Operator or semicolon missing before %c%s
5f2c6f7e 457Pattern subroutine nesting without pos change exceeded limit in regex
87a63fff 458Perl %s required--this is only %s, stopped
78d0fecf 459ptr wrong %p != %p fl=%x nl=%p e=%p for %d
87a63fff 460Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
5f2c6f7e 461Repeated format line will never terminate (~~ and @#)
87a63fff 462Reversed %c= operator
78d0fecf 463%s(%f) failed
87a63fff
JM
464%sCompilation failed in require
465set %s %p %p %p
466%s free() ignored (RMAGIC, PERL_CORE)
467%s has too many errors.
468SIG%s handler "%s" not defined.
87a63fff
JM
469%s in %s
470Size magic not implemented
87a63fff 471%s number > %s non-portable
87a63fff 472%srealloc() %signored
5f2c6f7e 473%s in regex m/%s/
ca53083a 474%s on %s %s
5f2c6f7e 475socketpair not implemented!
87a63fff
JM
476Starting Full Screen process with flag=%d, mytype=%d
477Starting PM process with flag=%d, mytype=%d
5f2c6f7e 478sv_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
87a63fff 479SWASHNEW didn't return an HV ref
5f2c6f7e
FC
480switching effective gid is not implemented
481switching effective uid is not implemented
482System V IPC is not implemented on this machine
87a63fff 483-T and -B not implemented on filehandles
5f2c6f7e
FC
484Terminating on signal SIG%s(%d)
485The crypt() function is unimplemented due to excessive paranoia.
486The crypt() function is not implemented on NetWare
87a63fff
JM
487The flock() function is not implemented on NetWare
488The rewinddir() function is not implemented on NetWare
489The seekdir() function is not implemented on NetWare
87a63fff
JM
490The telldir() function is not implemented on NetWare
491Too deeply nested ()-groups in %s
87a63fff
JM
492Too many args on %s line of "%s"
493U0 mode on a byte string
5f2c6f7e
FC
494unable to find VMSPIPE.COM for i/o piping
495Unknown Unicode option value %d
496Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
87a63fff 497Unstable directory path, current directory changed unexpectedly
87a63fff
JM
498Unterminated compressed integer in unpack
499Usage: CODE(0x%x)(%s)
500Usage: %s(%s)
501Usage: %s::%s(%s)
5f2c6f7e
FC
502Usage: File::Copy::rmscopy(from,to[,date_flag])
503Usage: VMS::Filespec::candelete(spec)
504Usage: VMS::Filespec::fileify(spec)
505Usage: VMS::Filespec::pathify(spec)
506Usage: VMS::Filespec::rmsexpand(spec[,defspec])
507Usage: VMS::Filespec::unixify(spec)
508Usage: VMS::Filespec::unixpath(spec)
87a63fff 509Usage: VMS::Filespec::unixrealpath(spec)
5f2c6f7e
FC
510Usage: VMS::Filespec::vmsify(spec)
511Usage: VMS::Filespec::vmspath(spec)
87a63fff
JM
512Usage: VMS::Filespec::vmsrealpath(spec)
513Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
78d0fecf 514utf8 "\x%X" does not map to Unicode
87a63fff 515Value of logical "%s" too long. Truncating to %i bytes
5f2c6f7e 516waitpid: process %x is not a child of process %x
87a63fff
JM
517Wide character
518Wide character in $/
5f2c6f7e 519Within []-length '*' not allowed in %s
87a63fff
JM
520Within []-length '%c' not allowed in %s
521Wrong syntax (suid) fd script name "%s"
5f2c6f7e 522'X' outside of string in %s
87a63fff 523'X' outside of string in unpack