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