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