diag.t: Validate severity of ck warn routines better

In the case of Perl_ck_warner and other _ck_ functions, we can tell
whether it is a severe/default warning or no by the _d suffix (or the
presence of ‘dep’ in the name for regcomp.c’s ckWARN* functions).

This caught one incorrect severity in perldiag.pod, which is also cor-
rected here.

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index e5f12c3..ef69cd1 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -3862,7 +3862,7 @@ that a method requires a package that has not been loaded.
 =item Perl folding rules are not up-to-date for 0x%X; please use the perlbug 
 utility to report; in regex; marked by <-- HERE in m/%s/
 
-(W regexp, deprecated) You used a regular expression with
+(D regexp, deprecated) You used a regular expression with
 case-insensitive matching, and there is a bug in Perl in which the
 built-in regular expression folding rules are not accurate.  This may
 lead to incorrect results.  Please report this as a bug using the

diff --git a/t/porting/diag.t b/t/porting/diag.t
index 2d98b57..a37b338 100644 (file)
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -312,10 +312,17 @@ sub check_file {
       next;
     }
 
+    # Try to guess what the severity should be.  In the case of
+    # Perl_ck_warner and other _ck_ functions, we can tell whether it is
+    # a severe/default warning or no by the _d suffix.  In the case of
+    # other warn functions we cannot tell, because Perl_warner may be pre-
+    # ceded by if(ckWARN) or if(ckWARN_d).
     my $severity = !$routine                   ? '[PFX]'
                  :  $routine =~ /warn.*_d\z/   ? '[DS]'
+                 :  $routine =~ /ck_warn/      ?  'W'
                  :  $routine =~ /warn/         ? '[WDS]'
-                 :  $routine =~ /ckWARN\d*reg/ ? '[WDS]'
+                 :  $routine =~ /ckWARN.*dep/  ?  'D'
+                 :  $routine =~ /ckWARN\d*reg/ ?  'W'
                  :  $routine =~ /vWARN\d/      ? '[WDS]'
                  :                             '[PFX]';
     my $categories;
@@ -405,7 +412,9 @@ sub check_message {
           if $entries{$key}{cattodo};
 
         like $entries{$key}{severity}, $qr,
-          "severity is one of $severity for $key";
+          $severity =~ /\[/
+            ? "severity is one of $severity for $key"
+            : "severity is $severity for $key";
 
         is $entries{$key}{category}, $categories,
            ($categories ? "categories are [$categories]" : "no category")