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