warnings.pm - support deprecated::smartmatch category

Currently we seem to lack a way to have a subcategory under deprecated.
It seems reasonable to me that people might want to disable a specific
subcategory warning while leaving the rest in place. This patch allows
that. Note that both

    no warnings "deprecated";

and

    no warnings "deprecated::smartmatch";

work to disable the warning. Really this needs tests, but this will shut
up autodie warnings, so we can do the tests for this later. Also we
should go through and enumerate all the deprecated subcategories and
switch to using them. Deprecated warnings shouldn't be "all or nothing".
Again, I think that should happen after this is merged.

Author: demerphq

lib/warnings.pm

@@ -74,7 +74,9 @@ BEGIN
                                 'debugging'     => [ 5.008, DEFAULT_ON],
                                 'malloc'        => [ 5.008, DEFAULT_ON],
                            }],
-        'deprecated'    => [ 5.008, DEFAULT_ON],
+        'deprecated'    => [ 5.008, DEFAULT_ON, {
+                                'deprecated::smartmatch' => [ 5.037009, DEFAULT_ON],
+                        }],
         'void'          => [ 5.008, DEFAULT_OFF],
         'recursion'     => [ 5.008, DEFAULT_OFF],
         'redefine'      => [ 5.008, DEFAULT_OFF],
@@ -204,12 +206,12 @@ sub valueWalk
         die "Value associated with key '$k' is not an ARRAY reference"
             if !ref $v || ref $v ne 'ARRAY' ;
 
-        my ($ver, $rest) = @{ $v } ;
+        my ($ver, $rest, $rest2) = @{ $v } ;
+        my $ref = ref $rest ? $rest : $rest2;
         push @{ $v_list->{$ver} }, $k;
 
-        if (ref $rest)
-          { valueWalk ($rest, $v_list) }
-
+        if (ref $ref)
+          { valueWalk ($ref, $v_list) }
     }
 }
 
@@ -265,11 +267,12 @@ sub walk
         die "Value associated with key '$k' is not an ARRAY reference"
             if !ref $v || ref $v ne 'ARRAY' ;
 
-        my ($ver, $rest) = @{ $v } ;
-        if (ref $rest)
-          { push (@{ $CATEGORIES{$k} }, walk ($rest)) }
-        elsif ($rest == DEFAULT_ON)
+        my ($ver, $rest, $rest2) = @{ $v } ;
+        my $ref = ref $rest ? $rest : $rest2;
+        if (!ref $rest and $rest == DEFAULT_ON)
           { push @DEFAULTS, $NAME_TO_VALUE{uc $k} }
+        if (ref $ref)
+          { push (@{ $CATEGORIES{$k} }, walk ($ref)) }
 
         push @list, @{ $CATEGORIES{$k} } ;
     }
@@ -334,12 +337,13 @@ sub warningsTree
             $offset = ' ' x ($max + 1) ;
         }
 
-        my ($ver, $rest) = @{ $v } ;
-        if (ref $rest)
+        my ($ver, $rest, $rest2) = @{ $v } ;
+        my $ref = ref $rest ? $rest : $rest2;
+        if (ref $ref)
         {
             my $bar = @keys ? "|" : " ";
             $rv .= " -" . "-" x ($max - length $k ) . "+\n" ;
-            $rv .= warningsTree ($rest, $prefix . $bar . $offset )
+            $rv .= warningsTree ($ref, $prefix . $bar . $offset )
         }
         else
           { $rv .= "\n" }

regen/warnings.pl

@@ -6638,7 +6638,7 @@ yyl_tilde(pTHX_ char *s)
             TOKEN(0);
         s += 2;
         Perl_ck_warner_d(aTHX_
-            packWARN(WARN_DEPRECATED),
+            packWARN(WARN_DEPRECATED__SMARTMATCH),
             "Smartmatch is deprecated");
         NCEop(OP_SMARTMATCH);
     }
@@ -8179,7 +8179,7 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
 
     case KEY_given:
         pl_yylval.ival = CopLINE(PL_curcop);
-        Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+        Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED__SMARTMATCH),
                          "given is deprecated");
         OPERATOR(KW_GIVEN);
 
@@ -8702,7 +8702,7 @@ yyl_word_or_keyword(pTHX_ char *s, STRLEN len, I32 key, I32 orig_keyword, struct
             return REPORT(0);
         pl_yylval.ival = CopLINE(PL_curcop);
         Perl_ck_warner_d(aTHX_
-            packWARN(WARN_DEPRECATED),
+            packWARN(WARN_DEPRECATED__SMARTMATCH),
             "when is deprecated");
         OPERATOR(KW_WHEN);