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