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