1 files changed, 90 insertions, 11 deletions

diff --git a/op.c b/op.c
index e791032430..ae7c3209d8 100644
--- a/op.c
+++ b/op.c
@@ -6699,6 +6699,7 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
 	|| (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
 	|| type == OP_SASSIGN
 	|| type == OP_ENTERTRY
+        || type == OP_ENTERTRYCATCH
 	|| type == OP_CUSTOM
 	|| type == OP_NULL );
 
@@ -9834,27 +9835,42 @@ The C<flags> argument is currently ignored.
 OP *
 Perl_newTRYCATCHOP(pTHX_ I32 flags, OP *tryblock, OP *catchvar, OP *catchblock)
 {
-    OP *tryop, *catchop;
+    OP *o, *catchop;
 
     PERL_ARGS_ASSERT_NEWTRYCATCHOP;
     assert(catchvar->op_type == OP_PADSV);
 
     PERL_UNUSED_ARG(flags);
 
-    tryop = newUNOP(OP_ENTERTRY, OPf_SPECIAL, tryblock);
+    /* The returned optree is shaped as:
+     *   LISTOP leavetrycatch
+     *       LOGOP entertrycatch
+     *       LISTOP poptry
+     *           $tryblock here
+     *       LOGOP catch
+     *           $catchblock here
+     */
+
+    if(tryblock->op_type != OP_LINESEQ)
+        tryblock = op_convert_list(OP_LINESEQ, 0, tryblock);
+    OpTYPE_set(tryblock, OP_POPTRY);
 
-    catchop = newLOGOP(OP_CATCH, 0,
-        newOP(OP_NULL, 0), /* LOGOP always needs an op_first */
-        catchblock);
+    /* Manually construct a naked LOGOP.
+     * Normally if we call newLOGOP the returned value is a UNOP(OP_NULL)
+     * containing the LOGOP we wanted as its op_first */
+    catchop = (OP *)alloc_LOGOP(OP_CATCH, newOP(OP_NULL, 0), catchblock);
+    OpMORESIB_set(cUNOPx(catchop)->op_first, catchblock);
+    OpLASTSIB_set(catchblock, catchop);
 
-    /* catchblock itself is an OP_NULL; the real OP_CATCH is its op_first */
-    assert(cUNOPx(catchop)->op_first->op_type == OP_CATCH);
-    cUNOPx(catchop)->op_first->op_targ = catchvar->op_targ;
+    /* Inject the catchvar's pad offset into the OP_CATCH targ */
+    cLOGOPx(catchop)->op_targ = catchvar->op_targ;
     op_free(catchvar);
 
-    return op_append_list(OP_LEAVE,
-      newOP(OP_ENTER, 0),
-      op_append_list(OP_LINESEQ, tryop, catchop));
+    /* Build the optree structure */
+    o = newLISTOP(OP_LIST, 0, tryblock, catchop);
+    o = op_convert_list(OP_ENTERTRYCATCH, 0, o);
+
+    return o;
 }
 
 /*
@@ -12842,6 +12858,69 @@ Perl_ck_eval(pTHX_ OP *o)
 }
 
 OP *
+Perl_ck_trycatch(pTHX_ OP *o)
+{
+    LOGOP *enter;
+    OP *to_free = NULL;
+    OP *trykid, *catchkid;
+    OP *catchroot, *catchstart;
+
+    PERL_ARGS_ASSERT_CK_TRYCATCH;
+
+    trykid = cUNOPo->op_first;
+    if(trykid->op_type == OP_NULL || trykid->op_type == OP_PUSHMARK) {
+        to_free = trykid;
+        trykid = OpSIBLING(trykid);
+    }
+    catchkid = OpSIBLING(trykid);
+
+    assert(trykid->op_type == OP_POPTRY);
+    assert(catchkid->op_type == OP_CATCH);
+
+    /* cut whole sibling chain free from o */
+    op_sibling_splice(o, NULL, -1, NULL);
+    if(to_free)
+        op_free(to_free);
+    op_free(o);
+
+    enter = alloc_LOGOP(OP_ENTERTRYCATCH, NULL, NULL);
+
+    /* establish postfix order */
+    enter->op_next = (OP*)enter;
+
+    o = op_prepend_elem(OP_LINESEQ, (OP*)enter, trykid);
+    op_append_elem(OP_LINESEQ, (OP*)o, catchkid);
+
+    OpTYPE_set(o, OP_LEAVETRYCATCH);
+
+    /* The returned optree is actually threaded up slightly nonobviously in
+     * terms of its ->op_next pointers.
+     *
+     * This way, if the tryblock dies, its retop points at the OP_CATCH, but
+     * if it does not then its leavetry skips over that and continues
+     * execution past it.
+     */
+
+    /* First, link up the actual body of the catch block */
+    catchroot = OpSIBLING(cUNOPx(catchkid)->op_first);
+    catchstart = LINKLIST(catchroot);
+    cLOGOPx(catchkid)->op_other = catchstart;
+
+    o->op_next = LINKLIST(o);
+
+    /* die within try block should jump to the catch */
+    enter->op_other = catchkid;
+
+    /* after try block that doesn't die, just skip straight to leavetrycatch */
+    trykid->op_next = o;
+
+    /* after catch block, skip back up to the leavetrycatch */
+    catchroot->op_next = o;
+
+    return o;
+}
+
+OP *
 Perl_ck_exec(pTHX_ OP *o)
 {
     PERL_ARGS_ASSERT_CK_EXEC;