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