This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
diag.t: Ignore formatting precisions in messages
[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"
78d0fecf
KW
219 # Convert from internal formats to ones that the readers will be familiar
220 # with, while removing any format modifiers, such as precision, the
221 # presence of which would just confuse the pod's explanation
fe13d51d
JM
222 my %specialformats = (IVdf => 'd',
223 UVuf => 'd',
224 UVof => 'o',
225 UVxf => 'x',
226 UVXf => 'X',
227 NVef => 'f',
228 NVff => 'f',
229 NVgf => 'f',
230 SVf => 's');
78d0fecf
KW
231 my $format_modifiers = qr/ [#0\ +-]* # optional flags
232 (?: [1-9][0-9]* | \* )? # optional field width
233 (?: \. \d* )? /x; # optional precision
fe13d51d 234 for my $from (keys %specialformats) {
78d0fecf
KW
235 s/%$format_modifiers"\s*$from\s*"/\%$specialformats{$from}/g;
236 s/%$format_modifiers"\s*$from/\%$specialformats{$from}"/g;
fe13d51d 237 }
78d0fecf
KW
238
239 # Remove any remaining format modifiers, but not in %%
240 s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;
241
fe13d51d 242 # The %"foo" thing needs to happen *before* this regex.
49a5993e 243 if ( my $found = find_message($_) ) {
1b1ee2ef
KW
244 # diag($_);
245 # DIE is just return Perl_die
49a5993e 246 my ($name, $category) = @$found;
1b1ee2ef 247 my $severity = {croak => [qw/P F/],
fe13d51d
JM
248 die => [qw/P F/],
249 warn => [qw/W D S/],
1b1ee2ef
KW
250 }->{$+{'routine'}||'die'};
251 my @categories;
49a5993e
DG
252 if (defined $category) {
253 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
1b1ee2ef 254 }
c4ea5f2e 255 if ($listed_as and $listed_as_line == $. - $multiline) {
fe13d51d 256 $name = $listed_as;
1b1ee2ef 257 } else {
1b1ee2ef
KW
258 # The form listed in perldiag ignores most sorts of fancy printf
259 # formatting, or makes it more perlish.
fe13d51d
JM
260 $name =~ s/%%/\\%/g;
261 $name =~ s/%l[ud]/%d/g;
262 $name =~ s/%\.(\d+|\*)s/\%s/g;
263 $name =~ s/\\"/"/g;
264 $name =~ s/\\t/\t/g;
87a63fff
JM
265 $name =~ s/\\n/ /g;
266 $name =~ s/\s+$//;
4a68bf9d 267 $name =~ s/(\\)\\/$1/g;
fe13d51d
JM
268 }
269
87a63fff
JM
270 # Extra explanatory info on an already-listed error, doesn't
271 # need it's own listing.
fe13d51d
JM
272 next if $name =~ m/^\t/;
273
274 # Happens fairly often with PL_no_modify.
275 next if $name eq '%s';
276
87a63fff
JM
277 # Special syntax for magic comment, allows ignoring the fact
278 # that it isn't listed. Only use in very special circumstances,
279 # like this script failing to notice that the Perl_croak call is
280 # inside an #if 0 block.
fe13d51d
JM
281 next if $name eq 'SKIPME';
282
abd65dc0 283 $name = standardize($name);
2c86d456 284
87a63fff 285 if (exists $entries{$name}) {
abd65dc0
DG
286 if ( $entries{$name}{seen}++ ) {
287 # no need to repeat entries we've tested
288 } elsif ($entries{$name}{todo}) {
87a63fff 289 TODO: {
1b1ee2ef 290 no warnings 'once';
f7b649f0 291 local $::TODO = 'in DATA';
1eb3f3ad 292 # There is no listing, but it is in the list of exceptions. TODO FAIL.
abd65dc0
DG
293 fail($name);
294 diag(
808910a9 295 " Message '$name'\n from $codefn line $. is not listed in $pod\n".
abd65dc0
DG
296 " (but it wasn't documented in 5.10 either, so marking it TODO)."
297 );
87a63fff 298 }
fe13d51d 299 } else {
1eb3f3ad 300 # We found an actual valid entry in perldiag.pod for this error.
abd65dc0 301 pass($name);
fe13d51d 302 }
87a63fff 303 # Later, should start checking that the severity is correct, too.
fe13d51d 304 } else {
87a63fff 305 if ($make_exceptions_list) {
1eb3f3ad
JM
306 # We're making an updated version of the exception list, to
307 # stick in the __DATA__ section. I honestly can't think of
308 # a situation where this is the right thing to do, but I'm
309 # leaving it here, just in case one of my descendents thinks
310 # it's a good idea.
87a63fff
JM
311 print STDERR "$name\n";
312 } else {
1eb3f3ad
JM
313 # No listing found, and no excuse either.
314 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
abd65dc0 315 fail($name);
808910a9 316 diag(" Message '$name'\n from $codefn line $. is not listed in $pod");
87a63fff 317 }
abd65dc0
DG
318 # seen it, so only fail once for this message
319 $entries{$name}{seen}++;
fe13d51d
JM
320 }
321
322 die if $name =~ /%$/;
323 }
324 }
325}
93f09d7b 326# Lists all missing things as of the inauguration of this script, so we
87a63fff 327# don't have to go from "meh" to perfect all at once.
b0227916
JM
328#
329# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
330# pod/perldiag.pod for your new (warning|error).
fed3ba5d
NC
331
332# Also FIXME this test, as the first entry in TODO *is* covered by the
333# description: Malformed UTF-8 character (%s)
87a63fff 334__DATA__
78d0fecf 335Malformed UTF-8 character (unexpected non-continuation byte 0x%x, immediately after start byte 0x%x)
fed3ba5d 336
0dc17498
TM
337%s (%d) does not match %s (%d),
338%s (%d) smaller than %s (%d),
87a63fff
JM
339Argument "%s" isn't numeric
340Argument "%s" isn't numeric in %s
87a63fff
JM
341Attempt to clear deleted array
342Attempt to free non-arena SV: 0x%x
343Attempt to free non-existent shared string '%s'%s
344Attempt to free temp prematurely: SV 0x%x
345Attempt to free unreferenced scalar: SV 0x%x
346Attempt to reload %s aborted. Compilation failed in require
347av_reify called on tied array
348Bad name after %s%s
d5713896 349Bad symbol for %s
87a63fff
JM
350bad top format reference
351Bizarre copy of %s
352Bizarre SvTYPE [%d]
353Cannot copy to %s
354Can't call method "%s" %s
355Can't coerce readonly %s to string
356Can't coerce readonly %s to string in %s
357Can't fix broken locale name "%s"
358Can't get short module name from a handle
359Can't goto subroutine from an eval-block
360Can't goto subroutine from an eval-string
361Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
362Can't modify non-existent substring
363Can't open
364Can't open perl script "%s": %s
365Can't open %s
366Can't reset \%ENV on this system
367Can't return array to lvalue scalar context
368Can't return a %s from lvalue subroutine
369Can't return hash to lvalue scalar context
370Can't spawn "%s": %s
371Can't %s script `%s' with ARGV[0] being `%s'
372Can't %s "%s": %s
373Can't %s %s%s%s
374Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
375Can't take %s of %f
376Can't use '%c' after -mname
973a7615 377Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
4a68bf9d 378Can't use \%c to mean $%c in expression
87a63fff 379Can't use when() outside a topicalizer
4a68bf9d 380\%c better written as $%c
87a63fff
JM
381Character(s) in '%c' format wrapped in %s
382$%c is no longer supported
383Cloning substitution context is unimplemented
384Code missing after '/' in pack
385Code missing after '/' in unpack
386Compilation failed in require
387Corrupted regexp opcode %d > %d
388'%c' outside of string in pack
389Debug leaking scalars child failed%s%s with errno %d: %s
390Deep recursion on anonymous subroutine
391defined(\%hash) is deprecated
4a68bf9d 392Don't know how to handle magic of type \%o
87a63fff
JM
393-Dp not implemented on this platform
394entering effective gid failed
395entering effective uid failed
396Error reading "%s": %s
397Exiting %s via %s
398Filehandle opened only for %sput
399Filehandle %s opened only for %sput
400Filehandle STD%s reopened as %s only for input
401YOU 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!
402Format STDOUT redefined
403Free to wrong pool %p not %p
404get %s %p %p %p
405glob failed (can't start child: %s)
406glob failed (child exited with status %d%s)
407Goto undefined subroutine
408Goto undefined subroutine &%s
409Hash \%%s missing the \% in argument %d of %s()
87a63fff 410Illegal character %sin prototype for %s : %s
1b1ee2ef 411Integer overflow in binary number
87a63fff 412Integer overflow in decimal number
1b1ee2ef
KW
413Integer overflow in hexadecimal number
414Integer overflow in octal number
87a63fff
JM
415Integer overflow in version %d
416internal \%<num>p might conflict with future printf extensions
78d0fecf 417invalid control request: '\%o'
87a63fff
JM
418Invalid module name %s with -%c option: contains single ':'
419invalid option -D%c, use -D'' to see choices
420Invalid range "%c-%c" in transliteration operator
421Invalid separator character %c%c%c in PerlIO layer specification %s
422Invalid TOKEN object ignored
423Invalid type '%c' in pack
424Invalid type '%c' in %s
425Invalid type '%c' in unpack
426Invalid type ',' in %s
4a68bf9d 427It 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
428'j' not supported on this platform
429'J' not supported on this platform
87a63fff
JM
430leaving effective gid failed
431leaving effective uid failed
432List form of piped open not implemented
433Lost precision when decrementing %f by 1
434Lost precision when incrementing %f by 1
435%lx
436Malformed UTF-16 surrogate
437Malformed UTF-8 character (fatal)
438'\%' may not be used in pack
439Missing (suid) fd script name
440More than one argument to open
441More than one argument to open(,':%s')
442mprotect for %p %d failed with %d
443mprotect RW for %p %d failed with %d
444No code specified for -%c
445No directory specified for -I
446No such class field "%s"
447Not an XSUB reference
448Not %s reference
449Offset outside string
450Opening dirhandle %s also as a file
451Opening filehandle %s also as a directory
452Operator or semicolon missing before %c%s
87a63fff
JM
453PERL_SIGNALS illegal: "%s"
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
4a68bf9d 457Possible unintended interpolation of $\ in regex
78d0fecf 458ptr wrong %p != %p fl=%x nl=%p e=%p for %d
87a63fff
JM
459Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
460Recursive call to Perl_load_module in PerlIO_find_layer
461refcnt_dec: fd %d < 0
462refcnt_dec: fd %d: %d <= 0
463refcnt_dec: fd %d >= refcnt_size %d
464refcnt_inc: fd %d < 0
465refcnt_inc: fd %d: %d <= 0
466Reversed %c= operator
467Runaway prototype
1b1ee2ef 468%s(%.0
78d0fecf
KW
469%s(%f) failed
470%s(%f) too large
471%s(%f) too small
87a63fff
JM
472Scalar value %s better written as $%s
473%sCompilation failed in regexp
474%sCompilation failed in require
475set %s %p %p %p
476%s free() ignored (RMAGIC, PERL_CORE)
477%s has too many errors.
478SIG%s handler "%s" not defined.
479%s: illegal mapping '%s'
480%s in %s
481Size magic not implemented
482%s limit (%d) exceeded
483%s method "%s" overloading "%s" in package "%s"
484%s number > %s non-portable
485%s object version %s does not match %s%s%s%s %s
486%srealloc() %signored
487%s returned from lvalue subroutine in scalar context
488%s%s has too many errors.
489%s%s on %s %s
490%s%s on %s %s %s
491Starting Full Screen process with flag=%d, mytype=%d
492Starting PM process with flag=%d, mytype=%d
493strxfrm() gets absurd
494SWASHNEW didn't return an HV ref
495-T and -B not implemented on filehandles
496The flock() function is not implemented on NetWare
497The rewinddir() function is not implemented on NetWare
498The seekdir() function is not implemented on NetWare
499The stat preceding lstat() wasn't an lstat
500The telldir() function is not implemented on NetWare
501Too deeply nested ()-groups in %s
502Too late to run CHECK block
503Too late to run INIT block
504Too many args on %s line of "%s"
505U0 mode on a byte string
506Unbalanced string table refcount: (%d) for "%s"
507Undefined top format called
508Unexpected constant lvalue entersub entry via type/targ %d:%d
78d0fecf 509Unicode non-character 0x%X
87a63fff
JM
510Unknown PerlIO layer "scalar"
511Unknown Unicode option letter '%c'
87a63fff 512Unstable directory path, current directory changed unexpectedly
ee6ba15d
EB
513Unsupported script encoding UTF-16BE
514Unsupported script encoding UTF-16LE
515Unsupported script encoding UTF-32BE
516Unsupported script encoding UTF-32LE
87a63fff
JM
517Unterminated compressed integer in unpack
518Usage: CODE(0x%x)(%s)
519Usage: %s(%s)
520Usage: %s::%s(%s)
521Usage: VMS::Filespec::unixrealpath(spec)
522Usage: VMS::Filespec::vmsrealpath(spec)
523Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
78d0fecf 524utf8 "\x%X" does not map to Unicode
87a63fff
JM
525Value of logical "%s" too long. Truncating to %i bytes
526value of node is %d in Offset macro
527Value of %s%s can be "0"; test with defined()
528Variable "%c%s" is not imported
529vector argument not supported with alpha versions
530Wide character
531Wide character in $/
532Wide character in print
533Wide character in %s
534Within []-length '%c' not allowed in %s
535Wrong syntax (suid) fd script name "%s"
536'X' outside of string in unpack