[perl #38809] return do { } : take 3 (or 4...)

Message-ID: <48E0F5E9.4050805@profvince.com>

p4raw-id: //depot/perl@34907

4 files changed, 43 insertions, 13 deletions

diff --git a/op.c b/op.c
index 10c1fc9be9..102c20e455 100644
--- a/op.c
+++ b/op.c
@@ -7644,14 +7644,28 @@ OP *
 Perl_ck_return(pTHX_ OP *o)
 {
     dVAR;
+    OP *kid;
 
     PERL_ARGS_ASSERT_CK_RETURN;
 
+    kid = cLISTOPo->op_first->op_sibling;
     if (CvLVALUE(PL_compcv)) {
-        OP *kid;
-	for (kid = cLISTOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
+	for (; kid; kid = kid->op_sibling)
 	    mod(kid, OP_LEAVESUBLV);
+    } else {
+	for (; kid; kid = kid->op_sibling)
+	    if ((kid->op_type == OP_NULL)
+		&& (kid->op_flags & OPf_SPECIAL)) {
+		/* This is a do block */
+		OP *op = cUNOPx(kid)->op_first;
+		assert(op && (op->op_type == OP_LEAVE) && (op->op_flags & OPf_KIDS));
+		op = cUNOPx(op)->op_first;
+		assert(op->op_type == OP_ENTER && !(op->op_flags & OPf_SPECIAL));
+		/* Force the use of the caller's context */
+		op->op_flags |= OPf_SPECIAL;
+	    }
     }
+
     return o;
 }
 
diff --git a/op.h b/op.h
index 6729f6edcb..a90be0a5e9 100644
--- a/op.h
+++ b/op.h
@@ -137,6 +137,7 @@ Deprecated.  Use C<GIMME_V> instead.
 				/*  On OP_SMARTMATCH, an implicit smartmatch */
 				/*  On OP_ANONHASH and OP_ANONLIST, create a
 				    reference to the new anon hash or array */
+				/*  On OP_ENTER, store caller context */
 				/*  On OP_HELEM and OP_HSLICE, localization will be followed
 				    by assignment, so do not wipe the target if it is special
 				    (e.g. a glob or a magic SV) */
diff --git a/pp_hot.c b/pp_hot.c
index fad52aae8b..f0c56cf9f5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1754,9 +1754,13 @@ PP(pp_enter)
     I32 gimme = OP_GIMME(PL_op, -1);
 
     if (gimme == -1) {
-	if (cxstack_ix >= 0)
-	    gimme = cxstack[cxstack_ix].blk_gimme;
-	else
+	if (cxstack_ix >= 0) {
+	    /* If this flag is set, we're just inside a return, so we should
+	     * store the caller's context */
+	    gimme = (PL_op->op_flags & OPf_SPECIAL)
+		? block_gimme()
+		: cxstack[cxstack_ix].blk_gimme;
+	} else
 	    gimme = G_SCALAR;
     }
 
@@ -1865,13 +1869,7 @@ PP(pp_leave)
 
     POPBLOCK(cx,newpm);
 
-    gimme = OP_GIMME(PL_op, -1);
-    if (gimme == -1) {
-	if (cxstack_ix >= 0)
-	    gimme = cxstack[cxstack_ix].blk_gimme;
-	else
-	    gimme = G_SCALAR;
-    }
+    gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
 
     TAINT_NOT;
     if (gimme == G_VOID)
diff --git a/t/op/do.t b/t/op/do.t
index 4fd79909c8..90a106cc81 100755
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -29,7 +29,7 @@ sub ok {
     return $ok;
 }
 
-print "1..26\n";
+print "1..32\n";
 
 # Test do &sub and proper @_ handling.
 $_[0] = 0;
@@ -104,6 +104,23 @@ ok( $owww eq 'swish', 'last is unless' );
 $owww = do { 4 if not $zok };
 ok( $owww eq '', 'last is if not' );
 
+# [perl #38809]
+@a = (7, 8);
+$x = sub { do { return do { 1; @a } }; 3 }->();
+ok(defined $x && $x == 2, 'return do { } receives caller scalar context');
+@x = sub { do { return do { 1; @a } }; 3 }->();
+ok("@x" eq "7 8", 'return do { } receives caller list context');
+@a = (7, 8, 9);
+$x = sub { do { do { 1; return @a } }; 4 }->();
+ok(defined $x && $x == 3, 'do { return } receives caller scalar context');
+@x = sub { do { do { 1; return @a } }; 4 }->();
+ok("@x" eq "7 8 9", 'do { return } receives caller list context');
+@a = (7, 8, 9, 10);
+$x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
+ok(defined $x && $x == 4, 'return do { do { } } receives caller scalar context');
+@x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
+ok("@x" eq "7 8 9 10", 'return do { do { } } receives caller list context');
+
 END {
     1 while unlink("$$.16", "$$.17", "$$.18");
 }