This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove invalid version object from diag.t exceptions
[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 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 ";"
369 'j' not supported on this platform
370 'J' not supported on this platform
371 Layer does not match this perl
372 leaving effective gid failed
373 leaving effective uid failed
374 List form of piped open not implemented
375 Lost precision when decrementing %f by 1
376 Lost precision when incrementing %f by 1
377 %lx
378 Malformed UTF-16 surrogate
379 Malformed UTF-8 character (fatal)
380 '\%' may not be used in pack
381 Missing (suid) fd script name
382 More than one argument to open
383 More than one argument to open(,':%s')
384 mprotect for %p %d failed with %d
385 mprotect RW for %p %d failed with %d
386 No code specified for -%c
387 No directory specified for -I
388 No such class field "%s"
389 Not an XSUB reference
390 Not %s reference
391 Offset outside string
392 Opening dirhandle %s also as a file
393 Opening filehandle %s also as a directory
394 Operator or semicolon missing before %c%s
395 PERL_SIGNALS illegal: "%s"
396 Perl %s required (did you mean %s?)--this is only %s, stopped
397 Perl %s required--this is only %s, stopped
398 Perls since %s too modern--this is %s, stopped
399 Possible unintended interpolation of $\ in regex
400 ptr wrong %p != %p fl=%08
401 Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)
402 Recursive call to Perl_load_module in PerlIO_find_layer
403 refcnt_dec: fd %d < 0
404 refcnt_dec: fd %d: %d <= 0
405 refcnt_dec: fd %d >= refcnt_size %d
406 refcnt_inc: fd %d < 0
407 refcnt_inc: fd %d: %d <= 0
408 Reversed %c= operator
409 Runaway prototype
410 %s(%.0
411 %s(%.0f) failed
412 %s(%.0f) too large
413 Scalar value %s better written as $%s
414 %sCompilation failed in regexp
415 %sCompilation failed in require
416 set %s %p %p %p
417 %s free() ignored (RMAGIC, PERL_CORE)
418 %s has too many errors.
419 SIG%s handler "%s" not defined.
420 %s: illegal mapping '%s'
421 %s in %s
422 Size magic not implemented
423 %s limit (%d) exceeded
424 %s method "%s" overloading "%s" in package "%s"
425 %s number > %s non-portable
426 %s object version %s does not match %s%s%s%s %s
427 %srealloc() %signored
428 %s returned from lvalue subroutine in scalar context
429 %s%s has too many errors.
430 %s%s on %s %s
431 %s%s on %s %s %s
432 Starting Full Screen process with flag=%d, mytype=%d
433 Starting PM process with flag=%d, mytype=%d
434 strxfrm() gets absurd
435 SWASHNEW didn't return an HV ref
436 -T and -B not implemented on filehandles
437 The flock() function is not implemented on NetWare
438 The rewinddir() function is not implemented on NetWare
439 The seekdir() function is not implemented on NetWare
440 The stat preceding lstat() wasn't an lstat
441 The telldir() function is not implemented on NetWare
442 Too deeply nested ()-groups in %s
443 Too late to run CHECK block
444 Too late to run INIT block
445 Too many args on %s line of "%s"
446 U0 mode on a byte string
447 Unbalanced string table refcount: (%d) for "%s"
448 Undefined top format called
449 Unexpected constant lvalue entersub entry via type/targ %d:%d
450 Unicode non-character 0x%04
451 Unknown PerlIO layer "scalar"
452 Unknown Unicode option letter '%c'
453 Unstable directory path, current directory changed unexpectedly
454 Unsupported script encoding UTF-16BE
455 Unsupported script encoding UTF-16LE
456 Unsupported script encoding UTF-32BE
457 Unsupported script encoding UTF-32LE
458 Unterminated compressed integer in unpack
459 Usage: CODE(0x%x)(%s)
460 Usage: %s(%s)
461 Usage: %s::%s(%s)
462 Usage: VMS::Filespec::unixrealpath(spec)
463 Usage: VMS::Filespec::vmsrealpath(spec)
464 Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
465 UTF-16 surrogate 0x%04
466 utf8 "\x%02X" does not map to Unicode
467 Value of logical "%s" too long. Truncating to %i bytes
468 value of node is %d in Offset macro
469 Value of %s%s can be "0"; test with defined()
470 Variable "%c%s" is not imported
471 vector argument not supported with alpha versions
472 Wide character
473 Wide character in $/
474 Wide character in print
475 Wide character in %s
476 Within []-length '%c' not allowed in %s
477 Wrong syntax (suid) fd script name "%s"
478 'X' outside of string in unpack