This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Add perldiag entries for new version format errors
[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
2c86d456
DG
212 # Standardize messages with variants into the form that appears
213 # in perldiag.pod
214 if ( $name =~ m/^(Invalid strict version format) \([^\)]*\)/ ) {
215 $name = "$1 (\%s)";
216 }
217 elsif ( $name =~ m/^(Invalid version format) \([^\)]*\)/ ) {
218 $name = "$1 (\%s)";
219 }
220
87a63fff
JM
221 if (exists $entries{$name}) {
222 if ($entries{$name}{todo}) {
223 TODO: {
1b1ee2ef 224 no warnings 'once';
f7b649f0 225 local $::TODO = 'in DATA';
1eb3f3ad
JM
226 # There is no listing, but it is in the list of exceptions. TODO FAIL.
227 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 228 }
fe13d51d 229 } else {
1eb3f3ad
JM
230 # We found an actual valid entry in perldiag.pod for this error.
231 ok("Found listing in pod/perldiag.pod for '$name' from $codefn line $.");
fe13d51d 232 }
87a63fff
JM
233 # Later, should start checking that the severity is correct, too.
234 } elsif ($name =~ m/^panic: /) {
235 # Just too many panic:s, they are hard to diagnose, and there
236 # is a generic "panic: %s" entry. Leave these for another
237 # pass.
1eb3f3ad 238 ok("Skipping lack of explicit perldiag entry for '$name' from $codefn line $., covered by panic: %s entry");
fe13d51d 239 } else {
87a63fff 240 if ($make_exceptions_list) {
1eb3f3ad
JM
241 # We're making an updated version of the exception list, to
242 # stick in the __DATA__ section. I honestly can't think of
243 # a situation where this is the right thing to do, but I'm
244 # leaving it here, just in case one of my descendents thinks
245 # it's a good idea.
87a63fff
JM
246 print STDERR "$name\n";
247 } else {
1eb3f3ad
JM
248 # No listing found, and no excuse either.
249 # Find the correct place in perldiag.pod, and add a stanza beginning =item $name.
250 fail("No listing in pod/perldiag.pod for '$name' from $codefn line $.");
87a63fff 251 }
fe13d51d
JM
252 }
253
254 die if $name =~ /%$/;
255 }
256 }
257}
f7223e8e 258# Lists all missing things as of the inaguration of this script, so we
87a63fff 259# don't have to go from "meh" to perfect all at once.
b0227916
JM
260#
261# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
262# pod/perldiag.pod for your new (warning|error).
87a63fff 263__DATA__
87a63fff
JM
264Argument "%s" isn't numeric
265Argument "%s" isn't numeric in %s
87a63fff
JM
266Attempt to clear deleted array
267Attempt to free non-arena SV: 0x%x
268Attempt to free non-existent shared string '%s'%s
269Attempt to free temp prematurely: SV 0x%x
270Attempt to free unreferenced scalar: SV 0x%x
271Attempt to reload %s aborted. Compilation failed in require
272av_reify called on tied array
273Bad name after %s%s
d5713896 274Bad symbol for %s
87a63fff
JM
275bad top format reference
276Bizarre copy of %s
277Bizarre SvTYPE [%d]
278Cannot copy to %s
279Can't call method "%s" %s
280Can't coerce readonly %s to string
281Can't coerce readonly %s to string in %s
282Can't fix broken locale name "%s"
283Can't get short module name from a handle
284Can't goto subroutine from an eval-block
285Can't goto subroutine from an eval-string
286Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
287Can't modify non-existent substring
288Can't open
289Can't open perl script "%s": %s
290Can't open %s
291Can't reset \%ENV on this system
292Can't return array to lvalue scalar context
293Can't return a %s from lvalue subroutine
294Can't return hash to lvalue scalar context
295Can't spawn "%s": %s
296Can't %s script `%s' with ARGV[0] being `%s'
297Can't %s "%s": %s
298Can't %s %s%s%s
299Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
300Can't take %s of %f
301Can't use '%c' after -mname
973a7615 302Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
4a68bf9d 303Can't use \%c to mean $%c in expression
87a63fff 304Can't use when() outside a topicalizer
4a68bf9d 305\%c better written as $%c
87a63fff
JM
306Character(s) in '%c' format wrapped in %s
307$%c is no longer supported
308Cloning substitution context is unimplemented
309Code missing after '/' in pack
310Code missing after '/' in unpack
311Compilation failed in require
312Corrupted regexp opcode %d > %d
313'%c' outside of string in pack
314Debug leaking scalars child failed%s%s with errno %d: %s
315Deep recursion on anonymous subroutine
316defined(\%hash) is deprecated
4a68bf9d 317Don't know how to handle magic of type \%o
87a63fff
JM
318-Dp not implemented on this platform
319entering effective gid failed
320entering effective uid failed
321Error reading "%s": %s
322Exiting %s via %s
323Filehandle opened only for %sput
324Filehandle %s opened only for %sput
325Filehandle STD%s reopened as %s only for input
326YOU 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!
327Format STDOUT redefined
328Free to wrong pool %p not %p
329get %s %p %p %p
330glob failed (can't start child: %s)
331glob failed (child exited with status %d%s)
332Goto undefined subroutine
333Goto undefined subroutine &%s
334Hash \%%s missing the \% in argument %d of %s()
4a68bf9d 335Illegal character \%03o (carriage return)
87a63fff 336Illegal character %sin prototype for %s : %s
1b1ee2ef 337Integer overflow in binary number
87a63fff 338Integer overflow in decimal number
1b1ee2ef
KW
339Integer overflow in hexadecimal number
340Integer overflow in octal number
87a63fff
JM
341Integer overflow in version %d
342internal \%<num>p might conflict with future printf extensions
4a68bf9d 343invalid control request: '\%03o'
87a63fff
JM
344Invalid module name %s with -%c option: contains single ':'
345invalid option -D%c, use -D'' to see choices
346Invalid range "%c-%c" in transliteration operator
347Invalid separator character %c%c%c in PerlIO layer specification %s
348Invalid TOKEN object ignored
349Invalid type '%c' in pack
350Invalid type '%c' in %s
351Invalid type '%c' in unpack
352Invalid type ',' in %s
87a63fff 353Invalid version object
4a68bf9d 354It 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
355'j' not supported on this platform
356'J' not supported on this platform
357Layer does not match this perl
358leaving effective gid failed
359leaving effective uid failed
360List form of piped open not implemented
361Lost precision when decrementing %f by 1
362Lost precision when incrementing %f by 1
363%lx
364Malformed UTF-16 surrogate
365Malformed UTF-8 character (fatal)
366'\%' may not be used in pack
367Missing (suid) fd script name
368More than one argument to open
369More than one argument to open(,':%s')
370mprotect for %p %d failed with %d
371mprotect RW for %p %d failed with %d
372No code specified for -%c
373No directory specified for -I
374No such class field "%s"
375Not an XSUB reference
376Not %s reference
377Offset outside string
378Opening dirhandle %s also as a file
379Opening filehandle %s also as a directory
380Operator or semicolon missing before %c%s
87a63fff
JM
381PERL_SIGNALS illegal: "%s"
382Perl %s required (did you mean %s?)--this is only %s, stopped
383Perl %s required--this is only %s, stopped
384Perls since %s too modern--this is %s, stopped
4a68bf9d 385Possible unintended interpolation of $\ in regex
87a63fff
JM
386ptr wrong %p != %p fl=%08
387Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
388Recursive call to Perl_load_module in PerlIO_find_layer
389refcnt_dec: fd %d < 0
390refcnt_dec: fd %d: %d <= 0
391refcnt_dec: fd %d >= refcnt_size %d
392refcnt_inc: fd %d < 0
393refcnt_inc: fd %d: %d <= 0
394Reversed %c= operator
395Runaway prototype
1b1ee2ef 396%s(%.0
87a63fff
JM
397%s(%.0f) failed
398%s(%.0f) too large
399Scalar value %s better written as $%s
400%sCompilation failed in regexp
401%sCompilation failed in require
402set %s %p %p %p
403%s free() ignored (RMAGIC, PERL_CORE)
404%s has too many errors.
405SIG%s handler "%s" not defined.
406%s: illegal mapping '%s'
407%s in %s
408Size magic not implemented
409%s limit (%d) exceeded
410%s method "%s" overloading "%s" in package "%s"
411%s number > %s non-portable
412%s object version %s does not match %s%s%s%s %s
413%srealloc() %signored
414%s returned from lvalue subroutine in scalar context
415%s%s has too many errors.
416%s%s on %s %s
417%s%s on %s %s %s
418Starting Full Screen process with flag=%d, mytype=%d
419Starting PM process with flag=%d, mytype=%d
420strxfrm() gets absurd
421SWASHNEW didn't return an HV ref
422-T and -B not implemented on filehandles
423The flock() function is not implemented on NetWare
424The rewinddir() function is not implemented on NetWare
425The seekdir() function is not implemented on NetWare
426The stat preceding lstat() wasn't an lstat
427The telldir() function is not implemented on NetWare
428Too deeply nested ()-groups in %s
429Too late to run CHECK block
430Too late to run INIT block
431Too many args on %s line of "%s"
432U0 mode on a byte string
433Unbalanced string table refcount: (%d) for "%s"
434Undefined top format called
435Unexpected constant lvalue entersub entry via type/targ %d:%d
6f6ac1de 436Unicode non-character 0x%04
87a63fff
JM
437Unknown PerlIO layer "scalar"
438Unknown Unicode option letter '%c'
87a63fff 439Unstable directory path, current directory changed unexpectedly
ee6ba15d
EB
440Unsupported script encoding UTF-16BE
441Unsupported script encoding UTF-16LE
442Unsupported script encoding UTF-32BE
443Unsupported script encoding UTF-32LE
87a63fff
JM
444Unterminated compressed integer in unpack
445Usage: CODE(0x%x)(%s)
446Usage: %s(%s)
447Usage: %s::%s(%s)
448Usage: VMS::Filespec::unixrealpath(spec)
449Usage: VMS::Filespec::vmsrealpath(spec)
450Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
451UTF-16 surrogate 0x%04
4a68bf9d 452utf8 "\x%02X" does not map to Unicode
87a63fff
JM
453Value of logical "%s" too long. Truncating to %i bytes
454value of node is %d in Offset macro
455Value of %s%s can be "0"; test with defined()
456Variable "%c%s" is not imported
457vector argument not supported with alpha versions
458Wide character
459Wide character in $/
460Wide character in print
461Wide character in %s
462Within []-length '%c' not allowed in %s
463Wrong syntax (suid) fd script name "%s"
464'X' outside of string in unpack