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