File Coverage

lib/Syntax/Keyword/Try.xs

Criterion	Covered	Total	%
statement	199	210	94.7
branch	109	150	72.6
condition			n/a
subroutine			n/a
pod			n/a
total	308	360	85.5

/*  You may distribute under the terms of either the GNU General Public License
  *  or the Artistic License (the same terms as Perl itself)
  *
  *  (C) Paul Evans, 2016-2021 -- [e-mail]
  */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "XSParseKeyword.h"

#include "perl-backcompat.c.inc"

#if HAVE_PERL_VERSION(5,32,0)
#  define HAVE_OP_ISA
#endif

#if HAVE_PERL_VERSION(5,26,0)
#  define HAVE_OP_SIBPARENT
#endif

#if HAVE_PERL_VERSION(5,19,4)
typedef SSize_t array_ix_t;
#else /* <5.19.4 */
typedef I32 array_ix_t;
#endif /* <5.19.4 */

#include "perl-additions.c.inc"
#include "optree-additions.c.inc"
#include "op_sibling_splice.c.inc"
#include "newOP_CUSTOM.c.inc"
#include "cop_warnings.c.inc"

static OP *pp_entertrycatch(pTHX);
static OP *pp_catch(pTHX);

/*
  * A modified version of pp_return for returning from inside a try block.
  * To do this, we unwind the context stack to just past the CXt_EVAL and then
  * chain to the regular OP_RETURN func
  */
static OP *pp_returnintry(pTHX)
{
  I32 cxix;

  for (cxix = cxstack_ix; cxix; cxix--) {
    if(CxTYPE(&cxstack[cxix]) == CXt_SUB)
      break;

    if(CxTYPE(&cxstack[cxix]) == CXt_EVAL && CxTRYBLOCK(&cxstack[cxix])) {
      /* If this CXt_EVAL frame came from our own ENTERTRYCATCH, then the
              * retop should point at an OP_CUSTOM and its first grand-child will be
              * our custom modified ENTERTRY. We can skip over it and continue in
              * this case.
              */
      OP *retop = cxstack[cxix].blk_eval.retop;
      OP *leave, *enter;
      if(retop->op_type == OP_CUSTOM && retop->op_ppaddr == &pp_catch &&
         (leave = cLOGOPx(retop)->op_first) && leave->op_type == OP_LEAVETRY &&
         (enter = cLOGOPx(leave)->op_first) && enter->op_type == OP_ENTERTRY &&
         enter->op_ppaddr == &pp_entertrycatch) {
        continue;
      }
      /* We have to stop at any other kind of CXt_EVAL */
      break;
    }
  }
  if(!cxix)
    croak("Unable to find an CXt_SUB to pop back to");

  I32 gimme = cxstack[cxix].blk_gimme;
  SV *retval;

  /* chunks of this code inspired by
      *   ZEFRAM/Scope-Escape-0.005/lib/Scope/Escape.xs
   */
    switch(gimme) {
        case G_VOID:
            (void)POPMARK;
            break;

        case G_SCALAR: {
            dSP;
            dMARK;
            retval = (MARK == SP) ? &PL_sv_undef : TOPs;
            SvREFCNT_inc(retval);
            sv_2mortal(retval);
            break;
        }

        case G_LIST: {
            dSP;
            dMARK;
            SV **retvals = MARK+1;
            array_ix_t retcount = SP-MARK;
            array_ix_t i;
            AV *retav = newAV();
            retval = (SV *)retav;
            sv_2mortal(retval);
            av_fill(retav, retcount-1);
            Copy(retvals, AvARRAY(retav), retcount, SV *);
            for(i = 0; i < retcount; i++)
                SvREFCNT_inc(retvals[i]);
            break;
        }
    }

    dounwind(cxix);

    /* Now put the value back */
    switch(gimme) {
        case G_VOID: {
            dSP;
            PUSHMARK(SP);
            break;
        }

        case G_SCALAR: {
            dSP;
            PUSHMARK(SP);
            XPUSHs(retval);
            PUTBACK;
            break;
        }

        case G_LIST: {
            dSP;
            PUSHMARK(SP);
            AV *retav = (AV *)retval;
            array_ix_t retcount = av_len(retav) + 1; /* because av_len means top index */
      EXTEND(SP, retcount);
      Copy(AvARRAY(retav), SP+1, retcount, SV *);
      SP += retcount;
      PUTBACK;
      break;
    }
  }

  return PL_ppaddr[OP_RETURN](aTHX);
}

