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