Correctly preserve the stack on an implicit break.

Perl generates a 'break' op with the special flag set at the end of every
'when' block. This makes it difficult to handle both the case of an
implicit break, where the stack has to be preserved, and the case of an
explicit break, which must obliterate the stack, with the same pp function.
Stack handling should naturally occur in 'leavewhen', but it is effectively
called only when the block issues a 'continue'.

In order to preserve the stack, we change the respective roles of 'break',
'continue' and 'leavewhen' ops :
- Special 'break' ops are no longer generated for implicit breaks. Just as
before, they give the control back to the 'leavegiven' op.
- 'continue' ops now directly forward to the op *following* the 'leavewhen'
op of the current 'when' block.
- 'leavewhen' is now only called at the natural end of a 'when' block.
It adjusts the stack to make sure returned values survive the temp cleanup,
then issues a 'next' or go to the current 'leavegiven' depending on whether
it is enclosed in a for loop or a given block.

This fixes [perl #93548].

5 files changed, 189 insertions, 65 deletions

diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm
index 8c89ea3f69..a53000a9d9 100644
--- a/dist/B-Deparse/Deparse.pm
+++ b/dist/B-Deparse/Deparse.pm
@@ -26,7 +26,7 @@ use B qw(class main_root main_start main_cv svref_2object opnumber perlstring
 	 ($] < 5.009 ? 'PMf_SKIPWHITE' : qw(RXf_SKIPWHITE)),
 	 ($] < 5.011 ? 'CVf_LOCKED' : 'OPpREVERSE_INPLACE'),
 	 ($] < 5.013 ? () : 'PMf_NONDESTRUCT');
-$VERSION = "1.05";
+$VERSION = "1.06";
 use strict;
 use vars qw/$AUTOLOAD/;
 use warnings ();
@@ -1759,11 +1759,7 @@ sub pp_ggrgid { unop(@_, "getgrgid") }
 sub pp_lock { unop(@_, "lock") }
 
 sub pp_continue { unop(@_, "continue"); }
-sub pp_break {
-    my ($self, $op) = @_;
-    return "" if $op->flags & OPf_SPECIAL;
-    unop(@_, "break");
-}
+sub pp_break { unop(@_, "break"); }
 
 sub givwhen {
     my $self = shift;
diff --git a/op.c b/op.c
index 267bfb96f0..cbc44b835c 100644
--- a/op.c
+++ b/op.c
@@ -959,14 +959,9 @@ Perl_scalar(pTHX_ OP *o)
     do_kids:
 	while (kid) {
 	    OP *sib = kid->op_sibling;
-	    if (sib && kid->op_type != OP_LEAVEWHEN) {
-		if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
-		    scalar(kid);
-		    scalarvoid(sib);
-		    break;
-		} else
-		    scalarvoid(kid);
-	    } else
+	    if (sib && kid->op_type != OP_LEAVEWHEN)
+		scalarvoid(kid);
+	    else
 		scalar(kid);
 	    kid = sib;
 	}
@@ -1345,14 +1340,9 @@ Perl_list(pTHX_ OP *o)
     do_kids:
 	while (kid) {
 	    OP *sib = kid->op_sibling;
-	    if (sib && kid->op_type != OP_LEAVEWHEN) {
-		if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
-		    list(kid);
-		    scalarvoid(sib);
-		    break;
-		} else
-		    scalarvoid(kid);
-	    } else
+	    if (sib && kid->op_type != OP_LEAVEWHEN)
+		scalarvoid(kid);
+	    else
 		list(kid);
 	    kid = sib;
 	}
@@ -5937,10 +5927,7 @@ Perl_newWHENOP(pTHX_ OP *cond, OP *block)
 		scalar(ref_array_or_hash(cond)));
     }
     
-    return newGIVWHENOP(
-	cond_op,
-	op_append_elem(block->op_type, block, newOP(OP_BREAK, OPf_SPECIAL)),
-	OP_ENTERWHEN, OP_LEAVEWHEN, 0);
+    return newGIVWHENOP(cond_op, block, OP_ENTERWHEN, OP_LEAVEWHEN, 0);
 }
 
 void
diff --git a/op.h b/op.h
index 5b1432cee9..da62fd7640 100644
--- a/op.h
+++ b/op.h
@@ -132,7 +132,6 @@ Deprecated.  Use C<GIMME_V> instead.
 				 *    (runtime property) */
 				/*  On OP_REQUIRE, was seen as CORE::require */
 				/*  On OP_ENTERWHEN, there's no condition */
