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).

8 files changed, 191 insertions, 18 deletions

diff --git a/doio.c b/doio.c
index 8a12268474..7be7af1142 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 549d672a2a..24e11c19bf 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 05a5092b25..5cfa8cb920 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 748888704c..03fe906bb0 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 4f4130e40f..5b221fa90b 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 9f13d6e113..0b3dc3b064 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<exec> function is not implemented in MacPerl. See L<perlport>.
 
-=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<perlfunc/goto>.
 supposed to follow something: a template character or a ()-group.
  See L<perlfunc/pack>.
 
-=item %s had compilation errors
+=item %s had compilation errors.
 
 (F) The final summary message when a C<perl -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<perlrun> 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<open> 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<perl -n -T> to C<perl -T -n>.
+editing the #! line so that the B<-%c> option is a part of Perl's first
+argument: e.g. change C<perl -n -%c> to C<perl -%c -n>.
 
 If the Perl script is being executed as C<perl scriptname>, then the
-B<-T> option must appear on the command line: C<perl -T scriptname>.
+B<-%c> option must appear on the command line: C<perl -%c scriptname>.
 
 =item To%s: illegal mapping '%s'
 
diff --git a/sv.c b/sv.c
index 7de171dbff..bb4df7a46d 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 0000000000..ee562b24f4
--- /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</\* diag_listed_as: (.*) \*/>) {
+      $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 =~ /%$/;
+    }
+  }
+}