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