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