PATCH: teach diag.t new warning function names

A number of function names that do warnings have been added, but diag.t
hasn't kept up.

This patch changes it to look for likely function names in embed.fnc, so
it will automatically keep up in the future.  There's no need to worry
about it looking for inappropriate functions, as the syntax of messages
that it looks for is so restrictive, that there won't be false
positives.  Instead there are still many messages it fails to catch.

As a result of it's falling behind several issues have crept in.  I
resolved the couple I thought were clear (including one in a comment;
diag.t doesn't strip comments, but mostly it doesn't matter), and added
the others to the <DATA> section to ignore.
are

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 8bb0f85..4d7d6ad 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -1711,7 +1711,7 @@ in your false range is interpreted as a literal "-".  Consider quoting the
 "-", "\-".  The <-- HERE shows in the regular expression about where the
 problem was discovered.  See L<perlre>.
 
-=item Fatal VMS error at %s, line %d
+=item Fatal VMS error (status=%d) at %s, line %d
 
 (P) An error peculiar to VMS.  Something untoward happened in a VMS
 system service or RTL routine; Perl's exit status should provide more

diff --git a/t/porting/diag.t b/t/porting/diag.t
old mode 100644 (file)
new mode 100755 (executable)
index 11bbca0..daec293
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -13,16 +13,50 @@ my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list';
 chdir '..' or die "Can't chdir ..: $!";
 BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; }
 
-open my $diagfh, "<", "pod/perldiag.pod"
-  or die "Can't open pod/perldiag.pod: $!";
+my @functions;
+
+open my $func_fh, "<", "embed.fnc" or die "Can't open embed.fnc: $!";
+
+# Look for functions in embed.fnc that look like they could be diagnostic ones.
+while (<$func_fh>) {
+  chomp;
+  s/^\s+//;
+  while (s/\s*\\$//) {      # Grab up all continuation lines, these end in \
+    my $next = <$func_fh>;
+    $next =~ s/^\s+//;
+    chomp $next;
+    $_ .= $next;
+  }
+  next if /^:/;     # Lines beginning with colon are comments.
+  next unless /\|/; # Lines without a vertical bar are something we can't deal
+                    # with
+  my @fields = split /\s*\|\s*/;
+  next unless $fields[2] =~ /warn|err|(\b|_)die|croak/i;
+  push @functions, $fields[2];
+
+  # The flag p means that this function may have a 'Perl_' prefix
+  # The flag s means that this function may have a 'S_' prefix
+  push @functions, "Perl_$fields[2]", if $fields[0] =~ /p/;
+  push @functions, "S_$fields[2]", if $fields[0] =~ /s/;
+}
+
+close $func_fh;
+
+my $function_re = join '|', @functions;
+my $source_msg_re = qr/(?<routine>\bDIE\b|$function_re)/;
 
 my %entries;
+
+# Get the ignores that are compiled into this file
 while (<DATA>) {
   chomp;
   $entries{$_}{todo}=1;
 }
 
 my $cur_entry;
+open my $diagfh, "<", "pod/perldiag.pod"
+  or die "Can't open pod/perldiag.pod: $!";
+
 while (<$diagfh>) {
   if (m/^=item (.*)/) {
     $cur_entry = $1;
@@ -35,6 +69,7 @@ while (<$diagfh>) {
   }
 }
 
+# Recursively descend looking for source files.
 my @todo = <*>;
 while (@todo) {
   my $todo = shift @todo;
@@ -74,7 +109,9 @@ sub check_file {
     }
     next if /^#/;
     next if /^ * /;
-    while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) {
+
+    # Loop to accumulate the message text all on one line.
+    while (m/$source_msg_re/ 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
@@ -108,27 +145,28 @@ sub check_file {
       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*
+    if (m/$source_msg_re(?:_nocontext)? \s*
           \(aTHX_ \s*
-          (?:packWARN\d*\((.*?)\),)? \s*
-          "((?:\\"|[^"])*?)"/x) {
-      # diag($_);
-      # DIE is just return Perl_die
-      my $severity = {croak => [qw/P F/],
+          (?:packWARN\d*\((?<category>.*?)\),)? \s*
+          "(?<text>(?:\\"|[^"])*?)"/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 == $.) {
+                     }->{$+{'routine'}||'die'};
+    my @categories;
+    if ($+{'category'}) {
+        @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $+{'category'};
+    }
+    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.
+    } else {
+        $name = $+{'text'};
+        # 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;
@@ -155,7 +193,7 @@ sub check_file {
       if (exists $entries{$name}) {
         if ($entries{$name}{todo}) {
         TODO: {
-           no warnings 'once';
+            no warnings 'once';
             local $::TODO = 'in DATA';
             fail("Presence of '$name' from $codefn line $.");
           }
@@ -261,7 +299,10 @@ Goto undefined subroutine &%s
 Hash \%%s missing the \% in argument %d of %s()
 Illegal character \%03o (carriage return)
 Illegal character %sin prototype for %s : %s
+Integer overflow in binary number
 Integer overflow in decimal number
+Integer overflow in hexadecimal number
+Integer overflow in octal number
 Integer overflow in version %d
 internal \%<num>p might conflict with future printf extensions
 invalid control request: '\%03o'
@@ -325,6 +366,7 @@ refcnt_inc: fd %d < 0
 refcnt_inc: fd %d: %d <= 0
 Reversed %c= operator
 Runaway prototype
+%s(%.0
 %s(%.0f) failed
 %s(%.0f) too large
 Scalar value %s better written as $%s

diff --git a/universal.c b/universal.c
index dec8505..3df8321 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -218,7 +218,7 @@ A specialised variant of C<croak()> for emitting the usage message for xsubs
 works out the package name and subroutine name from C<cv>, and then calls
 C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
 
-    Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
+    Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow");
 
 =cut
 */