From 2d705ed7705fa471fd9f9bf245b6ef87d3c65a50 Mon Sep 17 00:00:00 2001
From: Yves Orton <demerphq@gmail.com>
Date: Sat, 25 Feb 2023 15:21:14 +0100
Subject: [PATCH] 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.
---
 lib/warnings.pm   | 17 ++++++++++++-----
 pod/perldiag.pod  |  6 +++---
 regen/warnings.pl | 28 ++++++++++++++++------------
 toke.c            |  6 +++---
 warnings.h        |  5 +++++
 5 files changed, 39 insertions(+), 23 deletions(-)

diff --git a/lib/warnings.pm b/lib/warnings.pm
index 2dd9eccb513a..083dbb4fca48 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -112,6 +112,9 @@ our %Offsets = (
 
     # Warnings Categories added in Perl 5.037
     'experimental::class'		=> 144,
+
+    # Warnings Categories added in Perl 5.037009
+    'deprecated::smartmatch'		=> 146,
 );
 
 our %Bits = (
@@ -121,7 +124,8 @@ our %Bits = (
     'closed'				=> "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
     'closure'				=> "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
     'debugging'				=> "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
-    'deprecated'			=> "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+    'deprecated'			=> "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [2,73]
+    'deprecated::smartmatch'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [73]
     'digit'				=> "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
     'exec'				=> "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'				=> "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
@@ -197,7 +201,8 @@ our %DeadBits = (
     'closed'				=> "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
     'closure'				=> "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
     'debugging'				=> "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [22]
-    'deprecated'			=> "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
+    'deprecated'			=> "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [2,73]
+    'deprecated::smartmatch'		=> "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [73]
     'digit'				=> "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [31]
     'exec'				=> "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
     'exiting'				=> "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
@@ -279,8 +284,8 @@ our %NoOp = (
 
 # These are used by various things, including our own tests
 our $NONE				=  "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0";
-our $DEFAULT				=  "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x50\x05\x51\x55\x15\x01"; # [2,4,22,23,25,54..57,60,62..70,72]
-our $LAST_BIT				=  146 ;
+our $DEFAULT				=  "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00\x50\x05\x51\x55\x15\x05"; # [2,4,22,23,25,54..57,60,62..70,72,73]
+our $LAST_BIT				=  148 ;
 our $BYTES				=  19 ;
 
 sub Croaker
@@ -881,7 +886,9 @@ The current hierarchy is:
          |
          +- closure
          |
-         +- deprecated
+         +- deprecated ----+
+         |                 |
+         |                 +- deprecated::smartmatch
          |
          +- exiting
          |
diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index d774e3537c8d..9d88c485c4dd 100644
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -2645,7 +2645,7 @@ L<perlfunc/getsockopt>.
 
 =item given is deprecated
 
-(D deprecated) C<given> depends on smartmatch, which is deprecated. It
+(D deprecated::smartmatch) C<given> depends on smartmatch, which is deprecated. It
 will be removed in Perl 5.42.  See the explanation under
 L<perlsyn/Experimental Details on given and when>.
 
@@ -6039,7 +6039,7 @@ for the smart match.
 
 =item Smartmatch is deprecated
 
-(D deprecated) This warning is emitted if you
+(D deprecated::smartmatch) This warning is emitted if you
 use the smartmatch (C<~~>) operator.  This is a deprecated
 feature.  Particularly, its behavior is noticed for being
 unnecessarily complex and unintuitive, and it will be removed
@@ -8025,7 +8025,7 @@ So put in parentheses to say what you really mean.
 
 =item when is deprecated
 
-(D deprecated) C<when> depends on smartmatch, which is
+(D deprecated::smartmatch) C<when> depends on smartmatch, which is
 deprecated.  Additionally, it has several special cases that may
 not be immediately obvious, and it will be removed in Perl 5.42.
 See the explanation
diff --git a/regen/warnings.pl b/regen/warnings.pl
index c2621363ba50..068d42c37fb7 100644
--- a/regen/warnings.pl
+++ b/regen/warnings.pl
@@ -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" }
diff --git a/toke.c b/toke.c
index 768630481aec..d02bcd07849c 100644
--- a/toke.c
+++ b/toke.c
@@ -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);
 
diff --git a/warnings.h b/warnings.h
index 613c8fb33f78..ef8984d7e376 100644
--- a/warnings.h
+++ b/warnings.h
@@ -134,6 +134,10 @@
 /* Warnings Categories added in Perl 5.037 */
 
 #define WARN_EXPERIMENTAL__CLASS	 72
+
+/* Warnings Categories added in Perl 5.037009 */
+
+#define WARN_DEPRECATED__SMARTMATCH	 73
 #define WARNsize			 19
 #define WARN_ALLstring			 "\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125\125"
 #define WARN_NONEstring			 "\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
@@ -321,6 +325,7 @@ category parameters passed.
 =for apidoc Amnh||WARN_EXPERIMENTAL__FOR_LIST
 =for apidoc Amnh||WARN_SCALAR
 =for apidoc Amnh||WARN_EXPERIMENTAL__CLASS
+=for apidoc Amnh||WARN_DEPRECATED__SMARTMATCH
 
 =cut
 */