This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove "at - line 3" from the end of a perldiag entry.
[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
f7223e8e 11my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
87a63fff 12
45f1c7ba 13chdir '..' or die "Can't chdir ..: $!";
47f6eaac 14BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
45f1c7ba 15
1b1ee2ef
KW
16my @functions;
17
18open my $func_fh, "<", "embed.fnc" or die "Can't open embed.fnc: $!";
19
20# Look for functions in embed.fnc that look like they could be diagnostic ones.
21while (<$func_fh>) {
22 chomp;
23 s/^\s+//;
24 while (s/\s*\\$//) { # Grab up all continuation lines, these end in \
25 my $next = <$func_fh>;
26 $next =~ s/^\s+//;
27 chomp $next;
28 $_ .= $next;
29 }
30 next if /^:/; # Lines beginning with colon are comments.
31 next unless /\|/; # Lines without a vertical bar are something we can't deal
32 # with
33 my @fields = split /\s*\|\s*/;
34 next unless $fields[2] =~ /warn|err|(\b|_)die|croak/i;
35 push @functions, $fields[2];
36
37 # The flag p means that this function may have a 'Perl_' prefix
38 # The flag s means that this function may have a 'S_' prefix
39 push @functions, "Perl_$fields[2]", if $fields[0] =~ /p/;
40 push @functions, "S_$fields[2]", if $fields[0] =~ /s/;
41}
42
43close $func_fh;
44
45my $function_re = join '|', @functions;
46my $source_msg_re = qr/(?<routine>\bDIE\b|$function_re)/;
fe13d51d
JM
47
48my %entries;
1b1ee2ef
KW
49
50# Get the ignores that are compiled into this file
87a63fff
JM
51while (<DATA>) {
52 chomp;
53 $entries{$_}{todo}=1;
54}
55
fe13d51d 56my $cur_entry;
1b1ee2ef
KW
57open my $diagfh, "<", "pod/perldiag.pod"
58 or die "Can't open pod/perldiag.pod: $!";
59
fe13d51d
JM
60while (<$diagfh>) {
61 if (m/^=item (.*)/) {
62 $cur_entry = $1;
63 } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) {
87a63fff
JM
64 # Make sure to init this here, so an actual entry in perldiag overwrites
65 # one in DATA.
66 $entries{$cur_entry}{todo} = 0;
fe13d51d
JM
67 $entries{$cur_entry}{severity} = $1;
68 $entries{$cur_entry}{category} = $2;
69 }
70}
71
1b1ee2ef 72# Recursively descend looking for source files.
45f1c7ba 73my @todo = <*>;
fe13d51d
JM
74while (@todo) {
75 my $todo = shift @todo;
45f1c7ba 76 next if $todo ~~ ['t', 'lib', 'ext', 'dist', 'cpan'];
fe13d51d 77 # opmini.c is just a copy of op.c, so there's no need to check again.
45f1c7ba 78 next if $todo eq 'opmini.c';
fe13d51d
JM
79 if (-d $todo) {
80 push @todo, glob "$todo/*";
87a63fff 81 } elsif ($todo =~ m/\.[ch]$/) {
fe13d51d
JM
82 check_file($todo);
83 }
84}
85
86sub check_file {
87 my ($codefn) = @_;
88
f7223e8e 89 print "# $codefn\n";
fe13d51d 90
38ec24b4 91 open my $codefh, "<", $codefn
fe13d51d
JM
92 or die "Can't open $codefn: $!";
93
94 my $listed_as;
95 my $listed_as_line;
96 my $sub = 'top of file';
97 while (<$codefh>) {
98 chomp;
99 # Getting too much here isn't a problem; we only use this to skip
100 # errors inside of XS modules, which should get documented in the
101 # docs for the module.
102 if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) {
103 $sub = $1;
104 }
105 next if $sub =~ m/^XS/;
106 if (m</\* diag_listed_as: (.*) \*/>) {
107 $listed_as = $1;
108 $listed_as_line = $.+1;
109 }
110 next if /^#/;
111 next if /^ * /;
1b1ee2ef 112
c4ea5f2e 113 my $multiline = 0;
1b1ee2ef
KW
114 # Loop to accumulate the message text all on one line.
115 while (m/$source_msg_re/ and not m/\);$/) {
fe13d51d
JM
116 my $nextline = <$codefh>;
117 # Means we fell off the end of the file. Not terribly surprising;
118 # this code tries to merge a lot of things that aren't regular C
119 # code (preprocessor stuff, long comments). That's OK; we don't
120 # need those anyway.
121 last if not defined $nextline;
122 chomp $nextline;
123 $nextline =~ s/^\s+//;
124 # Note that we only want to do this where *both* are true.
125 $_ =~ s/\\$//;
126 if ($_ =~ m/"$/ and $nextline =~ m/^"/) {
127 $_ =~ s/"$//;
128 $nextline =~ s/^"//;
129 }
130 $_ = "$_$nextline";
c4ea5f2e 131 ++$multiline;
fe13d51d
JM
132 }
133 # This should happen *after* unwrapping, or we don't reformat the things
134 # in later lines.
135 # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs"
136 my %specialformats = (IVdf => 'd',
137 UVuf => 'd',
138 UVof => 'o',
139 UVxf => 'x',
140 UVXf => 'X',
141 NVef => 'f',
142 NVff => 'f',
143 NVgf => 'f',
144 SVf => 's');
145 for my $from (keys %specialformats) {
146 s/%"\s*$from\s*"/\%$specialformats{$from}/g;
147 s/%"\s*$from/\%$specialformats{$from}"/g;
148 }
149 # The %"foo" thing needs to happen *before* this regex.
1b1ee2ef 150 if (m/$source_msg_re(?:_nocontext)? \s*
fe13d51d 151 \(aTHX_ \s*
1b1ee2ef
KW
152 (?:packWARN\d*\((?<category>.*?)\),)? \s*
153 "(?<text>(?:\\"|[^"])*?)"/x)
154 {
155 # diag($_);
156 # DIE is just return Perl_die
157 my $severity = {croak => [qw/P F/],
fe13d51d
JM
158 die => [qw/P F/],
159 warn => [qw/W D S/],
1b1ee2ef
KW
160 }->{$+{'routine'}||'die'};
161 my @categories;
162 if ($+{'category'}) {
163 @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $+{'category'};
164 }
165 my $name;
c4ea5f2e 166 if ($listed_as and $listed_as_line == $. - $multiline) {
fe13d51d 167 $name = $listed_as;
1b1ee2ef
KW
168 } else {
169 $name = $+{'text'};
170 # The form listed in perldiag ignores most sorts of fancy printf
171 # formatting, or makes it more perlish.
fe13d51d
JM
172 $name =~ s/%%/\\%/g;
173 $name =~ s/%l[ud]/%d/g;
174 $name =~ s/%\.(\d+|\*)s/\%s/g;
175 $name =~ s/\\"/"/g;
176 $name =~ s/\\t/\t/g;
87a63fff
JM
177 $name =~ s/\\n/ /g;
178 $name =~ s/\s+$//;
4a68bf9d 179 $name =~ s/(\\)\\/$1/g;
fe13d51d
JM
180 }
181
87a63fff
JM
182 # Extra explanatory info on an already-listed error, doesn't
183 # need it's own listing.
fe13d51d
JM
184 next if $name =~ m/^\t/;
185
186 # Happens fairly often with PL_no_modify.
187 next if $name eq '%s';
188
87a63fff
JM
189 # Special syntax for magic comment, allows ignoring the fact
190 # that it isn't listed. Only use in very special circumstances,
191 # like this script failing to notice that the Perl_croak call is
192 # inside an #if 0 block.
fe13d51d
JM
193 next if $name eq 'SKIPME';
194
87a63fff
JM
195 if (exists $entries{$name}) {
196 if ($entries{$name}{todo}) {
197 TODO: {
1b1ee2ef 198 no warnings 'once';
f7b649f0 199 local $::TODO = 'in DATA';
87a63fff
JM
200 fail("Presence of '$name' from $codefn line $.");
201 }
fe13d51d 202 } else {
87a63fff 203 ok("Presence of '$name' from $codefn line $.");
fe13d51d 204 }
87a63fff
JM
205 # Later, should start checking that the severity is correct, too.
206 } elsif ($name =~ m/^panic: /) {
207 # Just too many panic:s, they are hard to diagnose, and there
208 # is a generic "panic: %s" entry. Leave these for another
209 # pass.
210 ok("Presence of '$name' from $codefn line $., covered by panic: %s entry");
fe13d51d 211 } else {
87a63fff
JM
212 if ($make_exceptions_list) {
213 print STDERR "$name\n";
214 } else {
215 fail("Presence of '$name' from $codefn line $.");
216 }
fe13d51d
JM
217 }
218
219 die if $name =~ /%$/;
220 }
221 }
222}
f7223e8e 223# Lists all missing things as of the inaguration of this script, so we
87a63fff 224# don't have to go from "meh" to perfect all at once.
b0227916
JM
225#
226# PLEASE DO NOT ADD TO THIS LIST. Instead, write an entry in
227# pod/perldiag.pod for your new (warning|error).
87a63fff 228__DATA__
87a63fff
JM
229Argument "%s" isn't numeric
230Argument "%s" isn't numeric in %s
87a63fff
JM
231Attempt to clear deleted array
232Attempt to free non-arena SV: 0x%x
233Attempt to free non-existent shared string '%s'%s
234Attempt to free temp prematurely: SV 0x%x
235Attempt to free unreferenced scalar: SV 0x%x
236Attempt to reload %s aborted. Compilation failed in require
237av_reify called on tied array
238Bad name after %s%s
d5713896 239Bad symbol for %s
87a63fff
JM
240bad top format reference
241Bizarre copy of %s
242Bizarre SvTYPE [%d]
243Cannot copy to %s
244Can't call method "%s" %s
245Can't coerce readonly %s to string
246Can't coerce readonly %s to string in %s
247Can't fix broken locale name "%s"
248Can't get short module name from a handle
249Can't goto subroutine from an eval-block
250Can't goto subroutine from an eval-string
251Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
252Can't modify non-existent substring
253Can't open
254Can't open perl script "%s": %s
255Can't open %s
256Can't reset \%ENV on this system
257Can't return array to lvalue scalar context
258Can't return a %s from lvalue subroutine
259Can't return hash to lvalue scalar context
260Can't spawn "%s": %s
261Can't %s script `%s' with ARGV[0] being `%s'
262Can't %s "%s": %s
263Can't %s %s%s%s
264Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found)
265Can't take %s of %f
266Can't use '%c' after -mname
973a7615 267Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use
4a68bf9d 268Can't use \%c to mean $%c in expression
87a63fff 269Can't use when() outside a topicalizer
4a68bf9d 270\%c better written as $%c
87a63fff
JM
271Character(s) in '%c' format wrapped in %s
272$%c is no longer supported
273Cloning substitution context is unimplemented
274Code missing after '/' in pack
275Code missing after '/' in unpack
276Compilation failed in require
277Corrupted regexp opcode %d > %d
278'%c' outside of string in pack
279Debug leaking scalars child failed%s%s with errno %d: %s
280Deep recursion on anonymous subroutine
281defined(\%hash) is deprecated
4a68bf9d 282Don't know how to handle magic of type \%o
87a63fff
JM
283-Dp not implemented on this platform
284entering effective gid failed
285entering effective uid failed
286Error reading "%s": %s
287Exiting %s via %s
288Filehandle opened only for %sput
289Filehandle %s opened only for %sput
290Filehandle STD%s reopened as %s only for input
291YOU 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!
292Format STDOUT redefined
293Free to wrong pool %p not %p
294get %s %p %p %p
295glob failed (can't start child: %s)
296glob failed (child exited with status %d%s)
297Goto undefined subroutine
298Goto undefined subroutine &%s
299Hash \%%s missing the \% in argument %d of %s()
4a68bf9d 300Illegal character \%03o (carriage return)
87a63fff 301Illegal character %sin prototype for %s : %s
1b1ee2ef 302Integer overflow in binary number
87a63fff 303Integer overflow in decimal number
1b1ee2ef
KW
304Integer overflow in hexadecimal number
305Integer overflow in octal number
87a63fff
JM
306Integer overflow in version %d
307internal \%<num>p might conflict with future printf extensions
4a68bf9d 308invalid control request: '\%03o'
87a63fff
JM
309Invalid module name %s with -%c option: contains single ':'
310invalid option -D%c, use -D'' to see choices
311Invalid range "%c-%c" in transliteration operator
312Invalid separator character %c%c%c in PerlIO layer specification %s
313Invalid TOKEN object ignored
314Invalid type '%c' in pack
315Invalid type '%c' in %s
316Invalid type '%c' in unpack
317Invalid type ',' in %s
91152fc1
DG
318Invalid strict version format (0 before decimal required)
319Invalid strict version format (no leading zeros)
320Invalid strict version format (no underscores)
321Invalid strict version format (v1.2.3 required)
322Invalid strict version format (version required)
323Invalid strict version format (1.[0-9] required)
87a63fff
JM
324Invalid version format (alpha without decimal)
325Invalid version format (misplaced _ in number)
326Invalid version object
4a68bf9d 327It 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
328'j' not supported on this platform
329'J' not supported on this platform
330Layer does not match this perl
331leaving effective gid failed
332leaving effective uid failed
333List form of piped open not implemented
334Lost precision when decrementing %f by 1
335Lost precision when incrementing %f by 1
336%lx
337Malformed UTF-16 surrogate
338Malformed UTF-8 character (fatal)
339'\%' may not be used in pack
340Missing (suid) fd script name
341More than one argument to open
342More than one argument to open(,':%s')
343mprotect for %p %d failed with %d
344mprotect RW for %p %d failed with %d
345No code specified for -%c
346No directory specified for -I
347No such class field "%s"
348Not an XSUB reference
349Not %s reference
350Offset outside string
351Opening dirhandle %s also as a file
352Opening filehandle %s also as a directory
353Operator or semicolon missing before %c%s
87a63fff
JM
354PERL_SIGNALS illegal: "%s"
355Perl %s required (did you mean %s?)--this is only %s, stopped
356Perl %s required--this is only %s, stopped
357Perls since %s too modern--this is %s, stopped
4a68bf9d 358Possible unintended interpolation of $\ in regex
87a63fff
JM
359ptr wrong %p != %p fl=%08
360Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
361Recursive call to Perl_load_module in PerlIO_find_layer
362refcnt_dec: fd %d < 0
363refcnt_dec: fd %d: %d <= 0
364refcnt_dec: fd %d >= refcnt_size %d
365refcnt_inc: fd %d < 0
366refcnt_inc: fd %d: %d <= 0
367Reversed %c= operator
368Runaway prototype
1b1ee2ef 369%s(%.0
87a63fff
JM
370%s(%.0f) failed
371%s(%.0f) too large
372Scalar value %s better written as $%s
373%sCompilation failed in regexp
374%sCompilation failed in require
375set %s %p %p %p
376%s free() ignored (RMAGIC, PERL_CORE)
377%s has too many errors.
378SIG%s handler "%s" not defined.
379%s: illegal mapping '%s'
380%s in %s
381Size magic not implemented
382%s limit (%d) exceeded
383%s method "%s" overloading "%s" in package "%s"
384%s number > %s non-portable
385%s object version %s does not match %s%s%s%s %s
386%srealloc() %signored
387%s returned from lvalue subroutine in scalar context
388%s%s has too many errors.
389%s%s on %s %s
390%s%s on %s %s %s
391Starting Full Screen process with flag=%d, mytype=%d
392Starting PM process with flag=%d, mytype=%d
393strxfrm() gets absurd
394SWASHNEW didn't return an HV ref
395-T and -B not implemented on filehandles
396The flock() function is not implemented on NetWare
397The rewinddir() function is not implemented on NetWare
398The seekdir() function is not implemented on NetWare
399The stat preceding lstat() wasn't an lstat
400The telldir() function is not implemented on NetWare
401Too deeply nested ()-groups in %s
402Too late to run CHECK block
403Too late to run INIT block
404Too many args on %s line of "%s"
405U0 mode on a byte string
406Unbalanced string table refcount: (%d) for "%s"
407Undefined top format called
408Unexpected constant lvalue entersub entry via type/targ %d:%d
6f6ac1de 409Unicode non-character 0x%04
87a63fff
JM
410Unknown PerlIO layer "scalar"
411Unknown Unicode option letter '%c'
87a63fff 412Unstable directory path, current directory changed unexpectedly
ee6ba15d
EB
413Unsupported script encoding UTF-16BE
414Unsupported script encoding UTF-16LE
415Unsupported script encoding UTF-32BE
416Unsupported script encoding UTF-32LE
87a63fff
JM
417Unterminated compressed integer in unpack
418Usage: CODE(0x%x)(%s)
419Usage: %s(%s)
420Usage: %s::%s(%s)
421Usage: VMS::Filespec::unixrealpath(spec)
422Usage: VMS::Filespec::vmsrealpath(spec)
423Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
424UTF-16 surrogate 0x%04
4a68bf9d 425utf8 "\x%02X" does not map to Unicode
87a63fff
JM
426Value of logical "%s" too long. Truncating to %i bytes
427value of node is %d in Offset macro
428Value of %s%s can be "0"; test with defined()
429Variable "%c%s" is not imported
430vector argument not supported with alpha versions
431Wide character
432Wide character in $/
433Wide character in print
434Wide character in %s
435Within []-length '%c' not allowed in %s
436Wrong syntax (suid) fd script name "%s"
437'X' outside of string in unpack