Better handling of &SUB so as not to warn on \&SUB

Perl · Jan 24, 2022 · 49d74bb · 49d74bb
1 parent 231d6d9
commit 49d74bb
Show file tree

Hide file tree

Showing 2 changed files with 37 additions and 18 deletions.
diff --git 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
@@ -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