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