The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#include "try-catch-constants.h"
#include "try-catch-op.h"

#include <perl.h>

#define build_assign_op(left_sv, right_op) \
        newASSIGNOP(0, newSVOP(left_sv, 0), OP_SASSIGN, newSVOP(right_sv, 0))

/*
 * append: END_OF_BLOCK_SV
 */
static OP* my_build_block_content_op(pTHX_ OP* orig_content_op) {
    return op_append_elem(OP_LINESEQ,
            orig_content_op,
            newSVOP(OP_CONST, 0, END_OF_BLOCK_SV)
        );
}

/* build optree for catch call arguments:
 *  ( $block_ref, $class_name )
 *  or
 *  ( $block_ref )
 */
static OP* my_build_catch_args_optree(pTHX_ OP* block_op, SV* class_name_sv) {
    OP *class_name_op = class_name_sv ? build_const_sv_op(class_name_sv) : NULL;
    return newLISTOP(OP_LIST, 0, (block_op), class_name_op);
}

#define call_sub_op(name, args_op)  my_call_sub_op(aTHX_ name, args_op)
static OP* my_call_sub_op(pTHX_ char *name, OP* args_op) {
    GV *sub_gv = gv_fetchmethod(internal_stash, name);

    return newUNOP(OP_ENTERSUB, OPf_STACKED,
            op_append_elem(OP_LIST, args_op,
                newGVOP(OP_GV, 0, sub_gv)
            )
        );
}

/* build optree for:
 *  <MAIN_PKG>::_statement($try_block, [@catch_blocks], $finally_block);
 *  or
 *  <MAIN_PKG>::_statement($try_block, [@catch_blocks]);
 */
static OP *my_build_statement_optree(pTHX_
            OP *try_block_op, OP* catch_list_op, OP* finally_block_op
) {
    OP *args_op, *call_op, *return_op;

    catch_list_op = catch_list_op ? newANONLIST(catch_list_op)
                                  : newOP(OP_UNDEF, 0);

    args_op = newLISTOP(OP_LIST, 0, try_block_op, catch_list_op);
    args_op = op_append_elem(OP_LIST, args_op, finally_block_op);

    call_op = call_sub_op("_statement", args_op);
    return_op = newUNOP(OP_RETURN, 0, call_sub_op("_get_return_value", NULL));

    return newCONDOP(0, call_op, return_op, NULL);
}