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