This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove ‘Runaway prototype’ warning
[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;
de53a0ea
FC
53my $source_msg_re = '(?<routine>\bDIE\b|$function_re)';
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 /^#/;
78cd53af 218 next if /^ +/;
1b1ee2ef 219
c4ea5f2e 220 my $multiline = 0;
1b1ee2ef 221 # Loop to accumulate the message text all on one line.
6ad282c7 222 if (m/$source_msg_re(?:_nocontext)?\s*\(/) {
78cd53af
DM
223 while (not m/\);$/) {
224 my $nextline = <$codefh>;
225 # Means we fell off the end of the file. Not terribly surprising;
226 # this code tries to merge a lot of things that aren't regular C
227 # code (preprocessor stuff, long comments). That's OK; we don't
228 # need those anyway.
229 last if not defined $nextline;
230 chomp $nextline;
231 $nextline =~ s/^\s+//;
232 $_ =~ s/\\$//;
233 # Note that we only want to do this where *both* are true.
234 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
235 $_ =~ s/"$//;
236 $nextline =~ s/^"//;
237 }
238 $_ .= $nextline;
239 ++$multiline;
fe13d51d 240 }
fe13d51d
JM
241 }
242 # This should happen *after* unwrapping, or we don't reformat the things
243 # in later lines.
78cd53af
DM
244
245 s/$specialformats_re/"%$specialformats{$1}" . (defined $2 ? '' : '"')/ge;
78d0fecf
KW
246
247 # Remove any remaining format modifiers, but not in %%
248 s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
249
fe13d51d 250 # The %"foo" thing needs to happen *before* this regex.
1b1ee2ef
KW
251 # diag($_);
252 # DIE is just return Perl_die
78cd53af
DM
253 my ($name, $category);
254 if (/$source_msg_call_re/) {
255 ($name, $category) = ($+{'text'}, $+{'category'});
256 }
257 elsif (/$bad_version_re/) {
258 ($name, $category) = ($+{'text'}, undef);
259 }
260 else {
261 next;
262 }
263
1b1ee2ef 264 my $severity = {croak => [qw/P F/],
fe13d51d
JM
265 die => [qw/P F/],
266 warn => [qw/W D S/],
1b1ee2ef
KW
267 }->{$+{'routine'}||'die'};
268 my @categories;
49a5993e 269 if (defined $category) {
c0a76f06 270 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
1b1ee2ef 271 }
c4ea5f2e 272 if ($listed_as and $listed_as_line == $. - $multiline) {
c0a76f06 273 $name = $listed_as;
1b1ee2ef 274 } else {
c0a76f06
DM
275 # The form listed in perldiag ignores most sorts of fancy printf
276 # formatting, or makes it more perlish.
4111bb7b 277 $name =~ s/%%/%/g;
c0a76f06
DM
278 $name =~ s/%l[ud]/%d/g;
279 $name =~ s/%\.(\d+|\*)s/\%s/g;
ca53083a 280 $name =~ s/(?:%s){2,}/%s/g;
de78ba8e 281 $name =~ s/(\\")|("\s*[A-Z_]+\s*")/$1 ? '"' : '%s'/egg;
c0a76f06 282 $name =~ s/\\t/\t/g;
366fc280 283 $name =~ s/\\n/\n/g;
c0a76f06
DM
284 $name =~ s/\s+$//;
285 $name =~ s/(\\)\\/$1/g;
286 }
fe13d51d 287
c0a76f06
DM
288 # Extra explanatory info on an already-listed error, doesn't
289 # need it's own listing.
290 next if $name =~ m/^\t/;
fe13d51d 291
c0a76f06
DM
292 # Happens fairly often with PL_no_modify.
293 next if $name eq '%s';
fe13d51d 294
c0a76f06
DM
295 # Special syntax for magic comment, allows ignoring the fact
296 # that it isn't listed. Only use in very special circumstances,
297 # like this script failing to notice that the Perl_croak call is
298 # inside an #if 0 block.
299 next if $name eq 'SKIPME';
fe13d51d 300
366fc280
FC
301 check_message(standardize($name),$codefn);
302 }
303}
304
305sub check_message {
306 my($name,$codefn,$partial) = @_;
307 my $key = $name =~ y/\n/ /r;
308 my $ret;
2c86d456 309
366fc280
FC
310 if (exists $entries{$key}) {
311 $ret = 1;
312 if ( $entries{$key}{seen}++ ) {
c0a76f06
DM
313 # no need to repeat entries we've tested
314 } elsif ($entries{$name}{todo}) {
87a63fff 315 TODO: {
c0a76f06
DM
316 no warnings 'once';
317 local $::TODO = 'in DATA';
318 # There is no listing, but it is in the list of exceptions. TODO FAIL.
abd65dc0 319 fail($name);
c0a76f06
DM
320 diag(
321 " Message '$name'\n from $codefn line $. is not listed in $pod\n".
322 " (but it wasn't documented in 5.10 either, so marking it TODO)."
323 );
87a63fff 324 }
c0a76f06
DM
325 } else {
326 # We found an actual valid entry in perldiag.pod for this error.
b8d24c3d 327 pass($key);
fe13d51d 328 }
c0a76f06 329 # Later, should start checking that the severity is correct, too.
366fc280
FC
330 } elsif ($partial) {
331 # noop
c0a76f06 332 } else {
366fc280
FC
333 my $ok;
334 if ($name =~ /\n/) {
335 $ok = 1;
336 check_message($_,$codefn,1) or $ok = 0, last for split /\n/, $name;
337 }
338 if ($ok) {
339 # noop
340 } elsif ($make_exceptions_list) {
c0a76f06
DM
341 # We're making an updated version of the exception list, to
342 # stick in the __DATA__ section. I honestly can't think of
343 # a situation where this is the right thing to do, but I'm
344 # leaving it here, just in case one of my descendents thinks
345 # it's a good idea.
366fc280 346 print STDERR "$key\n";
c0a76f06
DM
347 } else {
348 # No listing found, and no excuse either.
349 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
350 fail($name);
351 diag(" Message '$name'\n from $codefn line $. is not listed in $pod");
352 }
353 # seen it, so only fail once for this message
354 $entries{$name}{seen}++;
355 }
fe13d51d 356
c0a76f06 357 die if $name =~ /%$/;
366fc280 358 return $ret;
fe13d51d 359}
c0a76f06 360
93f09d7b 361# Lists all missing things as of the inauguration of this script, so we
87a63fff 362# don't have to go from "meh" to perfect all at once.
b0227916
JM
363#
364# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
365# pod/perldiag.pod for your new (warning|error).
fed3ba5d
NC
366
367# Also FIXME this test, as the first entry in TODO *is* covered by the
368# description: Malformed UTF-8 character (%s)
87a63fff 369__DATA__
78d0fecf 370Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
fed3ba5d 371
0dc17498
TM
372%s (%d) does not match %s (%d),
373%s (%d) smaller than %s (%d),
87a63fff 374bad top format reference
87a63fff
JM
375Can't coerce readonly %s to string
376Can't coerce readonly %s to string in %s
377Can't fix broken locale name "%s"
378Can't get short module name from a handle
87a63fff 379Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
87a63fff
JM
380Can't spawn "%s": %s
381Can't %s script `%s' with ARGV[0] being `%s'
382Can't %s "%s": %s
87a63fff 383Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
973a7615 384Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
4a68bf9d 385\%c better written as $%c
87a63fff 386Character(s) in '%c' format wrapped in %s
87a63fff
JM
387Code missing after '/' in pack
388Code missing after '/' in unpack
87a63fff
JM
389Corrupted regexp opcode %d > %d
390'%c' outside of string in pack
ca53083a 391Debug leaking scalars child failed%s with errno %d: %s
4a68bf9d 392Don't know how to handle magic of type \%o
87a63fff 393-Dp not implemented on this platform
87a63fff 394Error reading "%s": %s
87a63fff
JM
395Filehandle opened only for %sput
396Filehandle %s opened only for %sput
397Filehandle STD%s reopened as %s only for input
398YOU 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!
87a63fff
JM
399Free to wrong pool %p not %p
400get %s %p %p %p
401glob failed (can't start child: %s)
402glob failed (child exited with status %d%s)
403Goto undefined subroutine
404Goto undefined subroutine &%s
87a63fff 405Illegal character %sin prototype for %s : %s
87a63fff 406Integer overflow in version %d
4111bb7b 407internal %<num>p might conflict with future printf extensions
78d0fecf 408invalid control request: '\%o'
87a63fff
JM
409Invalid range "%c-%c" in transliteration operator
410Invalid separator character %c%c%c in PerlIO layer specification %s
411Invalid TOKEN object ignored
412Invalid type '%c' in pack
413Invalid type '%c' in %s
414Invalid type '%c' in unpack
415Invalid type ',' in %s
87a63fff
JM
416'j' not supported on this platform
417'J' not supported on this platform
87a63fff 418Malformed UTF-8 character (fatal)
87a63fff
JM
419Missing (suid) fd script name
420More than one argument to open
421More than one argument to open(,':%s')
de42a5a9
KW
422mprotect for %p %u failed with %d
423mprotect RW for %p %u failed with %d
87a63fff 424Not an XSUB reference
87a63fff 425Operator or semicolon missing before %c%s
87a63fff 426Perl %s required--this is only %s, stopped
78d0fecf 427ptr wrong %p != %p fl=%x nl=%p e=%p for %d
87a63fff 428Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
87a63fff 429Reversed %c= operator
78d0fecf 430%s(%f) failed
87a63fff
JM
431%sCompilation failed in regexp
432%sCompilation failed in require
433set %s %p %p %p
434%s free() ignored (RMAGIC, PERL_CORE)
435%s has too many errors.
436SIG%s handler "%s" not defined.
87a63fff
JM
437%s in %s
438Size magic not implemented
87a63fff 439%s number > %s non-portable
ca53083a 440%s object version %s does not match %s %s
87a63fff 441%srealloc() %signored
ca53083a
FC
442%s has too many errors.
443%s on %s %s
444%s on %s %s %s
87a63fff
JM
445Starting Full Screen process with flag=%d, mytype=%d
446Starting PM process with flag=%d, mytype=%d
87a63fff
JM
447SWASHNEW didn't return an HV ref
448-T and -B not implemented on filehandles
449The flock() function is not implemented on NetWare
450The rewinddir() function is not implemented on NetWare
451The seekdir() function is not implemented on NetWare
87a63fff
JM
452The telldir() function is not implemented on NetWare
453Too deeply nested ()-groups in %s
87a63fff
JM
454Too many args on %s line of "%s"
455U0 mode on a byte string
87a63fff 456Undefined top format called
87a63fff 457Unstable directory path, current directory changed unexpectedly
87a63fff
JM
458Unterminated compressed integer in unpack
459Usage: CODE(0x%x)(%s)
460Usage: %s(%s)
461Usage: %s::%s(%s)
462Usage: VMS::Filespec::unixrealpath(spec)
463Usage: VMS::Filespec::vmsrealpath(spec)
464Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
78d0fecf 465utf8 "\x%X" does not map to Unicode
87a63fff
JM
466Value of logical "%s" too long. Truncating to %i bytes
467value of node is %d in Offset macro
87a63fff 468Variable "%c%s" is not imported
87a63fff
JM
469Wide character
470Wide character in $/
471Wide character in print
87a63fff
JM
472Within []-length '%c' not allowed in %s
473Wrong syntax (suid) fd script name "%s"
474'X' outside of string in unpack