From 7c2d9d03f8b64a80661ece16e7bfc15456ae3400 Mon Sep 17 00:00:00 2001
From: Vincent Pit <perl@profvince.com>
Date: Mon, 27 Jun 2011 15:01:30 +0200
Subject: [PATCH] Fix context propagation below return()

A.k.a. "RT #38809 strikes back".

Back in the time of perl 5.003, there was no void context, so "do" blocks
below a return needed special handling to use the dynamic context of the
caller instead of the static context implied by the return op location.

But nowadays context is applied by the scalarvoid(), scalar() and list()
functions, and they all already skip the return ops. "do" blocks below a
return don't get a static context, and GIMME_V ought to correctly return
the caller's context. The old workaround isn't even required anymore.
---
 op.c      |   13 -----------
 op.h      |    1 -
 pp_ctl.c  |   13 +-----------
 t/op/do.t |   67 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 68 insertions(+), 26 deletions(-)

diff --git a/op.c b/op.c
index cbc44b8..6b4bf6b 100644
--- a/op.c
+++ b/op.c
@@ -8219,19 +8219,6 @@ Perl_ck_return(pTHX_ OP *o)
     if (CvLVALUE(PL_compcv)) {
 	for (; kid; kid = kid->op_sibling)
 	    op_lvalue(kid, OP_LEAVESUBLV);
-    } else {
-	for (; kid; kid = kid->op_sibling)
-	    if ((kid->op_type == OP_NULL)
-		&& ((kid->op_flags & (OPf_SPECIAL|OPf_KIDS)) == (OPf_SPECIAL|OPf_KIDS))) {
-		/* This is a do block */
-		OP *op = kUNOP->op_first;
-		if (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 da62fd7..d80eb38 100644
--- a/op.h
+++ b/op.h
@@ -135,7 +135,6 @@ 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_ctl.c b/pp_ctl.c
index c5cf973..0727372 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2087,18 +2087,7 @@ PP(pp_enter)
 {
     dVAR; dSP;
     register PERL_CONTEXT *cx;
-    I32 gimme = OP_GIMME(PL_op, -1);
-
-    if (gimme == -1) {
-	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;
-    }
+    I32 gimme = GIMME_V;
 
     ENTER_with_name("block");
 
diff --git a/t/op/do.t b/t/op/do.t
index 787d632..aae6aac 100644
--- a/t/op/do.t
+++ b/t/op/do.t
@@ -159,6 +159,73 @@ is($x, 4, 'return do { do { ; } } receives caller scalar context');
 @x = sub { do { return do { 1; do { 2; @a } } }; 5 }->();
 is("@x", "7 8 9 10", 'return do { do { ; } } receives caller list context');
 
+# More tests about context propagation below return()
+@a = (11, 12);
+@b = (21, 22, 23);
+
+my $test_code = sub {
+    my ($x, $y) = @_;
+    if ($x) {
+	return $y ? do { my $z; @a } : do { my $z; @b };
+    } else {
+	return (
+	    do { my $z; @a },
+	    (do { my$z; @b }) x $y
+	);
+    }
+    'xxx';
+};
+
+$x = $test_code->(1, 1);
+is($x, 2, 'return $y ? do { } : do { } - scalar context 1');
+$x = $test_code->(1, 0);
+is($x, 3, 'return $y ? do { } : do { } - scalar context 2');
+@x = $test_code->(1, 1);
+is("@x", '11 12', 'return $y ? do { } : do { } - list context 1');
+@x = $test_code->(1, 0);
+is("@x", '21 22 23', 'return $y ? do { } : do { } - list context 2');
+
+$x = $test_code->(0, 0);
+is($x, "", 'return (do { }, (do { }) x ...) - scalar context 1');
+$x = $test_code->(0, 1);
+is($x, 3, 'return (do { }, (do { }) x ...) - scalar context 2');
+@x = $test_code->(0, 0);
+is("@x", '11 12', 'return (do { }, (do { }) x ...) - list context 1');
+@x = $test_code->(0, 1);
+is("@x", '11 12 21 22 23', 'return (do { }, (do { }) x ...) - list context 2');
+
+$test_code = sub {
+    my ($x, $y) = @_;
+    if ($x) {
+	return do {
+	    if ($y == 0) {
+		my $z;
+		@a;
+	    } elsif ($y == 1) {
+		my $z;
+		@b;
+	    } else {
+		my $z;
+		(wantarray ? reverse(@a) : '99');
+	    }
+	};
+    }
+    'xxx';
+};
+
+$x = $test_code->(1, 0);
+is($x, 2, 'return do { if () { } elsif () { } else { } } - scalar 1');
+$x = $test_code->(1, 1);
+is($x, 3, 'return do { if () { } elsif () { } else { } } - scalar 2');
+$x = $test_code->(1, 2);
+is($x, 99, 'return do { if () { } elsif () { } else { } } - scalar 3');
+@x = $test_code->(1, 0);
+is("@x", '11 12', 'return do { if () { } elsif () { } else { } } - list 1');
+@x = $test_code->(1, 1);
+is("@x", '21 22 23', 'return do { if () { } elsif () { } else { } } - list 2');
+@x = $test_code->(1, 2);
+is("@x", '12 11', 'return do { if () { } elsif () { } else { } } - list 3');
+
 # Do blocks created by constant folding
 # [perl #68108]
 $x = sub { if (1) { 20 } }->();
-- 
1.7.4.1