/*
  * A custom SVOP that takes a CV and arranges for it to be invoked on scope
  * leave
  */
static XOP xop_pushfinally;

static void invoke_finally(pTHX_ void *arg)
{
  CV *finally = arg;
  dSP;

  PUSHMARK(SP);
  call_sv((SV *)finally, G_DISCARD|G_EVAL|G_KEEPERR);

  SvREFCNT_dec(finally);
}

static OP *pp_pushfinally(pTHX)
{
  CV *finally = (CV *)cSVOP->op_sv;

  /* finally is a closure protosub; we have to clone it into a real sub.
      * If we do this now then captured lexicals still work even around
      * Future::AsyncAwait (see RT122796)
      * */
  SAVEDESTRUCTOR_X(&invoke_finally, (SV *)cv_clone(finally));
  return PL_op->op_next;
}

#define newLOCALISEOP(gv)  MY_newLOCALISEOP(aTHX_ gv)
static OP *MY_newLOCALISEOP(pTHX_ GV *gv)
{
  OP *op = newGVOP(OP_GVSV, 0, gv);
  op->op_private |= OPpLVAL_INTRO;
  return op;
}

#define newSTATEOP_nowarnings()  MY_newSTATEOP_nowarnings(aTHX)
static OP *MY_newSTATEOP_nowarnings(pTHX)
{
  OP *op = newSTATEOP(0, NULL, NULL);
  cop_disable_warning((COP *)op, WARN_EXITING);
  return op;
}

static void rethread_op(OP *op, OP *old, OP *new)
{
  if(op->op_next == old)
    op->op_next = new;

  switch(OP_CLASS(op)) {
    case OA_LOGOP:
      if(cLOGOPx(op)->op_other == old)
        cLOGOPx(op)->op_other = new;
      break;

    case OA_LISTOP:
      if(cLISTOPx(op)->op_last == old)
        cLISTOPx(op)->op_last = new;
      break;
  }

  if(op->op_flags & OPf_KIDS) {
    OP *kid;
    for(kid = cUNOPx(op)->op_first; kid; kid = OpSIBLING(kid))
      rethread_op(kid, old, new);
  }
}

#define walk_optree_try_in_eval(op_ptr, root)  MY_walk_optree_try_in_eval(aTHX_ op_ptr, root)
static void MY_walk_optree_try_in_eval(pTHX_ OP **op_ptr, OP *root);
static void MY_walk_optree_try_in_eval(pTHX_ OP **op_ptr, OP *root)
{
  OP *op = *op_ptr;

  switch(op->op_type) {
    /* Fix 'return' to unwind the CXt_EVAL block that implements try{} first */
    case OP_RETURN:
      op->op_ppaddr = &pp_returnintry;
      break;

    /* wrap  no warnings 'exiting' around loop controls */
    case OP_NEXT:
    case OP_LAST:
    case OP_REDO:
      {
#ifdef HAVE_OP_SIBPARENT
        OP *parent = OpHAS_SIBLING(op) ? NULL : op->op_sibparent;
#endif

        OP *stateop = newSTATEOP_nowarnings();

        OP *scope = newLISTOP(OP_SCOPE, 0,
          stateop, op);
#ifdef HAVE_OP_SIBPARENT
        if(parent)
          OpLASTSIB_set(scope, parent);
        else
          OpLASTSIB_set(scope, NULL);
#else
        op->op_sibling = NULL;
#endif

        /* Rethread */
        scope->op_next = stateop;
        stateop->op_next = op;

        *op_ptr = scope;
      }
      break;

    /* Don't enter inside nested eval{} blocks */
    case OP_LEAVETRY:
      return;
  }

  if(op->op_flags & OPf_KIDS) {
    OP *kid, *next, *prev = NULL;
    for(kid = cUNOPx(op)->op_first; kid; kid = next) {
      OP *newkid = kid;
      next = OpSIBLING(kid);

      walk_optree_try_in_eval(&newkid, root);

      if(newkid != kid) {
        rethread_op(root, kid, newkid);

        if(prev) {
          OpMORESIB_set(prev, newkid);
        }
        else
          cUNOPx(op)->op_first = newkid;

        if(next)
          OpMORESIB_set(newkid, next);
      }

      prev = kid;
    }
  }
}

