Merge branch 'vincent/rvalue_stmt_given' into blead
authorVincent Pit <perl@profvince.com>
Wed, 19 May 2010 20:59:58 +0000 (22:59 +0200)
committerVincent Pit <perl@profvince.com>
Wed, 19 May 2010 20:59:58 +0000 (22:59 +0200)
op.c
pod/perlsyn.pod
pp_ctl.c
t/op/switch.t

diff --git a/op.c b/op.c
index 661d0aa..ecc8b88 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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;
 }
index 6359df4..3a65b4e 100644 (file)
@@ -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.
index d203960..6d487ac 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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 *
index 92facef..1452b78 100644 (file)
@@ -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__