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