-				/*  On OP_BREAK, an implicit break */
 				/*  On OP_SMARTMATCH, an implicit smartmatch */
 				/*  On OP_ANONHASH and OP_ANONLIST, create a
 				    reference to the new anon hash or array */
diff --git a/pp_ctl.c b/pp_ctl.c
index 32573f3303..9eb281451a 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4950,7 +4950,7 @@ PP(pp_enterwhen)
     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
 	RETURNOP(cLOGOP->op_other->op_next);
 
-    ENTER_with_name("eval");
+    ENTER_with_name("when");
     SAVETMPS;
 
     PUSHBLOCK(cx, CXt_WHEN, SP);
@@ -4962,43 +4962,70 @@ PP(pp_enterwhen)
 PP(pp_leavewhen)
 {
     dVAR; dSP;
+    I32 cxix;
     register PERL_CONTEXT *cx;
-    I32 gimme __attribute__unused__;
+    I32 gimme;
     SV **newsp;
     PMOP *newpm;
 
+    cxix = dopoptogiven(cxstack_ix);
+    if (cxix < 0)
+	DIE(aTHX_ "Can't use when() outside a topicalizer");
+
     POPBLOCK(cx,newpm);
     assert(CxTYPE(cx) == CXt_WHEN);
 
-    SP = newsp;
-    PUTBACK;
-
+    TAINT_NOT;
+    SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
     PL_curpm = newpm;   /* pop $1 et al */
 
-    LEAVE_with_name("eval");
-    return NORMAL;
+    LEAVE_with_name("when");
+
+    if (cxix < cxstack_ix)
+        dounwind(cxix);
+
+    cx = &cxstack[cxix];
+
+    if (CxFOREACH(cx)) {
+	/* clear off anything above the scope we're re-entering */
+	I32 inner = PL_scopestack_ix;
+
+	TOPBLOCK(cx);
+	if (PL_scopestack_ix < inner)
+	    leave_scope(PL_scopestack[PL_scopestack_ix]);
+	PL_curcop = cx->blk_oldcop;
+
+	return cx->blk_loop.my_op->op_nextop;
+    }
+    else
+	/* RETURNOP calls PUTBACK which restores the old old sp */
+	return cx->blk_givwhen.leave_op;
 }
 
 PP(pp_continue)
 {
-    dVAR;   
+    dVAR; dSP;
     I32 cxix;
     register PERL_CONTEXT *cx;
-    I32 inner;
+    I32 gimme;
+    SV **newsp;
+    PMOP *newpm;
     
     cxix = dopoptowhen(cxstack_ix); 
     if (cxix < 0)   
 	DIE(aTHX_ "Can't \"continue\" outside a when block");
+
     if (cxix < cxstack_ix)
         dounwind(cxix);
     
-    /* clear off anything above the scope we're re-entering */
-    inner = PL_scopestack_ix;
-    TOPBLOCK(cx);
-    if (PL_scopestack_ix < inner)
-        leave_scope(PL_scopestack[PL_scopestack_ix]);
-    PL_curcop = cx->blk_oldcop;
-    return cx->blk_givwhen.leave_op;
+    POPBLOCK(cx,newpm);
+    assert(CxTYPE(cx) == CXt_WHEN);
+
+    SP = newsp;
+    PL_curpm = newpm;   /* pop $1 et al */
+
+    LEAVE_with_name("when");
+    RETURNOP(cx->blk_givwhen.leave_op->op_next);
 }
 
 PP(pp_break)
@@ -5006,34 +5033,20 @@ PP(pp_break)
     dVAR;   
     I32 cxix;
     register PERL_CONTEXT *cx;
-    I32 inner;
-    dSP;
 
     cxix = dopoptogiven(cxstack_ix); 
-    if (cxix < 0) {
-	if (PL_op->op_flags & OPf_SPECIAL)
-	    DIE(aTHX_ "Can't use when() outside a topicalizer");
-	else
-	    DIE(aTHX_ "Can't \"break\" outside a given block");
-    }
-    if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
+    if (cxix < 0)
+	DIE(aTHX_ "Can't \"break\" outside a given block");
+
+    cx = &cxstack[cxix];
+    if (CxFOREACH(cx))
 	DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
 
     if (cxix < cxstack_ix)
         dounwind(cxix);
