propagate correct ref context to both ?: branches

GH #18669

In something like

    @{ expr } = ...

the expression is expected to return an array ref. If the expression
is something like $h{foo}, then the helem op needs to know both that:
- it is in lvalue context, so should autovivify the foo element if not
  present;
- it is in array ref context, so it should autovivify the value to an
  empty array ref, rather than just to undef.

The function Perl_doref() is used to propagate this ref context at
compile time, e.g. by setting the OPf_MOD and OPpDEREF_AV flags on the
OP_HELEM op.

My commit v5.31.1-87-ge9b0092a10 made this function non-recursive
(so that deep expressions wouldn't SEGV during compilation), but
introduced a bug when the expression included the ternary condition
operator, '?:'.

In particular, since '?:' is the only OP where doref() needs to recurse
down *two* branches, I made the function just iterate down the tree, and
then have special handling for OP_COND_EXPR. This involved, once having
finished iterating down the tree, to work back up the tree looking for
OP_COND_EXPR nodes, and if found, iterate back down the second branch.

This had a fatal flaw: a 'type' variable indicated what context to
apply. For example in @{$h{expr}} = ..., type would start off as
OP_RV2AV, but as the tree was walked, would change to OP_HELEM and then
to OP_RV2HV. When walking back up the tree, this value wasn't being restored.

The specific bug in the ticket boiled down to something like

    @{ $cond ? $h{p} : $h{q} } = ...;

where the correct OPpDEREF_AV flag was being set on the first helem op,
but an incorrect OPpDEREF_HV on the second.

Since I can't think of anything better, the fix in this commit restores
some limited recursion to doref(). Namely, for an OP_COND_EXPR op, it
now recurses down that op's first branch, then after it returns,
iterates as normal down the second branch.

Thus extremely deeply nested ternary code like:

    @{ $c1 ? $c2 ? $c3 ? .... } ...

could start to SEGV during compilation again.

Author: iabyn

op.c

@@ -3774,7 +3774,13 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
             break;
 
         case OP_COND_EXPR:
+            /* OP_COND_EXPR is the only op where we have to propagate
+             * context to *both* branches. Recurse on the first branch,
+             * then iterate on the second branch.
+             */
             o = OpSIBLING(cUNOPo->op_first);
+            doref(o, type, set_op_ref);
+            o = OpSIBLING(o);
             continue;
 
         case OP_RV2SV:
@@ -3847,22 +3853,12 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
             break;
         } /* switch */
 
-        while (1) {
-            if (o == top_op)
-                return scalar(top_op); /* at top; no parents/siblings to try */
-            if (OpHAS_SIBLING(o)) {
-                o = o->op_sibparent;
-                /* Normally skip all siblings and go straight to the parent;
-                 * the only op that requires two children to be processed
-                 * is OP_COND_EXPR */
-                if (!OpHAS_SIBLING(o)
-                        && o->op_sibparent->op_type == OP_COND_EXPR)
-                    break;
-                continue;
-            }
-            o = o->op_sibparent; /* try parent's next sibling */
-        }
+        /* whole tree has been scanned for ref stuff; now propagate
+         * scalar context */
+        return scalar(top_op);
+
     } /* while */
+
 }
 
 

t/op/ref.t

@@ -8,7 +8,7 @@ BEGIN {
 
 use strict qw(refs subs);
 
-plan(257);
+plan(265);
 
 # Test this first before we extend the stack with other operations.
 # This caused an asan failure due to a bad write past the end of the stack.
@@ -913,6 +913,47 @@ EOF
                     'rt#130861: heap uaf in pp_rv2sv');
 }
 
+# GH 18669
+# The correct autovivification lvalue ref context should be propagated to
+# both branches of a ?:. So in something like:
+#    @{  $cond ? $h{a} : $h{b} } = ...;
+# the helem ops on *both* sides of the conditional should get the DREFAV
+# flag set, indicating that if the hash element doesn't exist, it should
+# be autovivified as an *array ref*.
+#
+
+{
+    my $x = { arr => undef };
+    eval {
+        push(@{ $x->{ decide } ? $x->{ not_here } : $x->{ new } }, "mana");
+    };
+
+    is($@, "", "GH 18669: push on non-existent hash ref entry: no errors");
+    is(eval {$x->{new}[0] }, 'mana',
+        "GH 18669: push on non-existent hash ref entry: autovivifies"
+    );
+
+    $x = { arr => undef };
+    eval {
+        push(@{ $x->{ decide } ? $x->{ not_here } : $x->{ arr } }, "mana");
+    };
+
+    is($@, "", "GH 18669: push on undef hash ref entry: no errors");
+    is(eval { $x->{arr}[0] }, 'mana',
+        "GH 18669: push on undef hash ref entry: autovivifies"
+    );
+
+    # try both branches
+    for my $cond (0, 1) {
+        my %h;
+        eval { @{ $cond ? $h{p} : $h{q} } = 99; };
+        is($@, "", "GH 18669: array assign on $cond cond: no errors");
+        is($h{$cond ? 'p' : 'q'}[0], 99,
+            "GH 18669: array assign on $cond cond: autovivifies"
+        );
+    }
+}
+
 # Bit of a hack to make test.pl happy. There are 3 more tests after it leaves.
 $test = curr_test();
 curr_test($test + 3);

t/run/todo.t

@@ -352,41 +352,6 @@ TODO: {
     is($?, 0, "No panic; GH 16971");
 }
 
-TODO: {
-    local $::TODO = 'GH 18669';
-
-    my $x = { arr => undef };
-    eval {
-        push(@{ $x->{ decide } ? $x->{ not_here } : $x->{ new } }, "mana");
-    };
-    unlike(
-        $@,
-        qr/Not an ARRAY reference/,
-        "push on non-existent hash entry does not throw 'Not an ARRAY reference' error; GH 18669"
-    );
-    is(
-        eval { $x->{ new }[0] },
-        'mana',
-        'push on non-existent hash entry from ternary autovivifies array ref; GH 18669'
-    );
-
-    $x = { arr => undef };
-    eval {
-        push(@{ $x->{ decide } ? $x->{ not_here } : $x->{ arr } }, "mana");
-    };
-    unlike(
-        $@,
-        qr/Not an ARRAY reference/,
-        "push on undef hash entry does not throw 'Not an ARRAY reference' error; GH 18669"
-    );
-    is(
-        eval { $x->{ arr }[0] },
-        'mana',
-        'push on undef hash entry from ternary autovivifies array ref; GH 18669'
-    );
-
-}
-
 TODO: {
     local $::TODO = 'GH 19378';
     fresh_perl_like(