From 49d74bb61561b9052d5dbe47b55cac1b59a8cecc Mon Sep 17 00:00:00 2001
From: "Paul \"LeoNerd\" Evans" <leonerd@leonerd.org.uk>
Date: Mon, 24 Jan 2022 13:40:05 +0000
Subject: [PATCH] Better handling of &SUB so as not to warn on \&SUB

---
 op.c              | 47 +++++++++++++++++++++++++++++++----------------
 t/op/signatures.t |  8 ++++++--
 2 files changed, 37 insertions(+), 18 deletions(-)

diff --git a/op.c b/op.c
index d6efef1caea8..6058b2978d14 100644
--- a/op.c
+++ b/op.c
@@ -3732,6 +3732,21 @@ Perl_optimize_optree(pTHX_ OP* o)
 }
 
 
+#define discourage_implicit_defgv_cvsig(o)  S_discourage_implicit_defgv_cvsig(aTHX_ o)
+static void
+S_discourage_implicit_defgv_cvsig(pTHX_ OP *o)
+{
+    CV *cv = PL_compcv;
+    while(cv && CvEVAL(cv))
+        cv = CvOUTSIDE(cv);
+
+    if(cv && CvSIGNATURE(cv))
+        Perl_ck_warner(aTHX_ packWARN(WARN_DISCOURAGED),
+            "Implicit use of @_ in %s is discouraged in signatured subroutine", OP_DESC(o));
+}
+
+#define OP_ZOOM(o)  (OP_TYPE_IS(o, OP_NULL) ? cUNOPx(o)->op_first : (o))
+
 /* helper for optimize_optree() which optimises one op then recurses
  * to optimise any children.
  */
@@ -3794,6 +3809,22 @@ S_optimize_op(pTHX_ OP* o)
             break;
         }
 
+        case OP_ENTERSUB:
+            if(!(o->op_flags & OPf_STACKED))
+                discourage_implicit_defgv_cvsig(o);
+            break;
+
+        case OP_GOTO:
+        {
+            OP *first = (o->op_flags & OPf_KIDS) ? cUNOPo->op_first : NULL;
+            OP *ffirst;
+            if(OP_TYPE_IS(first, OP_SREFGEN) &&
+                    (ffirst = OP_ZOOM(cUNOPx(first)->op_first)) &&
+                    OP_TYPE_IS(ffirst, OP_RV2CV))
+                discourage_implicit_defgv_cvsig(o);
+            break;
+        }
+
         default:
             break;
         }
@@ -12604,19 +12635,6 @@ Perl_newSVREF(pTHX_ OP *o)
 /* Check routines. See the comments at the top of this file for details
  * on when these are called */
 
-#define discourage_implicit_defgv_cvsig(o)  S_discourage_implicit_defgv_cvsig(aTHX_ o)
-static void
-S_discourage_implicit_defgv_cvsig(pTHX_ OP *o)
-{
-    CV *cv = PL_compcv;
-    while(cv && CvEVAL(cv))
-        cv = CvOUTSIDE(cv);
-
-    if(cv && CvSIGNATURE(cv))
-        Perl_ck_warner(aTHX_ packWARN(WARN_DISCOURAGED),
-            "Implicit use of @_ in %s is discouraged in signatured subroutine", OP_DESC(o));
-}
-
 OP *
 Perl_ck_anoncode(pTHX_ OP *o)
 {
@@ -15347,9 +15365,6 @@ Perl_ck_subr(pTHX_ OP *o)
 
     PERL_ARGS_ASSERT_CK_SUBR;
 
-    if(!(o->op_flags & OPf_STACKED))
-        discourage_implicit_defgv_cvsig(o);
-
     aop = cUNOPx(o)->op_first;
     if (!OpHAS_SIBLING(aop))
         aop = cUNOPx(aop)->op_first;
diff --git a/t/op/signatures.t b/t/op/signatures.t
index 71eea39a8781..69acab66d1a9 100644
--- a/t/op/signatures.t
+++ b/t/op/signatures.t
@@ -434,7 +434,10 @@ like $@, _create_flexible_mismatch_regexp('main::t128', 3, 2);
 is $a, 123;
 
 sub t130 { join(",", @_).";".scalar(@_) }
-sub t131 ($a = 222, $b = goto &t130) { "$a/$b" }
+{
+    no warnings 'discouraged';
+    sub t131 ($a = 222, $b = goto &t130) { "$a/$b" }
+}
 is prototype(\&t131), undef;
 is eval("t131()"), ";0";
 is eval("t131(0)"), "0;1";
@@ -1649,7 +1652,7 @@ while(<$kh>) {
     # implicit @_
     discouraged_ok 'shift',            'shift';
     discouraged_ok 'pop',              'pop';
-    discouraged_ok 'subroutine entry', 'goto &SUB'; # tail-call
+    discouraged_ok 'goto',             'goto &SUB'; # tail-call
     discouraged_ok 'subroutine entry', '&SUB'; # perl4-style
 
     # explicit @_
@@ -1672,6 +1675,7 @@ while(<$kh>) {
     # still permitted without warning
     not_discouraged_ok 'my $f = sub { my $y = shift; }';
     not_discouraged_ok 'my $f = sub { my $y = $_[0]; }';
+    not_discouraged_ok '\&SUB';
 }
 
 # Warnings can be disabled