t/porting/diag.t

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