This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Fix up diagnostic.pm’s backtrace for multiline msgs
[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
356Attempt to reload %s aborted. Compilation failed in require
357av_reify called on tied array
358Bad name after %s%s
d5713896 359Bad symbol for %s
87a63fff
JM
360bad top format reference
361Bizarre copy of %s
362Bizarre SvTYPE [%d]
87a63fff
JM
363Can't call method "%s" %s
364Can't coerce readonly %s to string
365Can't coerce readonly %s to string in %s
366Can't fix broken locale name "%s"
367Can't get short module name from a handle
368Can't goto subroutine from an eval-block
369Can't goto subroutine from an eval-string
370Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
371Can't modify non-existent substring
372Can't open
373Can't open perl script "%s": %s
374Can't open %s
375Can't reset \%ENV on this system
376Can't return array to lvalue scalar context
377Can't return a %s from lvalue subroutine
378Can't return hash to lvalue scalar context
379Can't spawn "%s": %s
380Can't %s script `%s' with ARGV[0] being `%s'
381Can't %s "%s": %s
382Can't %s %s%s%s
383Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
384Can't take %s of %f
385Can't use '%c' after -mname
973a7615 386Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
87a63fff 387Can't use when() outside a topicalizer
4a68bf9d 388\%c better written as $%c
87a63fff
JM
389Character(s) in '%c' format wrapped in %s
390$%c is no longer supported
391Cloning substitution context is unimplemented
392Code missing after '/' in pack
393Code missing after '/' in unpack
87a63fff
JM
394Corrupted regexp opcode %d > %d
395'%c' outside of string in pack
396Debug leaking scalars child failed%s%s with errno %d: %s
397Deep recursion on anonymous subroutine
398defined(\%hash) is deprecated
4a68bf9d 399Don't know how to handle magic of type \%o
87a63fff
JM
400-Dp not implemented on this platform
401entering effective gid failed
402entering effective uid failed
403Error reading "%s": %s
404Exiting %s via %s
405Filehandle opened only for %sput
406Filehandle %s opened only for %sput
407Filehandle STD%s reopened as %s only for input
408YOU 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!
409Format STDOUT redefined
410Free to wrong pool %p not %p
411get %s %p %p %p
412glob failed (can't start child: %s)
413glob failed (child exited with status %d%s)
414Goto undefined subroutine
415Goto undefined subroutine &%s
416Hash \%%s missing the \% in argument %d of %s()
87a63fff 417Illegal character %sin prototype for %s : %s
1b1ee2ef 418Integer overflow in binary number
87a63fff 419Integer overflow in decimal number
1b1ee2ef
KW
420Integer overflow in hexadecimal number
421Integer overflow in octal number
87a63fff
JM
422Integer overflow in version %d
423internal \%<num>p might conflict with future printf extensions
78d0fecf 424invalid control request: '\%o'
87a63fff
JM
425Invalid module name %s with -%c option: contains single ':'
426invalid option -D%c, use -D'' to see choices
427Invalid range "%c-%c" in transliteration operator
428Invalid separator character %c%c%c in PerlIO layer specification %s
429Invalid TOKEN object ignored
430Invalid type '%c' in pack
431Invalid type '%c' in %s
432Invalid type '%c' in unpack
433Invalid type ',' in %s
87a63fff
JM
434'j' not supported on this platform
435'J' not supported on this platform
87a63fff
JM
436leaving effective gid failed
437leaving effective uid failed
438List form of piped open not implemented
439Lost precision when decrementing %f by 1
440Lost precision when incrementing %f by 1
441%lx
87a63fff
JM
442Malformed UTF-8 character (fatal)
443'\%' may not be used in pack
444Missing (suid) fd script name
445More than one argument to open
446More than one argument to open(,':%s')
de42a5a9
KW
447mprotect for %p %u failed with %d
448mprotect RW for %p %u failed with %d
87a63fff
JM
449No code specified for -%c
450No directory specified for -I
451No such class field "%s"
452Not an XSUB reference
453Not %s reference
87a63fff 454Operator or semicolon missing before %c%s
87a63fff
JM
455Perl %s required (did you mean %s?)--this is only %s, stopped
456Perl %s required--this is only %s, stopped
457Perls since %s too modern--this is %s, stopped
78d0fecf 458ptr wrong %p != %p fl=%x nl=%p e=%p for %d
87a63fff
JM
459Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
460Recursive call to Perl_load_module in PerlIO_find_layer
87a63fff
JM
461Reversed %c= operator
462Runaway prototype
1b1ee2ef 463%s(%.0
78d0fecf
KW
464%s(%f) failed
465%s(%f) too large
466%s(%f) too small
87a63fff
JM
467Scalar value %s better written as $%s
468%sCompilation failed in regexp
469%sCompilation failed in require
470set %s %p %p %p
471%s free() ignored (RMAGIC, PERL_CORE)
472%s has too many errors.
473SIG%s handler "%s" not defined.
474%s: illegal mapping '%s'
475%s in %s
476Size magic not implemented
477%s limit (%d) exceeded
478%s method "%s" overloading "%s" in package "%s"
479%s number > %s non-portable
480%s object version %s does not match %s%s%s%s %s
481%srealloc() %signored
482%s returned from lvalue subroutine in scalar context
483%s%s has too many errors.
484%s%s on %s %s
485%s%s on %s %s %s
486Starting Full Screen process with flag=%d, mytype=%d
487Starting PM process with flag=%d, mytype=%d
87a63fff
JM
488SWASHNEW didn't return an HV ref
489-T and -B not implemented on filehandles
490The flock() function is not implemented on NetWare
491The rewinddir() function is not implemented on NetWare
492The seekdir() function is not implemented on NetWare
87a63fff
JM
493The telldir() function is not implemented on NetWare
494Too deeply nested ()-groups in %s
495Too late to run CHECK block
496Too late to run INIT block
497Too many args on %s line of "%s"
498U0 mode on a byte string
499Unbalanced string table refcount: (%d) for "%s"
500Undefined top format called
501Unexpected constant lvalue entersub entry via type/targ %d:%d
78d0fecf 502Unicode non-character 0x%X
87a63fff 503Unknown PerlIO layer "scalar"
87a63fff 504Unstable directory path, current directory changed unexpectedly
ee6ba15d
EB
505Unsupported script encoding UTF-16BE
506Unsupported script encoding UTF-16LE
507Unsupported script encoding UTF-32BE
508Unsupported script encoding UTF-32LE
87a63fff
JM
509Unterminated compressed integer in unpack
510Usage: CODE(0x%x)(%s)
511Usage: %s(%s)
512Usage: %s::%s(%s)
513Usage: VMS::Filespec::unixrealpath(spec)
514Usage: VMS::Filespec::vmsrealpath(spec)
515Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
78d0fecf 516utf8 "\x%X" does not map to Unicode
87a63fff
JM
517Value of logical "%s" too long. Truncating to %i bytes
518value of node is %d in Offset macro
519Value of %s%s can be "0"; test with defined()
520Variable "%c%s" is not imported
521vector argument not supported with alpha versions
522Wide character
523Wide character in $/
524Wide character in print
87a63fff
JM
525Within []-length '%c' not allowed in %s
526Wrong syntax (suid) fd script name "%s"
527'X' outside of string in unpack