1#!/usr/bin/perl 2use warnings; 3use strict; 4 5require './test.pl'; 6 7plan('no_plan'); 8 9$|=1; 10 11my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list'; 12 13chdir '..' or die "Can't chdir ..: $!"; 14BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; } 15 16open my $diagfh, "<", "pod/perldiag.pod" 17 or die "Can't open pod/perldiag.pod: $!"; 18 19my %entries; 20while (<DATA>) { 21 chomp; 22 $entries{$_}{todo}=1; 23} 24 25my $cur_entry; 26while (<$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 38my @todo = <*>; 39while (@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 51sub 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__ 185Ambiguous call resolved as CORE::%s(), %s 186Ambiguous use of %c resolved as operator %c 187Ambiguous use of %c{%s} resolved to %c%s 188Ambiguous use of %c{%s%s} resolved to %c%s%s 189Ambiguous use of -%s resolved as -&%s() 190Argument "%s" isn't numeric 191Argument "%s" isn't numeric in %s 192Attempt to clear deleted array 193Attempt to free non-arena SV: 0x%x 194Attempt to free non-existent shared string '%s'%s 195Attempt to free temp prematurely: SV 0x%x 196Attempt to free unreferenced scalar: SV 0x%x 197Attempt to reload %s aborted. Compilation failed in require 198av_reify called on tied array 199Bad name after %s%s 200Bad symbol for %s 201bad top format reference 202Bizarre copy of %s 203Bizarre SvTYPE [%d] 204Cannot copy to %s 205Can't call method "%s" %s 206Can't coerce readonly %s to string 207Can't coerce readonly %s to string in %s 208Can't fix broken locale name "%s" 209Can't get short module name from a handle 210Can't goto subroutine from an eval-block 211Can't goto subroutine from an eval-string 212Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?) 213Can't modify non-existent substring 214Can't open 215Can't open perl script "%s": %s 216Can't open %s 217Can't reset \%ENV on this system 218Can't return array to lvalue scalar context 219Can't return a %s from lvalue subroutine 220Can't return hash to lvalue scalar context 221Can't spawn "%s": %s 222Can't %s script `%s' with ARGV[0] being `%s' 223Can't %s "%s": %s 224Can't %s %s%s%s 225Can't %s `%s' with ARGV[0] being `%s' (looking for executables only, not found) 226Can't take %s of %f 227Can't use '%c' after -mname 228Can't use string ("%s"%s) as a subroutine ref while "strict refs" in use 229Can't use \\%c to mean $%c in expression 230Can't use when() outside a topicalizer 231\\%c better written as $%c 232Character(s) in '%c' format wrapped in %s 233$%c is no longer supported 234Cloning substitution context is unimplemented 235Code missing after '/' in pack 236Code missing after '/' in unpack 237Compilation failed in require 238Corrupted regexp opcode %d > %d 239'%c' outside of string in pack 240Debug leaking scalars child failed%s%s with errno %d: %s 241Deep recursion on anonymous subroutine 242defined(\%hash) is deprecated 243Don't know how to handle magic of type \\%o 244-Dp not implemented on this platform 245entering effective gid failed 246entering effective uid failed 247Error reading "%s": %s 248Exiting %s via %s 249Filehandle opened only for %sput 250Filehandle %s opened only for %sput 251Filehandle STD%s reopened as %s only for input 252YOU 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! 253Format STDOUT redefined 254Free to wrong pool %p not %p 255get %s %p %p %p 256glob failed (can't start child: %s) 257glob failed (child exited with status %d%s) 258Goto undefined subroutine 259Goto undefined subroutine &%s 260Hash \%%s missing the \% in argument %d of %s() 261Illegal character \\%03o (carriage return) 262Illegal character %sin prototype for %s : %s 263Integer overflow in decimal number 264Integer overflow in version %d 265internal \%<num>p might conflict with future printf extensions 266invalid control request: '\\%03o' 267Invalid module name %s with -%c option: contains single ':' 268invalid option -D%c, use -D'' to see choices 269Invalid range "%c-%c" in transliteration operator 270Invalid separator character %c%c%c in PerlIO layer specification %s 271Invalid TOKEN object ignored 272Invalid type '%c' in pack 273Invalid type '%c' in %s 274Invalid type '%c' in unpack 275Invalid type ',' in %s 276Invalid strict version format (0 before decimal required) 277Invalid strict version format (no leading zeros) 278Invalid strict version format (no underscores) 279Invalid strict version format (v1.2.3 required) 280Invalid strict version format (version required) 281Invalid strict version format (1.[0-9] required) 282Invalid version format (alpha without decimal) 283Invalid version format (misplaced _ in number) 284Invalid version object 285'j' not supported on this platform 286'J' not supported on this platform 287Layer does not match this perl 288leaving effective gid failed 289leaving effective uid failed 290List form of piped open not implemented 291Lost precision when decrementing %f by 1 292Lost precision when incrementing %f by 1 293%lx 294Malformed UTF-16 surrogate 295Malformed UTF-8 character (fatal) 296'\%' may not be used in pack 297Missing (suid) fd script name 298More than one argument to open 299More than one argument to open(,':%s') 300mprotect for %p %d failed with %d 301mprotect RW for %p %d failed with %d 302No code specified for -%c 303No directory specified for -I 304No such class field "%s" 305Not an XSUB reference 306Not %s reference 307Offset outside string 308Opening dirhandle %s also as a file 309Opening filehandle %s also as a directory 310Operator or semicolon missing before %c%s 311PERL_SIGNALS illegal: "%s" 312Perl %s required (did you mean %s?)--this is only %s, stopped 313Perl %s required--this is only %s, stopped 314Perls since %s too modern--this is %s, stopped 315Possible unintended interpolation of $\\ in regex 316ptr wrong %p != %p fl=%08 317Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?) 318Recursive call to Perl_load_module in PerlIO_find_layer 319refcnt_dec: fd %d < 0 320refcnt_dec: fd %d: %d <= 0 321refcnt_dec: fd %d >= refcnt_size %d 322refcnt_inc: fd %d < 0 323refcnt_inc: fd %d: %d <= 0 324Reversed %c= operator 325Runaway prototype 326%s(%.0f) failed 327%s(%.0f) too large 328Scalar value %s better written as $%s 329%sCompilation failed in regexp 330%sCompilation failed in require 331set %s %p %p %p 332%s free() ignored (RMAGIC, PERL_CORE) 333%s has too many errors. 334SIG%s handler "%s" not defined. 335%s: illegal mapping '%s' 336%s in %s 337Size 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 347Starting Full Screen process with flag=%d, mytype=%d 348Starting PM process with flag=%d, mytype=%d 349strxfrm() gets absurd 350SWASHNEW didn't return an HV ref 351-T and -B not implemented on filehandles 352The flock() function is not implemented on NetWare 353The rewinddir() function is not implemented on NetWare 354The seekdir() function is not implemented on NetWare 355The stat preceding lstat() wasn't an lstat 356The telldir() function is not implemented on NetWare 357Too deeply nested ()-groups in %s 358Too late to run CHECK block 359Too late to run INIT block 360Too many args on %s line of "%s" 361U0 mode on a byte string 362Unbalanced string table refcount: (%d) for "%s" 363Undefined top format called 364Unexpected constant lvalue entersub entry via type/targ %d:%d 365Unicode non-character 0x%04 366Unknown PerlIO layer "scalar" 367Unknown Unicode option letter '%c' 368unrecognised control character '%c' 369Unstable directory path, current directory changed unexpectedly 370Unsupported script encoding UTF-16BE 371Unsupported script encoding UTF-16LE 372Unsupported script encoding UTF-32BE 373Unsupported script encoding UTF-32LE 374Unterminated compressed integer in unpack 375Usage: CODE(0x%x)(%s) 376Usage: %s(%s) 377Usage: %s::%s(%s) 378Usage: VMS::Filespec::unixrealpath(spec) 379Usage: VMS::Filespec::vmsrealpath(spec) 380Use of inherited AUTOLOAD for non-method %s::%s() is deprecated 381UTF-16 surrogate 0x%04 382utf8 "\\x%02X" does not map to Unicode 383Value of logical "%s" too long. Truncating to %i bytes 384value of node is %d in Offset macro 385Value of %s%s can be "0"; test with defined() 386Variable "%c%s" is not imported 387vector argument not supported with alpha versions 388Wide character 389Wide character in $/ 390Wide character in print 391Wide character in %s 392Within []-length '%c' not allowed in %s 393Wrong syntax (suid) fd script name "%s" 394'X' outside of string in unpack 395