static OP *pp_entertrycatch(pTHX)
{
  /* Localise the errgv */
  save_scalar(PL_errgv);

  return PL_ppaddr[OP_ENTERTRY](aTHX);
}

static XOP xop_catch;

static OP *pp_catch(pTHX)
{
  /* If an error didn't happen, then ERRSV will be both not true and not a
      * reference. If it's a reference, then an error definitely happened
      */
  if(SvROK(ERRSV) || SvTRUE(ERRSV))
    return cLOGOP->op_other;
  else
    return cLOGOP->op_next;
}

#define newENTERTRYCATCHOP(flags, try, catch)  MY_newENTERTRYCATCHOP(aTHX_ flags, try, catch)
static OP *MY_newENTERTRYCATCHOP(pTHX_ U32 flags, OP *try, OP *catch)
{
  OP *enter, *entertry, *ret;

  /* Walk the block for OP_RETURN ops, so we can apply a hack to them to
      * make
      *   try { return }
      * return from the containing sub, not just the eval block
      */
  walk_optree_try_in_eval(&try, try);

  enter = newUNOP(OP_ENTERTRY, 0, try);
  /* despite calling newUNOP(OP_ENTERTRY,...) the returned root node is the
      * OP_LEAVETRY, whose first child is the ENTERTRY we wanted
      */
  entertry = ((UNOP *)enter)->op_first;
  entertry->op_ppaddr = &pp_entertrycatch;

  /* If we call newLOGOP_CUSTOM it will op_contextualize the enter block into
      * G_SCALAR. This is not what we want
      */
  {
    LOGOP *logop;

    OP *first = enter, *other = newLISTOP(OP_SCOPE, 0, catch, NULL);

    NewOp(1101, logop, 1, LOGOP);

    logop->op_type = OP_CUSTOM;
    logop->op_ppaddr = &pp_catch;
    logop->op_first = first;
    logop->op_flags = OPf_KIDS;
    logop->op_other = LINKLIST(other);

    logop->op_next = LINKLIST(first);
    enter->op_next = (OP *)logop;
#if HAVE_PERL_VERSION(5, 22, 0)
    op_sibling_splice((OP *)logop, first, 0, other);
#else
    first->op_sibling = other;
#endif

    ret = newUNOP(OP_NULL, 0, (OP *)logop);
    other->op_next = ret;
  }

  return ret;
}

#ifndef HAVE_OP_ISA
static XOP xop_isa;

/* Totally stolen from perl 5.32.0's pp.c */
#define sv_isa_sv(sv, namesv)  S_sv_isa_sv(aTHX_ sv, namesv)
static bool S_sv_isa_sv(pTHX_ SV *sv, SV *namesv)
{
  if(!SvROK(sv) || !SvOBJECT(SvRV(sv)))
    return FALSE;

  /* TODO: ->isa invocation */

#if HAVE_PERL_VERSION(5,16,0)
  return sv_derived_from_sv(sv, namesv, 0);
#else
  return sv_derived_from(sv, SvPV_nolen(namesv));
#endif
}

