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