-    
-    /* clear off anything above the scope we're re-entering */
-    inner = PL_scopestack_ix;
-    TOPBLOCK(cx);
-    if (PL_scopestack_ix < inner)
-        leave_scope(PL_scopestack[PL_scopestack_ix]);
-    PL_curcop = cx->blk_oldcop;
 
-    if (CxFOREACH(cx))
-	return (cx)->blk_loop.my_op->op_nextop;
-    else
-	/* RETURNOP calls PUTBACK which restores the old old sp */
-	RETURNOP(cx->blk_givwhen.leave_op);
+    /* RETURNOP calls PUTBACK which restores the old old sp */
+    return cx->blk_givwhen.leave_op;
 }
 
 static MAGIC *
diff --git a/t/op/switch.t b/t/op/switch.t
index ba4fc406ab..7614630d99 100644
--- a/t/op/switch.t
+++ b/t/op/switch.t
@@ -9,7 +9,7 @@ BEGIN {
 use strict;
 use warnings;
 
-plan tests => 168;
+plan tests => 196;
 
 # The behaviour of the feature pragma should be tested by lib/feature.t
 # using the tests in t/lib/feature/*. This file tests the behaviour of
@@ -1218,6 +1218,135 @@ unreified_check(undef,"");
     }
 }
 
+# Test that returned values are correctly propagated through several context
+# levels (see RT #93548).
+{
+    my $tester = sub {
+	my $id = shift;
+
+	package fmurrr;
+
+	our ($when_loc, $given_loc, $ext_loc);
+
+	my $ext_lex    = 7;
+	our $ext_glob  = 8;
+	local $ext_loc = 9;
+
+	given ($id) {
+	    my $given_lex    = 4;
+	    our $given_glob  = 5;
+	    local $given_loc = 6;
+
+	    when (0) { 0 }
+
+	    when (1) { my $when_lex    = 1 }
+	    when (2) { our $when_glob  = 2 }
+	    when (3) { local $when_loc = 3 }
+
+	    when (4) { $given_lex }
+	    when (5) { $given_glob }
+	    when (6) { $given_loc }
+
+	    when (7) { $ext_lex }
+	    when (8) { $ext_glob }
+	    when (9) { $ext_loc }
+
+	    'fallback';
+	}
+    };
+
+    my @descriptions = qw<
+	constant
+
+	when-lexical
+	when-global
+	when-local
+
+	given-lexical
+	given-global
+	given-local
+
+	extern-lexical
+	extern-global
+	extern-local
+    >;
+
+    for my $id (0 .. 9) {
+	my $desc = $descriptions[$id];
+
+	my $res = $tester->($id);
+	is $res, $id, "plain call - $desc";
+
+	$res = do {
+	    my $id_plus_1 = $id + 1;
+	    given ($id_plus_1) {
+		do {
+		    when (/\d/) {
+			--$id_plus_1;
+			continue;
+			456;
+		    }
+		};
+		default {
+		    $tester->($id_plus_1);
+		}
+		'XXX';
+	    }
+	};
+	is $res, $id, "across continue and default - $desc";
+    }
+}
+
+# Check that values returned from given/when are destroyed at the right time.
+{
+    {
+	package Fmurrr;
+
+	sub new {
+	    bless {
+		flag => \($_[1]),
+		id   => $_[2],
+	    }, $_[0]
+	}
+
+	sub DESTROY {
+	    ${$_[0]->{flag}}++;
+	}
+    }
+
+    my @descriptions = qw<
+	when
+	break
+	continue
+	default
+    >;
+
+    for my $id (0 .. 3) {
+	my $desc = $descriptions[$id];
+
+	my $destroyed = 0;
+	my $res_id;
+
+	{
+	    my $res = do {
+		given ($id) {
+		    my $x;
+		    when (0) { Fmurrr->new($destroyed, 0) }
+		    when (1) { my $y = Fmurrr->new($destroyed, 1); break }
+		    when (2) { $x = Fmurrr->new($destroyed, 2); continue }
+		    when (2) { $x }
+		    default  { Fmurrr->new($destroyed, 3) }
+		}
+	    };
+	    $res_id = $res->{id};
+	}
+	$res_id = $id if $id == 1; # break doesn't return anything
+
+	is $res_id,    $id, "given/when returns the right object - $desc";
+	is $destroyed, 1,   "given/when does not leak - $desc";
+    };
+}
+
 # Okay, that'll do for now. The intricacies of the smartmatch
 # semantics are tested in t/op/smartmatch.t
 __END__