From: James Mastros Date: Sat, 6 Jun 2009 19:46:21 +0000 (+0100) Subject: Add test to make sure everything that outputs an exception or warning has a matching... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=fe13d51d6409065a0214793b416a2eb3fe209949;p=p5sagit%2Fp5-mst-13.2.git Add test to make sure everything that outputs an exception or warning has a matching entry in perldiag (and fix it so that more of the existing ones do). --- diff --git a/doio.c b/doio.c index 8a12268..7be7af1 100644 --- a/doio.c +++ b/doio.c @@ -312,6 +312,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, else { PerlIO *that_fp = NULL; if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ Perl_croak(aTHX_ "More than one argument to '%c&' open",IoTYPE(io)); } while (isSPACE(*type)) @@ -398,6 +399,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, fp = PerlIO_stdout(); IoTYPE(io) = IoTYPE_STD; if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ Perl_croak(aTHX_ "More than one argument to '>%c' open",IoTYPE_STD); } } @@ -431,6 +433,7 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, fp = PerlIO_stdin(); IoTYPE(io) = IoTYPE_STD; if (num_svs > 1) { + /* diag_listed_as: More than one argument to '%s' open */ Perl_croak(aTHX_ "More than one argument to '<%c' open",IoTYPE_STD); } } @@ -1997,6 +2000,7 @@ Perl_do_ipcget(pTHX_ I32 optype, SV **mark, SV **sp) #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: + /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } @@ -2057,12 +2061,14 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) than guessing about u_?short(_t)? */ } #else + /* diag_listed_as: sem%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif break; #endif #if !defined(HAS_MSG) || !defined(HAS_SEM) || !defined(HAS_SHM) default: + /* diag_listed_as: shm%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } @@ -2110,6 +2116,7 @@ Perl_do_ipcctl(pTHX_ I32 optype, SV **mark, SV **sp) #endif ret = Semctl(id, n, cmd, unsemds); #else + /* diag_listed_as: sem%s not implemented */ Perl_croak(aTHX_ "%s not implemented", PL_op_desc[optype]); #endif } @@ -2151,6 +2158,7 @@ Perl_do_msgsnd(pTHX_ SV **mark, SV **sp) #else PERL_UNUSED_ARG(sp); PERL_UNUSED_ARG(mark); + /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "msgsnd not implemented"); #endif } @@ -2192,6 +2200,7 @@ Perl_do_msgrcv(pTHX_ SV **mark, SV **sp) #else PERL_UNUSED_ARG(sp); PERL_UNUSED_ARG(mark); + /* diag_listed_as: msg%s not implemented */ Perl_croak(aTHX_ "msgrcv not implemented"); #endif } @@ -2246,6 +2255,7 @@ Perl_do_semop(pTHX_ SV **mark, SV **sp) return result; } #else + /* diag_listed_as: sem%s not implemented */ Perl_croak(aTHX_ "semop not implemented"); #endif } @@ -2304,6 +2314,7 @@ Perl_do_shmio(pTHX_ I32 optype, SV **mark, SV **sp) } return shmdt(shm); #else + /* diag_listed_as: shm%s not implemented */ Perl_croak(aTHX_ "shm I/O not implemented"); #endif } diff --git a/gv.c b/gv.c index 549d672..24e11c1 100644 --- a/gv.c +++ b/gv.c @@ -99,6 +99,7 @@ Perl_gv_IOadd(pTHX_ register GV *gv) PL_op->op_type == OP_REWINDDIR || PL_op->op_type == OP_CLOSEDIR ? "dirhandle" : "filehandle"; + /* diag_listed_as: Bad symbol for filehandle */ Perl_croak(aTHX_ "Bad symbol for %s", fh); } @@ -1087,6 +1088,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, (sv_type == SVt_PVAV && !GvIMPORTED_AV(*gvp)) || (sv_type == SVt_PVHV && !GvIMPORTED_HV(*gvp)) ) { + /* diag_listed_as: Variable "%s" is not imported%s */ Perl_warn(aTHX_ "Variable \"%c%s\" is not imported", sv_type == SVt_PVAV ? '@' : sv_type == SVt_PVHV ? '%' : '$', diff --git a/mg.c b/mg.c index 05a5092..5cfa8cb 100644 --- a/mg.c +++ b/mg.c @@ -1331,7 +1331,7 @@ Perl_csighandler(int sig) #ifndef SIG_PENDING_DIE_COUNT # define SIG_PENDING_DIE_COUNT 120 #endif - /* And one to say _a_ signal is pending */ + /* Add one to say _a_ signal is pending */ if (++PL_sig_pending >= SIG_PENDING_DIE_COUNT) Perl_croak(aTHX_ "Maximal count of pending signals (%lu) exceeded", (unsigned long)SIG_PENDING_DIE_COUNT); diff --git a/op.c b/op.c index 7488887..03fe906 100644 --- a/op.c +++ b/op.c @@ -3857,7 +3857,7 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) SV *meth; if (version->op_type != OP_CONST || !SvNIOKp(vesv)) - Perl_croak(aTHX_ "Version number must be constant number"); + Perl_croak(aTHX_ "Version number must be a constant number"); /* Make copy of idop so we don't free it twice */ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv)); @@ -8961,6 +8961,7 @@ const_sv_xsub(pTHX_ CV* cv) if (items != 0) { NOOP; #if 0 + /* diag_listed_as: SKIPME */ Perl_croak(aTHX_ "usage: %s::%s()", HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv))); #endif diff --git a/perl.h b/perl.h index 4f4130e..5b221fa 100644 --- a/perl.h +++ b/perl.h @@ -1027,6 +1027,7 @@ EXTERN_C int usleep(unsigned int); # define MALLOC_CHECK_TAINT(argc,argv,env) #endif /* MYMALLOC */ +/* diag_listed_as: "-T" is on the #! line, it must also be used on the command line */ #define TOO_LATE_FOR_(ch,what) Perl_croak(aTHX_ "\"-%c\" is on the #! line, it must also be used on the command line%s", (char)(ch), what) #define TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, "") #define MALLOC_TOO_LATE_FOR(ch) TOO_LATE_FOR_(ch, " with $ENV{PERL_MALLOC_OPT}") diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 9f13d6e..0b3dc3b 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -320,7 +320,7 @@ attribute on a array, hash or scalar reference. The :unique attribute is has had no no effect since Perl 5.8.8, and will be removed in the next major release of Perl 5. -=item Bad arg length for %s, is %d, should be %s +=item Bad arg length for %s, is %d, should be %d (F) You passed a buffer of the wrong size to one of msgctl(), semctl() or shmctl(). In C parlance, the correct sizes are, respectively, @@ -1032,7 +1032,7 @@ probably because you don't have write permission to the directory. (P) An error peculiar to VMS. Perl thought stdin was a pipe, and tried to reopen it to accept binary data. Alas, it failed. -=item Can't resolve method `%s' overloading `%s' in package `%s' +=item Can't resolve method "%s" overloading "%s" in package "%s" (F|P) Error resolving overloading specified by a method name (as opposed to a subroutine reference): no such method callable via the package. If @@ -1618,7 +1618,7 @@ variable and glob that. (F) The C function is not implemented in MacPerl. See L. -=item Execution of %s aborted due to compilation errors +=item Execution of %s aborted due to compilation errors. (F) The final summary message when a Perl compilation fails. @@ -1842,7 +1842,7 @@ unspecified destination. See L. supposed to follow something: a template character or a ()-group. See L. -=item %s had compilation errors +=item %s had compilation errors. (F) The final summary message when a C fails. @@ -1945,7 +1945,7 @@ two from 1 to 32 (or 64, if your platform supports that). (W digit) You may have tried to use an 8 or 9 in an octal number. Interpretation of the octal number stopped before the 8 or 9. -=item Illegal switch in PERL5OPT: %s +=item Illegal switch in PERL5OPT: -%c (X) The PERL5OPT environment variable may only be used to set the following switches: B<-[CDIMUdmtw]>. @@ -2167,7 +2167,7 @@ strange for a machine that supports C. (W unopened) You tried ioctl() on a filehandle that was never opened. Check you control flow and number of arguments. -=item IO layers (like "%s") unavailable +=item IO layers (like '%s') unavailable (F) Your Perl has not been configured to have PerlIO, and therefore you cannot use IO layers. To have PerlIO Perl must be configured @@ -2333,9 +2333,9 @@ rules and perl was unable to guess how to make more progress. (F) You tried to unpack something that didn't comply with UTF-8 encoding rules and perl was unable to guess how to make more progress. -=item Maximal count of pending signals (%s) exceeded +=item Maximal count of pending signals (%d) exceeded -(F) Perl aborted due to a too important number of signals pending. This +(F) Perl aborted due to a too high number of signals pending. This usually indicates that your operating system tried to deliver signals too fast (with a very high priority), starving the perl process from resources it would need to reach a point where it can process signals @@ -2478,7 +2478,7 @@ couldn't be created for some peculiar reason. you omitted the name of the module. Consult L for full details about C<-M> and C<-m>. -=item More than one argument to open +=item More than one argument to '%s' open (F) The C function has been asked to open multiple files. This can happen if you are trying to open a pipe to a command that takes a @@ -3943,7 +3943,7 @@ a block by itself. (W unopened) You tried to use the stat() function on a filehandle that was either never opened or has since been closed. -=item Stub found while resolving method "%s" overloading "%s" +=item Stub found while resolving method "%s" overloading "%s" in package "%s" (P) Overloading resolution over @ISA tree may be broken by importation stubs. Stubs should never be implicitly created, but explicit calls to @@ -4154,18 +4154,18 @@ suspect you're not running on Unix. =item "-T" is on the #! line, it must also be used on the command line (X) The #! line (or local equivalent) in a Perl script contains the -B<-T> option, but Perl was not invoked with B<-T> in its command line. +B<-T> option (or the B<-t> option), but Perl was not invoked with B<-T> in its command line. This is an error because, by the time Perl discovers a B<-T> in a script, it's too late to properly taint everything from the environment. So Perl gives up. If the Perl script is being executed as a command using the #! mechanism (or its local equivalent), this error can usually be fixed by -editing the #! line so that the B<-T> option is a part of Perl's first -argument: e.g. change C to C. +editing the #! line so that the B<-%c> option is a part of Perl's first +argument: e.g. change C to C. If the Perl script is being executed as C, then the -B<-T> option must appear on the command line: C. +B<-%c> option must appear on the command line: C. =item To%s: illegal mapping '%s' diff --git a/sv.c b/sv.c index 7de171d..bb4df7a 100644 --- a/sv.c +++ b/sv.c @@ -5518,8 +5518,8 @@ Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv) SV_CHECK_THINKFIRST_COW_DROP(sv); if (SvREFCNT(nsv) != 1) { - Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%" - UVuf " != 1)", (UV) SvREFCNT(nsv)); + Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" + " (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); } if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) diff --git a/t/pod/diag.t b/t/pod/diag.t new file mode 100644 index 0000000..ee562b2 --- /dev/null +++ b/t/pod/diag.t @@ -0,0 +1,158 @@ +#!/usr/bin/perl +use warnings; +use strict; +use Test::More 'no_plan'; +$|=1; + +open my $diagfh, "<:raw", "pod/perldiag.pod" + or die "Can't open pod/perldiag.pod: $!"; + +my %entries; +my $cur_entry; +while (<$diagfh>) { + if (m/^=item (.*)/) { + $cur_entry = $1; + } elsif (m/^\((.)(?: ([a-z]+?))?\)/ and !$entries{$cur_entry}{severity}) { + $entries{$cur_entry}{severity} = $1; + $entries{$cur_entry}{category} = $2; + } +} + +my @todo = ('.'); +while (@todo) { + my $todo = shift @todo; + next if $todo ~~ ['./t', './lib', './ext']; + # opmini.c is just a copy of op.c, so there's no need to check again. + next if $todo eq './opmini.c'; + if (-d $todo) { + push @todo, glob "$todo/*"; + } elsif ($todo =~ m/\.(c|h)$/) { + check_file($todo); + } +} + +sub check_file { + my ($codefn) = @_; + + diag($codefn); + + open my $codefh, "<:raw", $codefn + or die "Can't open $codefn: $!"; + + my $listed_as; + my $listed_as_line; + my $sub = 'top of file'; + while (<$codefh>) { + chomp; + # Getting too much here isn't a problem; we only use this to skip + # errors inside of XS modules, which should get documented in the + # docs for the module. + if (m<^([^#\s].*)> and $1 !~ m/^[{}]*$/) { + $sub = $1; + } + next if $sub =~ m/^XS/; + if (m) { + $listed_as = $1; + $listed_as_line = $.+1; + } + next if /^#/; + next if /^ * /; + while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) { + my $nextline = <$codefh>; + # Means we fell off the end of the file. Not terribly surprising; + # this code tries to merge a lot of things that aren't regular C + # code (preprocessor stuff, long comments). That's OK; we don't + # need those anyway. + last if not defined $nextline; + chomp $nextline; + $nextline =~ s/^\s+//; + # Note that we only want to do this where *both* are true. + $_ =~ s/\\$//; + if ($_ =~ m/"$/ and $nextline =~ m/^"/) { + $_ =~ s/"$//; + $nextline =~ s/^"//; + } + $_ = "$_$nextline"; + } + # This should happen *after* unwrapping, or we don't reformat the things + # in later lines. + # List from perlguts.pod "Formatted Printing of IVs, UVs, and NVs" + my %specialformats = (IVdf => 'd', + UVuf => 'd', + UVof => 'o', + UVxf => 'x', + UVXf => 'X', + NVef => 'f', + NVff => 'f', + NVgf => 'f', + SVf => 's'); + for my $from (keys %specialformats) { + s/%"\s*$from\s*"/\%$specialformats{$from}/g; + s/%"\s*$from/\%$specialformats{$from}"/g; + } + # The %"foo" thing needs to happen *before* this regex. + if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s* + \(aTHX_ \s* + (?:packWARN\d*\((.*?)\),)? \s* + "((?:\\"|[^"])*?)"/x) { + # diag($_); + # DIE is just return Perl_die + my $severity = {croak => [qw/P F/], + die => [qw/P F/], + warn => [qw/W D S/], + }->{$1||'die'}; + my @categories; + if ($2) { + @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2; + } + my $name; + if ($listed_as and $listed_as_line == $.) { + $name = $listed_as; + } else { + $name = $3; + # The form listed in perldiag ignores most sorts of fancy printf formatting, + # or makes it more perlish. + $name =~ s/%%/\\%/g; + $name =~ s/%l[ud]/%d/g; + $name =~ s/%\.(\d+|\*)s/\%s/g; + $name =~ s/\\"/"/g; + $name =~ s/\\t/\t/g; + $name =~ s/\\n/\n/g; + $name =~ s/\n$//; + } + + # Extra explanitory info on an already-listed error, doesn't need it's own listing. + next if $name =~ m/^\t/; + + # Happens fairly often with PL_no_modify. + next if $name eq '%s'; + + # Special syntax for magic comment, allows ignoring the fact that it isn't listed. + # Only use in very special circumstances, like this script failing to notice that + # the Perl_croak call is inside an #if 0 block. + next if $name eq 'SKIPME'; + + if (!exists $entries{$name}) { + if ($name =~ m/^panic: /) { + # Just too many panic:s, they are hard to diagnose, and there is a generic "panic: %s" entry. + # Leave these for another pass. + ok("Presence of '$name' from $codefn line $., covered by panic: %s entry"); + } else { + fail("Presence of '$name' from $codefn line $."); + } + } else { + ok("Presence of '$name' from $codefn line $."); + # Commented: "substr outside of string" has is either a warning + # or an error, depending how much was outside. + # Also, plenty of failures without forcing further hardship... +# if ($entries{$name} and !($entries{$name}{severity} ~~ $severity)) { +# fail("Severity for '$name' from $codefn line $.: got $entries{$name}{severity}, expected $severity"); +# } else { +# ok("Severity for '$name' from $codefn line $.: got $entries{$name}{severity}, expected $severity"); +# } + } + + die if $name =~ /%$/; + } + } +}