This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove invalid version object from diag.t exceptions
[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}
f7223e8e 273# Lists all missing things as of the inaguration 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).
87a63fff 278__DATA__
87a63fff
JM
279Argument "%s" isn't numeric
280Argument "%s" isn't numeric in %s
87a63fff
JM
281Attempt to clear deleted array
282Attempt to free non-arena SV: 0x%x
283Attempt to free non-existent shared string '%s'%s
284Attempt to free temp prematurely: SV 0x%x
285Attempt to free unreferenced scalar: SV 0x%x
286Attempt to reload %s aborted. Compilation failed in require
287av_reify called on tied array
288Bad name after %s%s
d5713896 289Bad symbol for %s
87a63fff
JM
290bad top format reference
291Bizarre copy of %s
292Bizarre SvTYPE [%d]
293Cannot copy to %s
294Can't call method "%s" %s
295Can't coerce readonly %s to string
296Can't coerce readonly %s to string in %s
297Can't fix broken locale name "%s"
298Can't get short module name from a handle
299Can't goto subroutine from an eval-block
300Can't goto subroutine from an eval-string
301Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
302Can't modify non-existent substring
303Can't open
304Can't open perl script "%s": %s
305Can't open %s
306Can't reset \%ENV on this system
307Can't return array to lvalue scalar context
308Can't return a %s from lvalue subroutine
309Can't return hash to lvalue scalar context
310Can't spawn "%s": %s
311Can't %s script `%s' with ARGV[0] being `%s'
312Can't %s "%s": %s
313Can't %s %s%s%s
314Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
315Can't take %s of %f
316Can't use '%c' after -mname
973a7615 317Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
4a68bf9d 318Can't use \%c to mean $%c in expression
87a63fff 319Can't use when() outside a topicalizer
4a68bf9d 320\%c better written as $%c
87a63fff
JM
321Character(s) in '%c' format wrapped in %s
322$%c is no longer supported
323Cloning substitution context is unimplemented
324Code missing after '/' in pack
325Code missing after '/' in unpack
326Compilation failed in require
327Corrupted regexp opcode %d > %d
328'%c' outside of string in pack
329Debug leaking scalars child failed%s%s with errno %d: %s
330Deep recursion on anonymous subroutine
331defined(\%hash) is deprecated
4a68bf9d 332Don't know how to handle magic of type \%o
87a63fff
JM
333-Dp not implemented on this platform
334entering effective gid failed
335entering effective uid failed
336Error reading "%s": %s
337Exiting %s via %s
338Filehandle opened only for %sput
339Filehandle %s opened only for %sput
340Filehandle STD%s reopened as %s only for input
341YOU 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!
342Format STDOUT redefined
343Free to wrong pool %p not %p
344get %s %p %p %p
345glob failed (can't start child: %s)
346glob failed (child exited with status %d%s)
347Goto undefined subroutine
348Goto undefined subroutine &%s
349Hash \%%s missing the \% in argument %d of %s()
4a68bf9d 350Illegal character \%03o (carriage return)
87a63fff 351Illegal character %sin prototype for %s : %s
1b1ee2ef 352Integer overflow in binary number
87a63fff 353Integer overflow in decimal number
1b1ee2ef
KW
354Integer overflow in hexadecimal number
355Integer overflow in octal number
87a63fff
JM
356Integer overflow in version %d
357internal \%<num>p might conflict with future printf extensions
4a68bf9d 358invalid control request: '\%03o'
87a63fff
JM
359Invalid module name %s with -%c option: contains single ':'
360invalid option -D%c, use -D'' to see choices
361Invalid range "%c-%c" in transliteration operator
362Invalid separator character %c%c%c in PerlIO layer specification %s
363Invalid TOKEN object ignored
364Invalid type '%c' in pack
365Invalid type '%c' in %s
366Invalid type '%c' in unpack
367Invalid type ',' in %s
4a68bf9d 368It 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
369'j' not supported on this platform
370'J' not supported on this platform
371Layer does not match this perl
372leaving effective gid failed
373leaving effective uid failed
374List form of piped open not implemented
375Lost precision when decrementing %f by 1
376Lost precision when incrementing %f by 1
377%lx
378Malformed UTF-16 surrogate
379Malformed UTF-8 character (fatal)
380'\%' may not be used in pack
381Missing (suid) fd script name
382More than one argument to open
383More than one argument to open(,':%s')
384mprotect for %p %d failed with %d
385mprotect RW for %p %d failed with %d
386No code specified for -%c
387No directory specified for -I
388No such class field "%s"
389Not an XSUB reference
390Not %s reference
391Offset outside string
392Opening dirhandle %s also as a file
393Opening filehandle %s also as a directory
394Operator or semicolon missing before %c%s
87a63fff
JM
395PERL_SIGNALS illegal: "%s"
396Perl %s required (did you mean %s?)--this is only %s, stopped
397Perl %s required--this is only %s, stopped
398Perls since %s too modern--this is %s, stopped
4a68bf9d 399Possible unintended interpolation of $\ in regex
87a63fff
JM
400ptr wrong %p != %p fl=%08
401Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
402Recursive call to Perl_load_module in PerlIO_find_layer
403refcnt_dec: fd %d < 0
404refcnt_dec: fd %d: %d <= 0
405refcnt_dec: fd %d >= refcnt_size %d
406refcnt_inc: fd %d < 0
407refcnt_inc: fd %d: %d <= 0
408Reversed %c= operator
409Runaway prototype
1b1ee2ef 410%s(%.0
87a63fff
JM
411%s(%.0f) failed
412%s(%.0f) too large
413Scalar value %s better written as $%s
414%sCompilation failed in regexp
415%sCompilation failed in require
416set %s %p %p %p
417%s free() ignored (RMAGIC, PERL_CORE)
418%s has too many errors.
419SIG%s handler "%s" not defined.
420%s: illegal mapping '%s'
421%s in %s
422Size magic not implemented
423%s limit (%d) exceeded
424%s method "%s" overloading "%s" in package "%s"
425%s number > %s non-portable
426%s object version %s does not match %s%s%s%s %s
427%srealloc() %signored
428%s returned from lvalue subroutine in scalar context
429%s%s has too many errors.
430%s%s on %s %s
431%s%s on %s %s %s
432Starting Full Screen process with flag=%d, mytype=%d
433Starting PM process with flag=%d, mytype=%d
434strxfrm() gets absurd
435SWASHNEW didn't return an HV ref
436-T and -B not implemented on filehandles
437The flock() function is not implemented on NetWare
438The rewinddir() function is not implemented on NetWare
439The seekdir() function is not implemented on NetWare
440The stat preceding lstat() wasn't an lstat
441The telldir() function is not implemented on NetWare
442Too deeply nested ()-groups in %s
443Too late to run CHECK block
444Too late to run INIT block
445Too many args on %s line of "%s"
446U0 mode on a byte string
447Unbalanced string table refcount: (%d) for "%s"
448Undefined top format called
449Unexpected constant lvalue entersub entry via type/targ %d:%d
6f6ac1de 450Unicode non-character 0x%04
87a63fff
JM
451Unknown PerlIO layer "scalar"
452Unknown Unicode option letter '%c'
87a63fff 453Unstable directory path, current directory changed unexpectedly
ee6ba15d
EB
454Unsupported script encoding UTF-16BE
455Unsupported script encoding UTF-16LE
456Unsupported script encoding UTF-32BE
457Unsupported script encoding UTF-32LE
87a63fff
JM
458Unterminated compressed integer in unpack
459Usage: CODE(0x%x)(%s)
460Usage: %s(%s)
461Usage: %s::%s(%s)
462Usage: VMS::Filespec::unixrealpath(spec)
463Usage: VMS::Filespec::vmsrealpath(spec)
464Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
465UTF-16 surrogate 0x%04
4a68bf9d 466utf8 "\x%02X" does not map to Unicode
87a63fff
JM
467Value of logical "%s" too long. Truncating to %i bytes
468value of node is %d in Offset macro
469Value of %s%s can be "0"; test with defined()
470Variable "%c%s" is not imported
471vector argument not supported with alpha versions
472Wide character
473Wide character in $/
474Wide character in print
475Wide character in %s
476Within []-length '%c' not allowed in %s
477Wrong syntax (suid) fd script name "%s"
478'X' outside of string in unpack