pp_ctl.c - in try_yyparse do not leak PL_restartop from compile that dies

Fix GH Issue #20396, try_yyparse() breaks Attribute::Handlers.

Reduced test case is:

    perl -e'CHECK { eval "]" }'

which should not assert or segfault.

In c304acb we made it so that when doeval_compile() is executed and it
calls yyparse() inside of an eval any exceptions that occur during the
parse process are trapped by try_yyparse() so that exection would return
to doeval_compile(). This was done so that post eval compilation cleanup
logic could be handled similarly regardless of whether Perl_croak() was
called or not. However the logic to setup PL_restartop was not adjusted
accordingly.

The opcode that calls doeval_compile() setups an eval context data
before it calls doeval_compile(). This data includes the "retop" which
is used to return control to after the eval should it die and is set to
the be the evaling opcodes op_next. When Perl_die_unwind() is called it
sets PL_restartop to be the "retop" of the of the current eval frame,
and then does a longjmp, on the assumption it will end up inside of a
"run loop enabled jump enviornment", where it restarts the run loop
based on the value of PL_restartop, zeroing it aftewards.

After c304acb however, a die inside of try_yyparse the die_unwind
returns control back to the try_yyparse, which ignores PL_restartop, and
leaves it set. Code then goes through the "compilation failed" branch
and execution returns to PL_restartop /anyway/, as PL_op hasn't changed
and pp_entereval returns control to PL_op->op_next, which is what we
pushed into the eval context anyway for the PL_restartop.

The end result of this however is that PL_restartop remains set when we
enter perl_run() for the first time. perl_run() is a "run loop enabled
jump enviornment" which uses run_body() to do its business, such that
when PL_restartop is NULL it executes the just compiled body of the
program, and when PL_restartop is not null it assumes it must be in the
eval handler from an eval from the main body and it should recontinue.
The leaked PL_restartop is thus executed instead of the main program
body and things go horribly wrong.

This patch changes it so that when try_yyparse traps an exception we
restore PL_restartop back to its old value. Same for its partner
PL_restartjmpenv. This is fine as they have been set to the values from
the beginning of the eval frame which we are part of, which is now over.

Author: demerphq

perl.c

@@ -2701,6 +2701,11 @@ perl_run(pTHXx)
 #ifndef MULTIPLICITY
     PERL_UNUSED_ARG(my_perl);
 #endif
+    /* perl_parse() may end up starting its own run loops, which might end
+     * up "leaking" PL_restartop from the parse phase into the run phase
+     * which then ends up confusing run_body(). This leakage shouldn't
+     * happen and if it does its a bug. */
+    assert(!PL_restartop);
 
     oldscope = PL_scopestack_ix;
 #ifdef VMS

pp_ctl.c

@@ -3533,10 +3533,17 @@ Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
  *   3: yyparse() died
  */
 STATIC int
-S_try_yyparse(pTHX_ int gramtype)
+S_try_yyparse(pTHX_ int gramtype, OP *caller_op)
 {
-    int ret;
+    /* if we die during compilation PL_restartop and PL_restartjmpenv
+     * will be set by Perl_die_unwind(). We need to restore their values
+     * if that happens as they are intended for the case where the code
+     * compiles and dies during execution, not where it dies during
+     * compilation. */
+    JMPENV *restartjmpenv = PL_restartjmpenv;
+    OP *restartop = PL_restartop;
     dJMPENV;
+    int ret;
 
     assert(CxTYPE(CX_CUR()) == CXt_EVAL);
     JMPENV_PUSH(ret);
@@ -3545,6 +3552,11 @@ S_try_yyparse(pTHX_ int gramtype)
         ret = yyparse(gramtype) ? 1 : 0;
         break;
     case 3:
+        /* yyparse() died and we trapped the error. We need to restore
+         * the old PL_restartjmpenv and PL_restartop values. */
+        assert(PL_restartop == caller_op->op_next); /* we expect these to match */
+        PL_restartjmpenv = restartjmpenv;
+        PL_restartop = restartop;
         break;
     default:
         JMPENV_POP;
@@ -3724,19 +3736,23 @@ S_doeval_compile(pTHX_ U8 gimme, CV* outside, U32 seq, HV *hh)
      * always handle that case. */
     assert(!CATCH_GET);
     /* compile the code */
+
+
     yystatus = (!in_require)
-               ? S_try_yyparse(aTHX_ GRAMPROG)
+               ? S_try_yyparse(aTHX_ GRAMPROG, saveop)
                : yyparse(GRAMPROG);
 
     if (yystatus || PL_parser->error_count || !PL_eval_root) {
         PERL_CONTEXT *cx;
         SV *errsv;
 
         PL_op = saveop;
-        /* note that if yystatus == 3, then the require/eval died during
-         * compilation, so the EVAL CX block has already been popped, and
-         * various vars restored */
         if (yystatus != 3) {
+            /* note that if yystatus == 3, then the require/eval died during
+             * compilation, so the EVAL CX block has already been popped, and
+             * various vars restored. This block applies similar steps after
+             * the other "failed to compile" cases in yyparse, eg, where
+             * yystatus=1, "failed, but did not die". */
             if (PL_eval_root) {
                 op_free(PL_eval_root);
                 PL_eval_root = NULL;

t/op/eval.t

@@ -6,7 +6,7 @@ BEGIN {
     set_up_inc('../lib');
 }
 
-plan(tests => 152);
+plan(tests => 160);
 
 eval 'pass();';
 
@@ -723,10 +723,17 @@ pass("eval in freed package does not crash");
         'eval "UNITCHECK { eval q(UNITCHECK { die; }); print q(A-) }";',
         'eval "UNITCHECK { eval q(BEGIN     { die; }); print q(A-) }";',
         'eval "BEGIN     { eval q(UNITCHECK { die; }); print q(A-) }";',
+        'CHECK     { eval "]" } print q"A-";',
+        'INIT      { eval "]" } print q"A-";',
+        'UNITCHECK { eval "]" } print q"A-";',
+        'BEGIN     { eval "]" } print q"A-";',
     ) {
         fresh_perl_is($line . ' print "ok";', "A-ok", {}, "No segfault: $line");
-        my $sort_line= 'my @x= sort { ' . $line . ' } 1,2;';
-        fresh_perl_is($line . ' print "ok";', "A-ok", {}, "No segfault: $line");
 
+        # sort blocks are somewhat special and things that work in normal blocks
+        # can blow up in sort blocks, so test these constructs specially.
+        my $sort_line= 'my @x= sort { ' . $line . ' } 1,2;';
+        fresh_perl_is($sort_line . ' print "ok";', "A-ok", {},
+            "No segfault inside sort: $sort_line");
     }
 }