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