static OP *pp_isa(pTHX)
{
  dSP;

  SV *left, *right;

  right = POPs;
  left  = TOPs;

  SETs(boolSV(sv_isa_sv(left, right)));
  RETURN;
}
#endif

static int build_try(pTHX_ OP **out, XSParseKeywordPiece *args[], size_t nargs, void *hookdata)
{
  U32 argi = 0;

  OP *try = args[argi++]->op;

  OP *ret = NULL;
  HV *hints = GvHV(PL_hintgv);

  bool require_catch = hints && hv_fetchs(hints, "Syntax::Keyword::Try/require_catch", 0);
  bool require_var   = hints && hv_fetchs(hints, "Syntax::Keyword::Try/require_var", 0);

  U32 ncatches = args[argi++]->i;

  AV *condcatch = NULL;
  OP *catch = NULL;
  while(ncatches--) {
    bool has_catchvar = args[argi++]->i;
    PADOFFSET catchvar = has_catchvar ? args[argi++]->padix : 0;
    int catchtype = has_catchvar ? args[argi++]->i : -1;

    bool warned = FALSE;

    OP *condop = NULL;

    switch(catchtype) {
      case -1: /* no type */
        break;

      case 0: /* isa */
      {
        OP *type = args[argi++]->op;
#ifdef HAVE_OP_ISA
        condop = newBINOP(OP_ISA, 0,
          newPADxVOP(OP_PADSV, 0, catchvar), type);
#else
        /* Allow a bareword on RHS of `isa` */
        if(type->op_type == OP_CONST)
          type->op_private &= ~(OPpCONST_BARE|OPpCONST_STRICT);

        condop = newBINOP_CUSTOM(&pp_isa, 0,
          newPADxVOP(OP_PADSV, 0, catchvar), type);
#endif
        break;
      }

      case 1: /* =~ */
      {
        OP *regexp = args[argi++]->op;

        if(regexp->op_type != OP_MATCH || cPMOPx(regexp)->op_first)
          croak("Expected a regexp match");
#if HAVE_PERL_VERSION(5,22,0)
        /* Perl 5.22+ uses op_targ on OP_MATCH directly */
        regexp->op_targ = catchvar;
#else
        /* Older perls need a stacked OP_PADSV op */
        cPMOPx(regexp)->op_first = newPADxVOP(OP_PADSV, 0, catchvar);
        regexp->op_flags |= OPf_KIDS|OPf_STACKED;
#endif
        condop = regexp;
        break;
      }

      default:
        croak("TODO\n");
    }

#ifdef WARN_EXPERIMENTAL
    if(condop && !warned &&
      (!hints || !hv_fetchs(hints, "Syntax::Keyword::Try/experimental(typed)", 0))) {
      warned = true;
      Perl_ck_warner(aTHX_ packWARN(WARN_EXPERIMENTAL),
        "typed catch syntax is experimental and may be changed or removed without notice");
    }
#endif

    OP *body = args[argi++]->op;

    if(require_var && !has_catchvar)
      croak("Expected (VAR) for catch");

    if(catch)
      croak("Already have a default catch {} block");

    OP *assignop = NULL;
    if(catchvar) {
      /* my $var = $@ */
      assignop = newBINOP(OP_SASSIGN, 0,
        newGVOP(OP_GVSV, 0, PL_errgv), newPADxVOP(OP_PADSV, OPf_MOD | OPpLVAL_INTRO << 8, catchvar));
    }

    if(condop) {
      if(!condcatch)
        condcatch = newAV();

      av_push(condcatch, (SV *)op_append_elem(OP_LINESEQ, assignop, condop));
      av_push(condcatch, (SV *)body);
      /* catch remains NULL for now */
    }
    else if(assignop) {
      catch = op_prepend_elem(OP_LINESEQ,
        assignop, body);
    }
    else
      catch = body;
  }

  if(condcatch) {
    I32 i;

    if(!catch)
      /* A default fallthrough */
            /*   die $@ */
            catch = newLISTOP(OP_DIE, 0,
                newOP(OP_PUSHMARK, 0), newGVOP(OP_GVSV, 0, PL_errgv));

        for(i = AvFILL(condcatch)-1; i >= 0; i -= 2) {
            OP *body   = (OP *)av_pop(condcatch),
                  *condop = (OP *)av_pop(condcatch);

            catch = newCONDOP(0, condop, op_scope(body), catch);
        }

        SvREFCNT_dec(condcatch);
    }

    if(require_catch && !catch)
        croak("Expected a catch {} block");

    bool no_finally = hints && hv_fetchs(hints, "Syntax::Keyword::Try/no_finally", 0);

    U32 has_finally = args[argi++]->i;
    CV *finally = has_finally ? args[argi++]->cv : NULL;

    if(no_finally && finally)
        croak("finally {} is not permitted here");

    if(!catch && !finally) {
        op_free(try);
        croak(no_finally
            ? "Expected try {} to be followed by catch {}"
            : "Expected try {} to be followed by either catch {} or finally {}");
    }

    ret = try;

    if(catch) {
        ret = newENTERTRYCATCHOP(0, try, catch);
    }

    /* If there's a finally, make
      *   $RET = OP_PUSHFINALLY($FINALLY); $RET
      */
    if(finally) {
        ret = op_prepend_elem(OP_LINESEQ,
            newSVOP_CUSTOM(&pp_pushfinally, 0, (SV *)finally),
            ret);
    }

    ret = op_append_list(OP_LEAVE,
        newOP(OP_ENTER, 0),
        ret);

    *out = ret;
    return KEYWORD_PLUGIN_STMT;
}

