[perl #132854] Allow goto into first arg of bin op

Father Chrysostomos · Father Chrysostomos · commit b4dcd72d7c1f · 2018-02-23T17:59:49.000-08:00
This particular case does not risk any stack corruption, and there is
a CPAN module depending on it working (PerlX::AsyncAwait).
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
@@ -284,7 +284,12 @@ XXX Changes (i.e. rewording) of diagnostic messages go here
 
 =item *
 
-XXX Describe change here
+The new (as of 5.27.8) restriction forbidding use of C<goto> to enter the
+argument of a binary or list expression (see L<perldiag/"Can't
+E<quot>gotoE<quot> into a binary or list expression">) has been relaxed to
+allow entering the I<first> argument of an operator that takes a fixed
+number of arguments, since this is a case that will not cause stack
+corruption.  [perl #132854]
 
 =back
 
diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
@@ -3458,7 +3458,9 @@ deprecated and will issue a warning.  Even then, it may not be used to
 go into any construct that requires initialization, such as a
 subroutine, a C<foreach> loop, or a C<given>
 block.  In general, it may not be used to jump into the parameter
-of a binary or list operator.  It also can't be used to go into a
+of a binary or list operator, but it may be used to jump into the
+I<first> parameter of a binary operator or other operator that takes
+a fixed number of arguments.  It also can't be used to go into a
 construct that is optimized away.
 
 The C<goto &NAME> form is quite different from the other forms of
diff --git a/pp_ctl.c b/pp_ctl.c
@@ -2687,6 +2687,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
     *ops = 0;
     if (o->op_flags & OPf_KIDS) {
 	OP *kid;
+	OP * const kid1 = cUNOPo->op_first;
 	/* First try all the kids at this level, since that's likeliest. */
 	for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
 	    if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
@@ -2709,6 +2710,7 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
 	    }
 	}
 	for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {
+	    bool first_kid_of_binary = FALSE;
 	    if (kid == PL_lastgotoprobe)
 		continue;
 	    if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
@@ -2721,8 +2723,14 @@ S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstac
 		else
 		    *ops++ = kid;
 	    }
+	    if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {
+		first_kid_of_binary = TRUE;
+		ops--;
+	    }
 	    if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
 		return o;
+	    if (first_kid_of_binary)
+		*ops++ = UNENTERABLE;
 	}
     }
     *ops = 0;
diff --git a/t/op/goto.t b/t/op/goto.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use warnings;
 use strict;
-plan tests => 122;
+plan tests => 123;
 our $TODO;
 
 my $deprecated = 0;
@@ -870,3 +870,13 @@ sub _routine {
 }
 _routine();
 pass("bug 132799");
+
+# [perl #132854]
+# Goto the *first* parameter of a binary expression, which is harmless.
+eval {
+    goto __GEN_2;
+    my $sent = do {
+        __GEN_2:
+    };
+};
+is $@,'', 'goto the first parameter of a binary expression [perl #132854]';

Original file line number	Diff line number	Diff line change
`@@ -2687,6 +2687,7 @@ S_dofindlabel(pTHX_ OP o, const char label, STRLEN len, U32 flags, OP **opstac`
`2687`	`2687`	`*ops = 0;`
`2688`	`2688`	`if (o->op_flags & OPf_KIDS) {`
`2689`	`2689`	`OP *kid;`
	`2690`	`+ OP * const kid1 = cUNOPo->op_first;`
`2690`	`2691`	`/* First try all the kids at this level, since that's likeliest. */`
`2691`	`2692`	`for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {`
`2692`	`2693`	`if (kid->op_type == OP_NEXTSTATE \|\| kid->op_type == OP_DBSTATE) {`
`@@ -2709,6 +2710,7 @@ S_dofindlabel(pTHX_ OP o, const char label, STRLEN len, U32 flags, OP **opstac`
`2709`	`2710`	`}`
`2710`	`2711`	`}`
`2711`	`2712`	`for (kid = cUNOPo->op_first; kid; kid = OpSIBLING(kid)) {`
	`2713`	`+ bool first_kid_of_binary = FALSE;`
`2712`	`2714`	`if (kid == PL_lastgotoprobe)`
`2713`	`2715`	`continue;`
`2714`	`2716`	`if (kid->op_type == OP_NEXTSTATE \|\| kid->op_type == OP_DBSTATE) {`
`@@ -2721,8 +2723,14 @@ S_dofindlabel(pTHX_ OP o, const char label, STRLEN len, U32 flags, OP **opstac`
`2721`	`2723`	`else`
`2722`	`2724`	`*ops++ = kid;`
`2723`	`2725`	`}`
	`2726`	`+ if (kid == kid1 && ops != opstack && ops[-1] == UNENTERABLE) {`
	`2727`	`+ first_kid_of_binary = TRUE;`
	`2728`	`+ ops--;`
	`2729`	`+ }`
`2724`	`2730`	`if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))`
`2725`	`2731`	`return o;`
	`2732`	`+ if (first_kid_of_binary)`
	`2733`	`+ *ops++ = UNENTERABLE;`
`2726`	`2734`	`}`
`2727`	`2735`	`}`
`2728`	`2736`	`*ops = 0;`