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