In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/c08f093b3e154c428f604f89f7feb633e6c97869?hp=43d32dfff0307a53909d889f16182a4c40647c3b>
- Log ----------------------------------------------------------------- commit c08f093b3e154c428f604f89f7feb633e6c97869 Author: Vincent Pit <[email protected]> Date: Sat Jun 25 23:36:50 2011 +0200 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]. M dist/B-Deparse/Deparse.pm M op.c M op.h M pp_ctl.c M t/op/switch.t commit f02ea43cac371ecb59188f9654a0d99fd54db862 Author: Vincent Pit <[email protected]> Date: Sat Jun 25 14:28:12 2011 +0200 Convert pp_leave() to adjust_stack_on_leave() M pp_ctl.c commit 2b9a64577b41d2e4715e02f855894f80e1e293e8 Author: Vincent Pit <[email protected]> Date: Sat Jun 25 14:25:25 2011 +0200 Move pp_enter() and pp_leave() with their friends in pp_ctl.c M pp_ctl.c M pp_hot.c commit b9d76716561152289be3c4e24746173674d3b33a Author: Vincent Pit <[email protected]> Date: Sat Jun 25 11:53:48 2011 +0200 Factor stack adjustments on leave in a new static function This is just a refactoring. There should be no functional changes. M embed.fnc M embed.h M pp_ctl.c M proto.h ----------------------------------------------------------------------- Summary of changes: dist/B-Deparse/Deparse.pm | 8 +- embed.fnc | 1 + embed.h | 1 + op.c | 27 +--- op.h | 1 - pp_ctl.c | 288 ++++++++++++++++++++++----------------------- pp_hot.c | 76 ------------ proto.h | 7 + t/op/switch.t | 131 ++++++++++++++++++++- 9 files changed, 289 insertions(+), 251 deletions(-) diff --git a/dist/B-Deparse/Deparse.pm b/dist/B-Deparse/Deparse.pm index 8c89ea3..a53000a 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/embed.fnc b/embed.fnc index 41d9cc2..cc55c2a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1742,6 +1742,7 @@ sR |PerlIO *|check_type_and_open|NN SV *name #ifndef PERL_DISABLE_PMC sR |PerlIO *|doopen_pm |NN SV *name #endif +s |SV ** |adjust_stack_on_leave|NN SV **newsp|NN SV **sp|NN SV **mark|I32 gimme|U32 flags sRn |bool |path_is_absolute|NN const char *name sR |I32 |run_user_filter|int idx|NN SV *buf_sv|int maxlen sR |PMOP* |make_matcher |NN REGEXP* re diff --git a/embed.h b/embed.h index 6dcaa39..dd759a8 100644 --- a/embed.h +++ b/embed.h @@ -1381,6 +1381,7 @@ #define refto(a) S_refto(aTHX_ a) # endif # if defined(PERL_IN_PP_CTL_C) +#define adjust_stack_on_leave(a,b,c,d,e) S_adjust_stack_on_leave(aTHX_ a,b,c,d,e) #define check_type_and_open(a) S_check_type_and_open(aTHX_ a) #define destroy_matcher(a) S_destroy_matcher(aTHX_ a) #define do_smartmatch(a,b) S_do_smartmatch(aTHX_ a,b) diff --git a/op.c b/op.c index 267bfb9..cbc44b8 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 5b1432c..da62fd7 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 1057c70..9eb2814 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2050,6 +2050,90 @@ PP(pp_dbstate) return NORMAL; } +STATIC SV ** +S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) +{ + PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE; + + if (gimme == G_SCALAR) { + if (MARK < SP) + *++newsp = (SvFLAGS(*SP) & flags) ? *SP : sv_mortalcopy(*SP); + else { + /* MEXTEND() only updates MARK, so reuse it instead of newsp. */ + MARK = newsp; + MEXTEND(MARK, 1); + *++MARK = &PL_sv_undef; + return MARK; + } + } + else if (gimme == G_ARRAY) { + /* in case LEAVE wipes old return values */ + while (++MARK <= SP) { + if (SvFLAGS(*MARK) & flags) + *++newsp = *MARK; + else { + *++newsp = sv_mortalcopy(*MARK); + TAINT_NOT; /* Each item is independent */ + } + } + /* When this function was called with MARK == newsp, we reach this + * point with SP == newsp. */ + } + + return newsp; +} + +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; + } + + ENTER_with_name("block"); + + SAVETMPS; + PUSHBLOCK(cx, CXt_BLOCK, SP); + + RETURN; +} + +PP(pp_leave) +{ + dVAR; dSP; + register PERL_CONTEXT *cx; + SV **newsp; + PMOP *newpm; + I32 gimme; + + if (PL_op->op_flags & OPf_SPECIAL) { + cx = &cxstack[cxstack_ix]; + cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ + } + + POPBLOCK(cx,newpm); + + gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); + + TAINT_NOT; + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); + PL_curpm = newpm; /* Don't pop $1 et al till now */ + + LEAVE_with_name("block"); + + RETURN; +} + PP(pp_enteriter) { dVAR; dSP; dMARK; @@ -2203,21 +2287,7 @@ PP(pp_leaveloop) newsp = PL_stack_base + cx->blk_loop.resetsp; TAINT_NOT; - if (gimme == G_VOID) - NOOP; - else if (gimme == G_SCALAR) { - if (mark < SP) - *++newsp = sv_mortalcopy(*SP); - else - *++newsp = &PL_sv_undef; - } - else { - while (mark < SP) { - *++newsp = sv_mortalcopy(*++mark); - TAINT_NOT; /* Each item is independent */ - } - } - SP = newsp; + SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0); PUTBACK; POPLOOP(cx); /* Stack values are safe: release loop vars ... */ @@ -2572,21 +2642,8 @@ PP(pp_last) } TAINT_NOT; - if (gimme == G_SCALAR) { - if (MARK < SP) - *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP)) - ? *SP : sv_mortalcopy(*SP); - else - *++newsp = &PL_sv_undef; - } - else if (gimme == G_ARRAY) { - while (++MARK <= SP) { - *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK)) - ? *MARK : sv_mortalcopy(*MARK); - TAINT_NOT; /* Each item is independent */ - } - } - SP = newsp; + SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, + pop2 == CXt_SUB ? SVs_TEMP : 0); PUTBACK; LEAVE; @@ -4191,7 +4248,6 @@ PP(pp_entereval) PP(pp_leaveeval) { dVAR; dSP; - register SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -4208,31 +4264,8 @@ PP(pp_leaveeval) retop = cx->blk_eval.retop; TAINT_NOT; - if (gimme == G_VOID) - MARK = newsp; - else if (gimme == G_SCALAR) { - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & SVs_TEMP) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else { - /* in case LEAVE wipes old return values */ - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & SVs_TEMP)) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } + SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp, + gimme, SVs_TEMP); PL_curpm = newpm; /* Don't pop $1 et al till now */ #ifdef DEBUGGING @@ -4329,33 +4362,7 @@ PP(pp_leavetry) PERL_UNUSED_VAR(optype); TAINT_NOT; - if (gimme == G_VOID) - SP = newsp; - else if (gimme == G_SCALAR) { - register SV **mark; - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else { - /* in case LEAVE wipes old return values */ - register SV **mark; - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("eval_scope"); @@ -4393,33 +4400,7 @@ PP(pp_leavegiven) assert(CxTYPE(cx) == CXt_GIVEN); TAINT_NOT; - if (gimme == G_VOID) - SP = newsp; - else if (gimme == G_SCALAR) { - register SV **mark; - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } - else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else { - /* in case LEAVE wipes old return values */ - register SV **mark; - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } + SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP); PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("given"); @@ -4969,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); @@ -4981,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) @@ -5025,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/pp_hot.c b/pp_hot.c index 3b97815..2f159e5 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1735,31 +1735,6 @@ Perl_do_readline(pTHX) } } -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; - } - - ENTER_with_name("block"); - - SAVETMPS; - PUSHBLOCK(cx, CXt_BLOCK, SP); - - RETURN; -} - PP(pp_helem) { dVAR; dSP; @@ -1839,57 +1814,6 @@ PP(pp_helem) RETURN; } -PP(pp_leave) -{ - dVAR; dSP; - register PERL_CONTEXT *cx; - SV **newsp; - PMOP *newpm; - I32 gimme; - - if (PL_op->op_flags & OPf_SPECIAL) { - cx = &cxstack[cxstack_ix]; - cx->blk_oldpm = PL_curpm; /* fake block should preserve $1 et al */ - } - - POPBLOCK(cx,newpm); - - gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR); - - TAINT_NOT; - if (gimme == G_VOID) - SP = newsp; - else if (gimme == G_SCALAR) { - register SV **mark; - MARK = newsp + 1; - if (MARK <= SP) { - if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP)) - *MARK = TOPs; - else - *MARK = sv_mortalcopy(TOPs); - } else { - MEXTEND(mark,0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - else if (gimme == G_ARRAY) { - /* in case LEAVE wipes old return values */ - register SV **mark; - for (mark = newsp + 1; mark <= SP; mark++) { - if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) { - *mark = sv_mortalcopy(*mark); - TAINT_NOT; /* Each item is independent */ - } - } - } - PL_curpm = newpm; /* Don't pop $1 et al till now */ - - LEAVE_with_name("block"); - - RETURN; -} - PP(pp_iter) { dVAR; dSP; diff --git a/proto.h b/proto.h index 984fc80..d034326 100644 --- a/proto.h +++ b/proto.h @@ -5706,6 +5706,13 @@ PERL_CALLCONV GV* Perl_softref2xv(pTHX_ SV *const sv, const char *const what, co #endif #if defined(PERL_IN_PP_CTL_C) +STATIC SV ** S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags) + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2) + __attribute__nonnull__(pTHX_3); +#define PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE \ + assert(newsp); assert(sp); assert(mark) + STATIC PerlIO * S_check_type_and_open(pTHX_ SV *name) __attribute__warn_unused_result__ __attribute__nonnull__(pTHX_1); diff --git a/t/op/switch.t b/t/op/switch.t index ba4fc40..7614630 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__ -- Perl5 Master Repository
