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