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