diff options
| -rw-r--r-- | op.c | 56 | ||||
| -rw-r--r-- | pod/perlsyn.pod | 36 | ||||
| -rw-r--r-- | pp_ctl.c | 45 | ||||
| -rw-r--r-- | t/op/switch.t | 134 |
4 files changed, 236 insertions, 35 deletions
@@ -924,25 +924,28 @@ Perl_scalar(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; scalar(kid); - while ((kid = kid->op_sibling)) { - if (kid->op_sibling) - scalarvoid(kid); - else + kid = kid->op_sibling; + 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 scalar(kid); + kid = sib; } PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: case OP_LIST: - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) - scalarvoid(kid); - else - scalar(kid); - } - PL_curcop = &PL_compiling; - break; + kid = cLISTOPo->op_first; + goto do_kids; case OP_SORT: Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context"); break; @@ -986,7 +989,7 @@ Perl_scalarvoid(pTHX_ OP *o) want = o->op_flags & OPf_WANT; if ((want && want != OPf_WANT_SCALAR) || (PL_parser && PL_parser->error_count) - || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE) + || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN) { return o; } @@ -1297,24 +1300,27 @@ Perl_list(pTHX_ OP *o) case OP_LEAVETRY: kid = cLISTOPo->op_first; list(kid); - while ((kid = kid->op_sibling)) { - if (kid->op_sibling) - scalarvoid(kid); - else + kid = kid->op_sibling; + 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 list(kid); + kid = sib; } PL_curcop = &PL_compiling; break; case OP_SCOPE: case OP_LINESEQ: - for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) { - if (kid->op_sibling) - scalarvoid(kid); - else - list(kid); - } - PL_curcop = &PL_compiling; - break; + kid = cLISTOPo->op_first; + goto do_kids; } return o; } diff --git a/pod/perlsyn.pod b/pod/perlsyn.pod index 6359df4e14..3a65b4e9d0 100644 --- a/pod/perlsyn.pod +++ b/pod/perlsyn.pod @@ -674,6 +674,42 @@ case to the next: default { say '$foo does not contain a y' } } +=head3 Return value + +When a C<given> statement is also a valid expression (e.g. +when it's the last statement of a block), it returns : + +=over 4 + +=item * + +An empty list as soon as an explicit C<break> is encountered. + +=item * + +The value of the last evaluated expression of the successful +C<when>/C<default> clause, if there's one. + +=item * + +The value of the last evaluated expression of the C<given> block if no +condition was true. + +=back + +Note that, unlike C<if> and C<unless>, both C<when> and C<default> always +themselves return an empty list. + + my $price = do { given ($item) { + when ([ 'pear', 'apple' ]) { 1 } + break when 'vote'; # My vote cannot be bought + 1e10 when /Mona Lisa/; + 'unknown'; + } }; + +C<given> blocks can't currently be used as proper expressions. This +may be addressed in a future version of perl. + =head3 Switching in a loop Instead of using C<given()>, you can use a C<foreach()> loop. @@ -4059,14 +4059,38 @@ PP(pp_leavegiven) POPBLOCK(cx,newpm); assert(CxTYPE(cx) == CXt_GIVEN); - SP = newsp; - PUTBACK; - - PL_curpm = newpm; /* pop $1 et al */ + 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 */ + } + } + } + PL_curpm = newpm; /* Don't pop $1 et al till now */ LEAVE_with_name("given"); - - return NORMAL; + RETURN; } /* Helper routines used by pp_smartmatch */ @@ -4606,9 +4630,10 @@ PP(pp_enterwhen) fails, we don't want to push a context and then pop it again right away, so we skip straight to the op that follows the leavewhen. + RETURNOP calls PUTBACK which restores the stack pointer after the POPs. */ if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs)) - return cLOGOP->op_other->op_next; + RETURNOP(cLOGOP->op_other->op_next); ENTER_with_name("eval"); SAVETMPS; @@ -4667,7 +4692,8 @@ PP(pp_break) I32 cxix; register PERL_CONTEXT *cx; I32 inner; - + dSP; + cxix = dopoptogiven(cxstack_ix); if (cxix < 0) { if (PL_op->op_flags & OPf_SPECIAL) @@ -4691,7 +4717,8 @@ PP(pp_break) if (CxFOREACH(cx)) return CX_LOOP_NEXTOP_GET(cx); else - return cx->blk_givwhen.leave_op; + /* RETURNOP calls PUTBACK which restores the old old sp */ + RETURNOP(cx->blk_givwhen.leave_op); } STATIC OP * diff --git a/t/op/switch.t b/t/op/switch.t index 92faceffa8..1452b78bb2 100644 --- a/t/op/switch.t +++ b/t/op/switch.t @@ -9,7 +9,7 @@ BEGIN { use strict; use warnings; -plan tests => 132; +plan tests => 160; # The behaviour of the feature pragma should be tested by lib/switch.t # using the tests in t/lib/switch/*. This file tests the behaviour of @@ -1031,6 +1031,138 @@ unreified_check(1,2,undef); unreified_check(undef); unreified_check(undef,""); +# Test do { given } as a rvalue + +{ + # Simple scalar + my $lexical = 5; + my @things = (11 .. 26); # 16 elements + my @exp = (5, 16, 9); + no warnings 'void'; + for (0, 1, 2) { + my $scalar = do { given ($_) { + when (0) { $lexical } + when (2) { 'void'; 8, 9 } + @things; + } }; + is($scalar, shift(@exp), "rvalue given - simple scalar [$_]"); + } +} +{ + # Postfix scalar + my $lexical = 5; + my @exp = (5, 7, 9); + for (0, 1, 2) { + no warnings 'void'; + my $scalar = do { given ($_) { + $lexical when 0; + 8, 9 when 2; + 6, 7; + } }; + is($scalar, shift(@exp), "rvalue given - postfix scalar [$_]"); + } +} +{ + # Default scalar + my @exp = (5, 9, 9); + for (0, 1, 2) { + my $scalar = do { given ($_) { + no warnings 'void'; + when (0) { 5 } + default { 8, 9 } + 6, 7; + } }; + is($scalar, shift(@exp), "rvalue given - default scalar [$_]"); + } +} +{ + # Simple list + my @things = (11 .. 13); + my @exp = ('3 4 5', '11 12 13', '8 9'); + for (0, 1, 2) { + my @list = do { given ($_) { + when (0) { 3 .. 5 } + when (2) { my $fake = 'void'; 8, 9 } + @things; + } }; + is("@list", shift(@exp), "rvalue given - simple list [$_]"); + } +} +{ + # Postfix list + my @things = (12); + my @exp = ('3 4 5', '6 7', '12'); + for (0, 1, 2) { + my @list = do { given ($_) { + 3 .. 5 when 0; + @things when 2; + 6, 7; + } }; + is("@list", shift(@exp), "rvalue given - postfix list [$_]"); + } +} +{ + # Default list + my @things = (11 .. 20); # 10 elements + my @exp = ('m o o', '8 10', '8 10'); + for (0, 1, 2) { + my @list = do { given ($_) { + when (0) { "moo" =~ /(.)/g } + default { 8, scalar(@things) } + 6, 7; + } }; + is("@list", shift(@exp), "rvalue given - default list [$_]"); + } +} +{ + # Switch control + my @exp = ('6 7', '', '6 7'); + for (0, 1, 2, 3) { + my @list = do { given ($_) { + continue when $_ <= 1; + break when 1; + next when 2; + 6, 7; + } }; + is("@list", shift(@exp), "rvalue given - default list [$_]"); + } +} +{ + # Context propagation + my $smart_hash = sub { + do { given ($_[0]) { + 'undef' when undef; + when ([ 1 .. 3 ]) { 1 .. 3 } + when (4) { my $fake; do { 4, 5 } } + } }; + }; + + my $scalar; + + $scalar = $smart_hash->(); + is($scalar, 'undef', "rvalue given - scalar context propagation [undef]"); + + $scalar = $smart_hash->(4); + is($scalar, 5, "rvalue given - scalar context propagation [4]"); + + $scalar = $smart_hash->(999); + is($scalar, undef, "rvalue given - scalar context propagation [999]"); + + my @list; + + @list = $smart_hash->(); + is("@list", 'undef', "rvalue given - list context propagation [undef]"); + + @list = $smart_hash->(2); + is("@list", '1 2 3', "rvalue given - list context propagation [2]"); + + @list = $smart_hash->(4); + is("@list", '4 5', "rvalue given - list context propagation [4]"); + + @list = $smart_hash->(999); + is("@list", '', "rvalue given - list context propagation [999]"); +} + # Okay, that'll do for now. The intricacies of the smartmatch # semantics are tested in t/op/smartmatch.t __END__ |