[perl #120374] Stop for($h{k}||'') from vivifying

Commit 2e73d70e52 broke this (made it vivify) by propagating lvalue
context to the branches of || and && (to fix another bug).  It broke
App::JobLog as a result.

Because foreach does not do defelem magic (i.e., it vivifies), this
ends up extending vivification to happen where it did not before.

Fixing foreach to do defelem magic (create ‘deferred element’ scalars,
the way sub calls do, to avoid vivifying immediately) would be another
way to fix this, but it is controversial.  See ticket #2166.

So, if either argument to || (or &&) is a vivifying op, don’t propa-
gate the lvalue context, unless this is the return value of an lvalue
sub (necessary for if/else with implicit return to work correctly in
lvalue subs).

diff --git a/op.c b/op.c
index 1008a3b..0174e32 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2057,6 +2057,21 @@ such as C<$$x = 5> which might have to vivify a reference in C<$x>.
 =cut
 */
 
+static bool
+S_vivifies(const OPCODE type)
+{
+    switch(type) {
+    case OP_RV2AV:     case   OP_ASLICE:
+    case OP_RV2HV:     case OP_KVASLICE:
+    case OP_RV2SV:     case   OP_HSLICE:
+    case OP_AELEMFAST: case OP_KVHSLICE:
+    case OP_HELEM:
+    case OP_AELEM:
+       return 1;
+    }
+    return 0;
+}
+
 OP *
 Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
 {
@@ -2343,8 +2358,12 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
 
     case OP_AND:
     case OP_OR:
-       op_lvalue(cLOGOPo->op_first,             type);
-       op_lvalue(cLOGOPo->op_first->op_sibling, type);
+       if (type == OP_LEAVESUBLV
+        || !S_vivifies(cLOGOPo->op_first->op_type))
+           op_lvalue(cLOGOPo->op_first, type);
+       if (type == OP_LEAVESUBLV
+        || !S_vivifies(cLOGOPo->op_first->op_sibling->op_type))
+           op_lvalue(cLOGOPo->op_first->op_sibling, type);
        goto nomod;
     }
 

diff --git a/t/op/or.t b/t/op/or.t
index 056989f..9e7de4c 100644 (file)
--- a/t/op/or.t
+++ b/t/op/or.t
@@ -25,7 +25,7 @@ sub FETCH {
 package main;
 require './test.pl';
 
-plan( tests => 11 );
+plan( tests => 14 );
 
 
 my ($a, $b, $c);
@@ -71,7 +71,20 @@ $y = " ";
 for (pos $x || pos $y) {
     eval { $_++ };
 }
-is(pos($y) || $@, 1, "|| propagates lvaluish context");
+is(pos($y) || $@, 1, "|| propagates lvaluish context to its rhs");
+
+$x = "  ";
+pos $x = 1;
+for (pos $x || pos $y) {
+    eval { $_++ };
+}
+is(pos($x) || $@, 2, "|| propagates lvaluish context to its lhs");
+
+for ($h{k} || $h{l}) {}
+ok(!exists $h{k},
+  "|| does not propagate lvaluish cx to a subscript on its lhs");
+ok(!exists $h{l},
+  "|| does not propagate lvaluish cx to a subscript on its rhs");
 
 my $aa, $bb, $cc;
 $bb = 1;