This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add diag_listed_as for lstat error msg
[perl5.git] / t / porting / diag.t
CommitLineData
fe13d51d
JM
1#!/usr/bin/perl
2use warnings;
3use strict;
f7b649f0
NC
4
5require './test.pl';
6
7plan('no_plan');
8
fe13d51d
JM
9$|=1;
10
1eb3f3ad
JM
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.
f7223e8e 17my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
87a63fff 18
45f1c7ba 19chdir '..' or die "Can't chdir ..: $!";
47f6eaac 20BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
45f1c7ba 21
1b1ee2ef
KW
22my @functions;
23
24open 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.
27while (<$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
49close $func_fh;
50
51my $function_re = join '|', @functions;
52my $source_msg_re = qr/(?<routine>\bDIE\b|$function_re)/;
78cd53af
DM
53my $text_re = qr/"(?<text>(?:\\"|[^"])*?)"/;
54my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
55 \(aTHX_ \s*
56 (?:packWARN\d*\((?<category>.*?)\),)? \s*
57 $text_re /x;
58my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
fe13d51d
JM
59
60my %entries;
1b1ee2ef
KW
61
62# Get the ignores that are compiled into this file
87a63fff
JM
63while (<DATA>) {
64 chomp;
65 $entries{$_}{todo}=1;
66}
67
808910a9 68my $pod = "pod/perldiag.pod";
fe13d51d 69my $cur_entry;
808910a9
KW
70open my $diagfh, "<", $pod
71 or die "Can't open $pod: $!";
1b1ee2ef 72
aef36ea3 73my $category_re = qr/ [a-z0-9_]+?/; # Note: requires an initial space
4cf67031
KW
74my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
75 # be of the form 'S|P|W'
fe13d51d
JM
76while (<$diagfh>) {
77 if (m/^=item (.*)/) {
78 $cur_entry = $1;
4cf67031 79
9c3e8e01 80 if (exists $entries{$cur_entry}) {
b61b433c
KW
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 }
9c3e8e01 85 }
4cf67031
KW
86 # Make sure to init this here, so an actual entry in perldiag
87 # overwrites one in DATA.
87a63fff 88 $entries{$cur_entry}{todo} = 0;
4cf67031
KW
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 }
fe13d51d
JM
110 }
111}
112
4cf67031
KW
113foreach 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
78cd53af
DM
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
137my %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 SVf => 's');
146my $format_modifiers = qr/ [#0\ +-]* # optional flags
147 (?: [1-9][0-9]* | \* )? # optional field width
148 (?: \. \d* )? # optional precision
149 (?: h|l )? # optional length modifier
150 /x;
151
152my $specialformats = join '|', sort keys %specialformats;
153my $specialformats_re = qr/%$format_modifiers"\s*($specialformats)(\s*")?/;
154
1b1ee2ef 155# Recursively descend looking for source files.
abd65dc0 156my @todo = sort <*>;
fe13d51d
JM
157while (@todo) {
158 my $todo = shift @todo;
45f1c7ba 159 next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
fe13d51d 160 # opmini.c is just a copy of op.c, so there's no need to check again.
45f1c7ba 161 next if $todo eq 'opmini.c';
fe13d51d 162 if (-d $todo) {
abd65dc0 163 unshift @todo, sort glob "$todo/*";
87a63fff 164 } elsif ($todo =~ m/\.[ch]$/) {
fe13d51d
JM
165 check_file($todo);
166 }
167}
168
abd65dc0
DG
169# Standardize messages with variants into the form that appears
170# in perldiag.pod -- useful for things without a diag_listed_as annotation
171sub standardize {
172 my ($name) = @_;
173
174 if ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
175 $name = "$1 (\%s)";
176 }
177 elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
178 $name = "$1 (\%s)";
179 }
180 elsif ($name =~ m/^panic: /) {
181 $name = "panic: \%s";
182 }
183
184 return $name;
185}
186
fe13d51d
JM
187sub check_file {
188 my ($codefn) = @_;
189
abd65dc0 190 print "# Checking $codefn\n";
fe13d51d 191
38ec24b4 192 open my $codefh, "<", $codefn
fe13d51d
JM
193 or die "Can't open $codefn: $!";
194
195 my $listed_as;
196 my $listed_as_line;
197 my $sub = 'top of file';
198 while (<$codefh>) {
199 chomp;
200 # Getting too much here isn't a problem; we only use this to skip
201 # errors inside of XS modules, which should get documented in the
202 # docs for the module.
78cd53af
DM
203 if (m<^[^#\s]> and $_ !~ m/^[{}]*$/) {
204 $sub = $_;
fe13d51d
JM
205 }
206 next if $sub =~ m/^XS/;
207 if (m</\* diag_listed_as: (.*) \*/>) {
208 $listed_as = $1;
209 $listed_as_line = $.+1;
210 }
211 next if /^#/;
78cd53af 212 next if /^ +/;
1b1ee2ef 213
c4ea5f2e 214 my $multiline = 0;
1b1ee2ef 215 # Loop to accumulate the message text all on one line.
78cd53af
DM
216 if (m/$source_msg_re/) {
217 while (not m/\);$/) {
218 my $nextline = <$codefh>;
219 # Means we fell off the end of the file. Not terribly surprising;
220 # this code tries to merge a lot of things that aren't regular C
221 # code (preprocessor stuff, long comments). That's OK; we don't
222 # need those anyway.
223 last if not defined $nextline;
224 chomp $nextline;
225 $nextline =~ s/^\s+//;
226 $_ =~ s/\\$//;
227 # Note that we only want to do this where *both* are true.
228 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
229 $_ =~ s/"$//;
230 $nextline =~ s/^"//;
231 }
232 $_ .= $nextline;
233 ++$multiline;
fe13d51d 234 }
fe13d51d
JM
235 }
236 # This should happen *after* unwrapping, or we don't reformat the things
237 # in later lines.
78cd53af
DM
238
239 s/$specialformats_re/"%$specialformats{$1}" . (defined $2 ? '' : '"')/ge;
78d0fecf
KW
240
241 # Remove any remaining format modifiers, but not in %%
242 s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
243
fe13d51d 244 # The %"foo" thing needs to happen *before* this regex.
1b1ee2ef
KW
245 # diag($_);
246 # DIE is just return Perl_die
78cd53af
DM
247 my ($name, $category);
248 if (/$source_msg_call_re/) {
249 ($name, $category) = ($+{'text'}, $+{'category'});
250 }
251 elsif (/$bad_version_re/) {
252 ($name, $category) = ($+{'text'}, undef);
253 }
254 else {
255 next;
256 }
257
1b1ee2ef 258 my $severity = {croak => [qw/P F/],
fe13d51d
JM
259 die => [qw/P F/],
260 warn => [qw/W D S/],
1b1ee2ef
KW
261 }->{$+{'routine'}||'die'};
262 my @categories;
49a5993e 263 if (defined $category) {
c0a76f06 264 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
1b1ee2ef 265 }
c4ea5f2e 266 if ($listed_as and $listed_as_line == $. - $multiline) {
c0a76f06 267 $name = $listed_as;
1b1ee2ef 268 } else {
c0a76f06
DM
269 # The form listed in perldiag ignores most sorts of fancy printf
270 # formatting, or makes it more perlish.
271 $name =~ s/%%/\\%/g;
272 $name =~ s/%l[ud]/%d/g;
273 $name =~ s/%\.(\d+|\*)s/\%s/g;
274 $name =~ s/\\"/"/g;
275 $name =~ s/\\t/\t/g;
276 $name =~ s/\\n/ /g;
277 $name =~ s/\s+$//;
278 $name =~ s/(\\)\\/$1/g;
279 }
fe13d51d 280
c0a76f06
DM
281 # Extra explanatory info on an already-listed error, doesn't
282 # need it's own listing.
283 next if $name =~ m/^\t/;
fe13d51d 284
c0a76f06
DM
285 # Happens fairly often with PL_no_modify.
286 next if $name eq '%s';
fe13d51d 287
c0a76f06
DM
288 # Special syntax for magic comment, allows ignoring the fact
289 # that it isn't listed. Only use in very special circumstances,
290 # like this script failing to notice that the Perl_croak call is
291 # inside an #if 0 block.
292 next if $name eq 'SKIPME';
fe13d51d 293
c0a76f06 294 $name = standardize($name);
2c86d456 295
c0a76f06
DM
296 if (exists $entries{$name}) {
297 if ( $entries{$name}{seen}++ ) {
298 # no need to repeat entries we've tested
299 } elsif ($entries{$name}{todo}) {
87a63fff 300 TODO: {
c0a76f06
DM
301 no warnings 'once';
302 local $::TODO = 'in DATA';
303 # There is no listing, but it is in the list of exceptions. TODO FAIL.
abd65dc0 304 fail($name);
c0a76f06
DM
305 diag(
306 " Message '$name'\n from $codefn line $. is not listed in $pod\n".
307 " (but it wasn't documented in 5.10 either, so marking it TODO)."
308 );
87a63fff 309 }
c0a76f06
DM
310 } else {
311 # We found an actual valid entry in perldiag.pod for this error.
312 pass($name);
fe13d51d 313 }
c0a76f06
DM
314 # Later, should start checking that the severity is correct, too.
315 } else {
316 if ($make_exceptions_list) {
317 # We're making an updated version of the exception list, to
318 # stick in the __DATA__ section. I honestly can't think of
319 # a situation where this is the right thing to do, but I'm
320 # leaving it here, just in case one of my descendents thinks
321 # it's a good idea.
322 print STDERR "$name\n";
323 } else {
324 # No listing found, and no excuse either.
325 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
326 fail($name);
327 diag(" Message '$name'\n from $codefn line $. is not listed in $pod");
328 }
329 # seen it, so only fail once for this message
330 $entries{$name}{seen}++;
331 }
fe13d51d 332
c0a76f06 333 die if $name =~ /%$/;
fe13d51d
JM
334 }
335}
c0a76f06 336
93f09d7b 337# Lists all missing things as of the inauguration of this script, so we
87a63fff 338# don't have to go from "meh" to perfect all at once.
b0227916
JM
339#
340# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
341# pod/perldiag.pod for your new (warning|error).
fed3ba5d
NC
342
343# Also FIXME this test, as the first entry in TODO *is* covered by the
344# description: Malformed UTF-8 character (%s)
87a63fff 345__DATA__
78d0fecf 346Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
fed3ba5d 347
0dc17498
TM
348%s (%d) does not match %s (%d),
349%s (%d) smaller than %s (%d),
87a63fff
JM
350Argument "%s" isn't numeric
351Argument "%s" isn't numeric in %s
87a63fff 352Attempt to clear deleted array
87a63fff
JM
353Attempt to free non-existent shared string '%s'%s
354Attempt to free temp prematurely: SV 0x%x
355Attempt to free unreferenced scalar: SV 0x%x
356Attempt to reload %s aborted. Compilation failed in require
357av_reify called on tied array
358Bad name after %s%s
d5713896 359Bad symbol for %s
87a63fff
JM
360bad top format reference
361Bizarre copy of %s
362Bizarre SvTYPE [%d]
363Cannot copy to %s
364Can't call method "%s" %s
365Can't coerce readonly %s to string
366Can't coerce readonly %s to string in %s
367Can't fix broken locale name "%s"
368Can't get short module name from a handle
369Can't goto subroutine from an eval-block
370Can't goto subroutine from an eval-string
371Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
372Can't modify non-existent substring
373Can't open
374Can't open perl script "%s": %s
375Can't open %s
376Can't reset \%ENV on this system
377Can't return array to lvalue scalar context
378Can't return a %s from lvalue subroutine
379Can't return hash to lvalue scalar context
380Can't spawn "%s": %s
381Can't %s script `%s' with ARGV[0] being `%s'
382Can't %s "%s": %s
383Can't %s %s%s%s
384Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
385Can't take %s of %f
386Can't use '%c' after -mname
973a7615 387Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
87a63fff 388Can't use when() outside a topicalizer
4a68bf9d 389\%c better written as $%c
87a63fff
JM
390Character(s) in '%c' format wrapped in %s
391$%c is no longer supported
392Cloning substitution context is unimplemented
393Code missing after '/' in pack
394Code missing after '/' in unpack
87a63fff
JM
395Corrupted regexp opcode %d > %d
396'%c' outside of string in pack
397Debug leaking scalars child failed%s%s with errno %d: %s
398Deep recursion on anonymous subroutine
399defined(\%hash) is deprecated
4a68bf9d 400Don't know how to handle magic of type \%o
87a63fff
JM
401-Dp not implemented on this platform
402entering effective gid failed
403entering effective uid failed
404Error reading "%s": %s
405Exiting %s via %s
406Filehandle opened only for %sput
407Filehandle %s opened only for %sput
408Filehandle STD%s reopened as %s only for input
409YOU 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!
410Format STDOUT redefined
411Free to wrong pool %p not %p
412get %s %p %p %p
413glob failed (can't start child: %s)
414glob failed (child exited with status %d%s)
415Goto undefined subroutine
416Goto undefined subroutine &%s
417Hash \%%s missing the \% in argument %d of %s()
87a63fff 418Illegal character %sin prototype for %s : %s
1b1ee2ef 419Integer overflow in binary number
87a63fff 420Integer overflow in decimal number
1b1ee2ef
KW
421Integer overflow in hexadecimal number
422Integer overflow in octal number
87a63fff
JM
423Integer overflow in version %d
424internal \%<num>p might conflict with future printf extensions
78d0fecf 425invalid control request: '\%o'
87a63fff
JM
426Invalid module name %s with -%c option: contains single ':'
427invalid option -D%c, use -D'' to see choices
428Invalid range "%c-%c" in transliteration operator
429Invalid separator character %c%c%c in PerlIO layer specification %s
430Invalid TOKEN object ignored
431Invalid type '%c' in pack
432Invalid type '%c' in %s
433Invalid type '%c' in unpack
434Invalid type ',' in %s
87a63fff
JM
435'j' not supported on this platform
436'J' not supported on this platform
87a63fff
JM
437leaving effective gid failed
438leaving effective uid failed
439List form of piped open not implemented
440Lost precision when decrementing %f by 1
441Lost precision when incrementing %f by 1
442%lx
87a63fff
JM
443Malformed UTF-8 character (fatal)
444'\%' may not be used in pack
445Missing (suid) fd script name
446More than one argument to open
447More than one argument to open(,':%s')
de42a5a9
KW
448mprotect for %p %u failed with %d
449mprotect RW for %p %u failed with %d
87a63fff
JM
450No code specified for -%c
451No directory specified for -I
452No such class field "%s"
453Not an XSUB reference
454Not %s reference
87a63fff 455Operator or semicolon missing before %c%s
87a63fff
JM
456Perl %s required (did you mean %s?)--this is only %s, stopped
457Perl %s required--this is only %s, stopped
458Perls since %s too modern--this is %s, stopped
78d0fecf 459ptr wrong %p != %p fl=%x nl=%p e=%p for %d
87a63fff
JM
460Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
461Recursive call to Perl_load_module in PerlIO_find_layer
87a63fff
JM
462Reversed %c= operator
463Runaway prototype
1b1ee2ef 464%s(%.0
78d0fecf
KW
465%s(%f) failed
466%s(%f) too large
467%s(%f) too small
87a63fff
JM
468Scalar value %s better written as $%s
469%sCompilation failed in regexp
470%sCompilation failed in require
471set %s %p %p %p
472%s free() ignored (RMAGIC, PERL_CORE)
473%s has too many errors.
474SIG%s handler "%s" not defined.
475%s: illegal mapping '%s'
476%s in %s
477Size magic not implemented
478%s limit (%d) exceeded
479%s method "%s" overloading "%s" in package "%s"
480%s number > %s non-portable
481%s object version %s does not match %s%s%s%s %s
482%srealloc() %signored
483%s returned from lvalue subroutine in scalar context
484%s%s has too many errors.
485%s%s on %s %s
486%s%s on %s %s %s
487Starting Full Screen process with flag=%d, mytype=%d
488Starting PM process with flag=%d, mytype=%d
87a63fff
JM
489SWASHNEW didn't return an HV ref
490-T and -B not implemented on filehandles
491The flock() function is not implemented on NetWare
492The rewinddir() function is not implemented on NetWare
493The seekdir() function is not implemented on NetWare
87a63fff
JM
494The telldir() function is not implemented on NetWare
495Too deeply nested ()-groups in %s
496Too late to run CHECK block
497Too late to run INIT block
498Too many args on %s line of "%s"
499U0 mode on a byte string
500Unbalanced string table refcount: (%d) for "%s"
501Undefined top format called
502Unexpected constant lvalue entersub entry via type/targ %d:%d
78d0fecf 503Unicode non-character 0x%X
87a63fff 504Unknown PerlIO layer "scalar"
87a63fff 505Unstable directory path, current directory changed unexpectedly
ee6ba15d
EB
506Unsupported script encoding UTF-16BE
507Unsupported script encoding UTF-16LE
508Unsupported script encoding UTF-32BE
509Unsupported script encoding UTF-32LE
87a63fff
JM
510Unterminated compressed integer in unpack
511Usage: CODE(0x%x)(%s)
512Usage: %s(%s)
513Usage: %s::%s(%s)
514Usage: VMS::Filespec::unixrealpath(spec)
515Usage: VMS::Filespec::vmsrealpath(spec)
516Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
78d0fecf 517utf8 "\x%X" does not map to Unicode
87a63fff
JM
518Value of logical "%s" too long. Truncating to %i bytes
519value of node is %d in Offset macro
520Value of %s%s can be "0"; test with defined()
521Variable "%c%s" is not imported
522vector argument not supported with alpha versions
523Wide character
524Wide character in $/
525Wide character in print
87a63fff
JM
526Within []-length '%c' not allowed in %s
527Wrong syntax (suid) fd script name "%s"
528'X' outside of string in unpack