[perl #72406] Bad read with do{} until CONST

According to the original bug report, ‘do{print("foobar");}until(1)}’
crashes.  In recent perls it doesn’t, partly because of the slab allo-
cator, partly because such crashes are naturally fleeting.

‘foo while bar’ and ‘foo until bar’ make their way through newLOOPOP,
which then usually calls S_new_logop, to create and AND or OR op with
special pointers that turn it into a loop.

Because S_new_logop knows about folding ‘$x if 1’ down to a simple $x,
and because ‘do{foo()} while 0’ should still execute the do block,
newLOOPOP skips the call to S_new_logop in that case.

Hence, it assumes that if it has seen a do block on its lhs, then
S_new_logop must return an AND or OR op.

‘foo until bar’ is actually changed early on (in perly.y) to ‘foo
while !bar’, before it reaches newLOOPOP.  Constant folding usually
folds !1 down to a simple ""/0 (actually &PL_sv_no), so newLOOPOP sees
‘foo while 0’ for ‘foo until 1’.

If constant folding fails (e.g., because the parser has seen an
unmatched } and constant folding is skipped after such errors), then
newLOOPOP will see the unfolded !1.

S_new_logop has a special optimisation that changes ‘!foo && bar’ to
‘foo || bar’, etc.

That optimisation allows it to ‘see through’ the unoptimised !1 (a NOT
with a CONST kid) and get to the constant, folding the resulting op
and returning something that newLOOPOP is not expecting to be folded.
In the case of ‘do{print("foobar");}until(1)}’, it optimises the do
block away, which is wrong.

So newLOOPOP reads past the end of the op in this line:

	o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;

because it is treating an SVOP as a LOGOP.

I can trigger this condition by defeating constant folding some other
way.  Croaking in boolean overloading, but just the first time, will
do that, and crashes with blead:

{ package o; use overload bool => sub { die unless $::ok++; return 1 } }
use constant OK => bless [], o::;
do{print("foobar");}until OK;
__END__
Bus error: 10

My reading of the source code leads me to believe that this bad read
has been present since perl 5.000.  But back then it was not possible
to trigger it with this particular test case involving fatal overload-
ing (as of b7f7fd0bb it seems*), but ‘do{print("foobar");}until(1)}’
would have triggered it.

* Thanks to Matthew Horsfall for finding it.

diff --git a/op.c b/op.c
index 9c3cc94..d99d318 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6447,7 +6447,15 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
     PERL_UNUSED_ARG(debuggable);
 
     if (expr) {
-       if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
+       if (once && (
+             (expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
+          || (  expr->op_type == OP_NOT
+             && cUNOPx(expr)->op_first->op_type == OP_CONST
+             && SvTRUE(cSVOPx_sv(cUNOPx(expr)->op_first))
+             )
+          ))
+           /* Return the block now, so that S_new_logop does not try to
+              fold it away. */
            return block;       /* do {} while 0 does once */
        if (expr->op_type == OP_READLINE
            || expr->op_type == OP_READDIR
@@ -6486,11 +6494,19 @@ Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
     listop = op_append_elem(OP_LINESEQ, block, newOP(OP_UNSTACK, 0));
     o = new_logop(OP_AND, 0, &expr, &listop);
 
+    if (once) {
+       ASSUME(listop);
+    }
+
     if (listop)
        ((LISTOP*)listop)->op_last->op_next = LINKLIST(o);
 
     if (once && o != listop)
+    {
+       assert(cUNOPo->op_first->op_type == OP_AND
+           || cUNOPo->op_first->op_type == OP_OR);
        o->op_next = ((LOGOP*)cUNOPo->op_first)->op_other;
+    }
 
     if (o == listop)
        o = newUNOP(OP_NULL, 0, o);     /* or do {} while 1 loses outer block */

diff --git a/t/op/while.t b/t/op/while.t
index 5d2af71..1e8eb44 100644 (file)
--- a/t/op/while.t
+++ b/t/op/while.t
@@ -2,10 +2,11 @@
 
 BEGIN {
     chdir 't';
-    require "test.pl";
+    @INC = "../lib";
+    require "./test.pl";
 }
 
-plan(25);
+plan(26);
 
 my $tmpfile = tempfile();
 open (tmp,'>', $tmpfile) || die "Can't create Cmd_while.tmp.";
@@ -213,3 +214,10 @@ sub save_context { $_[0] = wantarray; $_[1] }
     }
     ok($a[0] ne $a[1]);
 }
+
+fresh_perl_is <<'72406', "foobar\n", {},
+{ package o; use overload bool => sub { die unless $::ok++; return 1 } }
+use constant OK => bless [], o::;
+do{print("foobar\n");}until OK;
+72406
+    "[perl #72406] segv with do{}until CONST where const is not folded";