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