t/porting/diag.t

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