diff options
| -rw-r--r-- | dist/B-Deparse/Deparse.pm | 8 | ||||
| -rw-r--r-- | op.c | 27 | ||||
| -rw-r--r-- | op.h | 1 | ||||
| -rw-r--r-- | pp_ctl.c | 87 | ||||
| -rw-r--r-- | t/op/switch.t | 131 |
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; @@ -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 @@ -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 */ @@ -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__ |