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