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;
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;
}
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;
}
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.
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 */
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;
I32 cxix;
register PERL_CONTEXT *cx;
I32 inner;
-
+ dSP;
+
cxix = dopoptogiven(cxstack_ix);
if (cxix < 0) {
if (PL_op->op_flags & OPf_SPECIAL)
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 *
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
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__
projects / p5sagit/p5-mst-13.2.git / commitdiff