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

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

p4raw-id: //depot/perl@34907

diff --git a/op.c b/op.c
index 10c1fc9..102c20e 100644 (file)
--- 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 6729f6e..a90be0a 100644 (file)
--- 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 fad52aa..f0c56cf 100644 (file)
--- 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 4fd7990..90a106c 100755 (executable)
--- 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");
 }