static struct XSParseKeywordHooks hooks_try = {
    .permit_hintkey = "Syntax::Keyword::Try/try",

    .pieces = (const struct XSParseKeywordPieceType []){
        XPK_BLOCK,
        XPK_REPEATED(
            XPK_LITERAL("catch"),
            XPK_PREFIXED_BLOCK(
                /* optionally ($var), ($var isa Type) or ($var =~ m/.../) */
                XPK_PARENS_OPT(
                    XPK_LEXVAR_MY(XPK_LEXVAR_SCALAR),
                    XPK_CHOICE(
                        XPK_SEQUENCE(XPK_LITERAL("isa"), XPK_TERMEXPR),
                        XPK_SEQUENCE(XPK_LITERAL("=~"), XPK_TERMEXPR)
                    )
                )
            )
        ),
        XPK_OPTIONAL(
            XPK_LITERAL("finally"), XPK_ANONSUB
        ),
        {0},
    },
    .build = &build_try,
};

MODULE = Syntax::Keyword::Try    PACKAGE = Syntax::Keyword::Try

BOOT:
    XopENTRY_set(&xop_catch, xop_name, "catch");
    XopENTRY_set(&xop_catch, xop_desc,
        "optionally invoke the catch block if required");
    XopENTRY_set(&xop_catch, xop_class, OA_LOGOP);
    Perl_custom_op_register(aTHX_ &pp_catch, &xop_catch);

    XopENTRY_set(&xop_pushfinally, xop_name, "pushfinally");
    XopENTRY_set(&xop_pushfinally, xop_desc,
        "arrange for a CV to be invoked at scope exit");
    XopENTRY_set(&xop_pushfinally, xop_class, OA_SVOP);
    Perl_custom_op_register(aTHX_ &pp_pushfinally, &xop_pushfinally);
#ifndef HAVE_OP_ISA
    XopENTRY_set(&xop_isa, xop_name, "isa");
    XopENTRY_set(&xop_isa, xop_desc,
        "check if a value is an object of the given class");
    XopENTRY_set(&xop_isa, xop_class, OA_BINOP);
    Perl_custom_op_register(aTHX_ &pp_isa, &xop_isa);
#endif

    boot_xs_parse_keyword(0.35);

    register_xs_parse_keyword("try", &hooks_try, NULL);