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