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