XS-Parse-Sublike

 view release on metacpan or  search on metacpan

src/parse_subsignature_ex.c  view on Meta::CPAN

    bool need_comma = false;
    if(param->flags & NAMEDPARAMf_UTF8)
      opdump_printf(ctx, "%sUTF8", need_comma?",":""), need_comma = true;
    if(param->flags & NAMEDPARAMf_REQUIRED)
      opdump_printf(ctx, "%sREQUIRED", need_comma?",":""), need_comma = true;
    if(param->flags & NAMEDPARAMf_REFALIAS)
      opdump_printf(ctx, "%sREFALIAS", need_comma?",":""), need_comma = true;

    opdump_printf(ctx, ")}\n");
  }
}
#endif

static XOP xop_refargelem;
static OP *pp_refargelem(pTHX)
{
  dSP;
  U8 priv = PL_op->op_private;
  IV argix = PTR2IV(cUNOP_AUX->op_aux);

  SV *sv;
  if(PL_op->op_flags & OPf_STACKED)
    sv = POPs;
  else {
    SV **svp = av_fetch(GvAV(PL_defgv), argix, FALSE);
    sv = svp ? *svp : NULL;
  }

  PUTBACK;

  if(!check_refalias_arg(priv, sv)) {
    const char *exp_reftype = NULL;
    switch(priv & OPpARGELEM_MASK) {
      case OPpARGELEM_SV: exp_reftype = "SCALAR"; break;
      case OPpARGELEM_AV: exp_reftype = "ARRAY"; break;
      case OPpARGELEM_HV: exp_reftype = "HASH"; break;
    }
    croak_from_caller("Expected argument %" IVdf " to %" SVf " to be a reference to %s",
        argix + 1, SVfARG(S_find_runcv_name(aTHX)), exp_reftype);
  }

  /* Perform refaliasing into the pad */
  SV **padentry = &(PAD_SVl(PL_op->op_targ));
  save_clearsv(padentry);
  SvREFCNT_dec(*padentry);
  *padentry = SvREFCNT_inc(SvRV(sv));

  return PL_op->op_next;
}

/* Parameter attribute extensions */
typedef struct SignatureAttributeRegistration SignatureAttributeRegistration;

struct SignatureAttributeRegistration {
  SignatureAttributeRegistration *next;

  const char *name;
  STRLEN permit_hintkeylen;

  const struct XPSSignatureAttributeFuncs *funcs;
  void *funcdata;
};

static SignatureAttributeRegistration *sigattrs = NULL;

#define find_registered_attribute(name)  S_find_registered_attribute(aTHX_ name)
static SignatureAttributeRegistration *S_find_registered_attribute(pTHX_ const char *name)
{
  HV *hints = GvHV(PL_hintgv);

  SignatureAttributeRegistration *reg;
  for(reg = sigattrs; reg; reg = reg->next) {
    if(!strEQ(name, reg->name))
      continue;

    if(reg->funcs->permit_hintkey &&
        (!hints || !hv_fetch(hints, reg->funcs->permit_hintkey, reg->permit_hintkeylen, 0)))
      continue;

    return reg;
  }

  croak("Unrecognised signature parameter attribute :%s", name);
}

struct PendingSignatureFunc {
  const struct XPSSignatureAttributeFuncs *funcs;
  void *funcdata;
  void *attrdata;
};

#define PENDING_FROM_SV(sv)  ((struct PendingSignatureFunc *)SvPVX(sv))

static void pending_free(pTHX_ SV *sv)
{
  struct PendingSignatureFunc *p = PENDING_FROM_SV(sv);

  if(p->funcs->free)
    (*p->funcs->free)(aTHX_ p->attrdata, p->funcdata);
}

#define NEW_SV_PENDING()  newSV_with_free(sizeof(struct PendingSignatureFunc), &pending_free)

struct NamedParamDetails {
  PADOFFSET padix;
  U8 flags;
  char sigil;
};
struct SignatureParsingContext {
  OP *positional_elems;  /* OP_LINESEQ of every positional element, in order */
  OP *named_elem_defops; /* OP_LINESEQ of those named elements that have defaulting expressions */
  HV *named_details;     /* SV ptrs to NamedParamDetails of every named parameter */
  OP *slurpy_elem;

  /* Counters that replace what PL_parser->sig_* used to be */
  IV n_elems;
  IV n_optelems;
  char slurpy_sigil;
};

static void free_parsing_ctx(pTHX_ void *_sigctx)
{
  struct SignatureParsingContext *sigctx = _sigctx;
  /* TODO the rest */
  if(sigctx->named_details)
    SvREFCNT_dec((SV *)sigctx->named_details);
}

#define sigctx_add_param(sigctx, paramctx) S_sigctx_add_param(aTHX_ sigctx, paramctx)
static void S_sigctx_add_param(pTHX_ struct SignatureParsingContext *sigctx, struct XPSSignatureParamContext *paramctx)
{
  if(paramctx->is_named) {
    /* A named scalar */

    if(paramctx->namelen) {
      if(!sigctx->named_details)
        sigctx->named_details = newHV();

      struct NamedParamDetails *details;
      Newx(details, 1, struct NamedParamDetails);
      *details = (struct NamedParamDetails){
        .padix       = paramctx->padix,
        .flags       = (!paramctx->defop) ? NAMEDPARAMf_REQUIRED : 0,
        .sigil       = paramctx->sigil,
      };

      if(paramctx->is_refalias) {
        details->flags |= NAMEDPARAMf_REFALIAS;
        switch(paramctx->sigil) {
          case '$': details->flags |= NAMEDPARAMf_REFSCALAR; break;
          case '@': details->flags |= NAMEDPARAMf_REFARRAY;  break;
          case '%': details->flags |= NAMEDPARAMf_REFHASH;   break;
        }
      }

      hv_store(sigctx->named_details, paramctx->namepv, paramctx->namelen, newSVpvx(details), 0);
    }

    sigctx->named_elem_defops = op_append_elem(OP_LINESEQ, sigctx->named_elem_defops,

src/parse_subsignature_ex.c  view on Meta::CPAN

      croak("Expected a signature element at <%s>\n", parser->bufptr);
  }

  char *lexname = parser->bufptr;

  /* Consume sigil */
  lex_read_unichar(0);

  STRLEN lexname_len = 0;

  if(isIDFIRST_uni(lex_peek_unichar(0))) {
    lex_read_unichar(0);
    while(isALNUM_uni(lex_peek_unichar(0)))
      lex_read_unichar(0);

    ENTER;
    SAVEI16(PL_parser->in_my);
    PL_parser->in_my = KEY_sigvar;

    lexname_len = PL_parser->bufptr - lexname;
    paramctx.padix = pad_add_name_pvn(lexname, lexname_len, 0, NULL, NULL);

    if(paramctx.is_named) {
      paramctx.namepv = lexname + 1;
      paramctx.namelen = lexname_len - 1;

      /* named params don't get an individual varop */
    }
    else {
      if(paramctx.is_refalias) {
        paramctx.varop = newUNOP_AUX(OP_CUSTOM, 0, NULL, INT2PTR(UNOP_AUX_item *, (sigctx->n_elems)));
        paramctx.varop->op_ppaddr = &pp_refargelem;
      }
      else
        paramctx.varop = newUNOP_AUX(OP_ARGELEM, 0, NULL, INT2PTR(UNOP_AUX_item *, (sigctx->n_elems)));
      paramctx.varop->op_private |= private;
      paramctx.varop->op_targ = paramctx.padix;
    }

    LEAVE;
  }

  lex_read_space(0);

  if(lex_peek_unichar(0) == ':') {
    if(!permit_attributes)
      croak("Attributes on signature parameters are not permitted");

    lex_read_unichar(0);
    lex_read_space(0);

    SV *attrname = sv_newmortal(), *attrval = sv_newmortal();

    while(lex_scan_attrval_into(attrname, attrval)) {
      lex_read_space(0);

      SignatureAttributeRegistration *reg = find_registered_attribute(SvPV_nolen(attrname));

      void *attrdata = NULL;
      if(reg->funcs->apply)
        (*reg->funcs->apply)(aTHX_ &paramctx, attrval, &attrdata, reg->funcdata);

      if(attrdata || reg->funcs->post_defop) {
        if(!pending) {
          pending = newAV();
          SAVEFREESV(pending);
        }

        SV *psv;
        av_push(pending, psv = NEW_SV_PENDING());

        PENDING_FROM_SV(psv)->funcs    = reg->funcs;
        PENDING_FROM_SV(psv)->funcdata = reg->funcdata;
        PENDING_FROM_SV(psv)->attrdata = attrdata;
      }

      if(lex_peek_unichar(0) == ':') {
        lex_read_unichar(0);
        lex_read_space(0);
      }
    }
  }

  if(paramctx.sigil == '$' || paramctx.is_refalias) {
    if(paramctx.is_named) {
    }
    else {
      if(sigctx->slurpy_sigil)
        yyerror("Slurpy parameters not last");
    }

    bool default_if_undef = false, default_if_false = false;
    if(lex_consume("=") ||
        (default_if_undef = lex_consume("//=")) ||
        (default_if_false = lex_consume("||="))) {
      OP *defexpr = parse_termexpr(PARSE_OPTIONAL);
      if(PL_parser->error_count)
        croak("Expected a defaulting expression for optional parameter");
      if(!paramctx.is_named && !paramctx.varop) {
        /* We permit `= undef` and the blank `=` but nothing else */
        if(defexpr && defexpr->op_type != OP_UNDEF)
          croak("Unnamed positional parameters cannot have defaulting expressions");
      }

      if(paramctx.is_named) {
        OP *assignop = newUNOP(OP_CUSTOM, 0, defexpr);
        assignop->op_ppaddr = &pp_namedargassign;
        assignop->op_targ = paramctx.padix;
        if(paramctx.is_refalias) {
          assignop->op_private |= NAMEDPARAMf_REFALIAS;
          switch(paramctx.sigil) {
            case '$': assignop->op_private |= NAMEDPARAMf_REFSCALAR; break;
            case '@': assignop->op_private |= NAMEDPARAMf_REFARRAY;  break;
            case '%': assignop->op_private |= NAMEDPARAMf_REFHASH;   break;
          }
        }

        OP *existsop = (OP *)alloc_LOGOP(OP_CUSTOM, assignop, LINKLIST(assignop));
        existsop->op_ppaddr = &pp_namedargexists;
        existsop->op_targ = paramctx.padix;
        existsop->op_private =
          default_if_undef ? OPp_NAMEDARGDEFELEM_IF_UNDEF :
          default_if_false ? OPp_NAMEDARGDEFELEM_IF_FALSE :
                            0;

        OP *defop = newUNOP(OP_NULL, 0, existsop);

        LINKLIST(defop);

        defop->op_next = existsop; /* start of this fragment */
        assignop->op_next = defop; /* after assign, stop this fragment */

        paramctx.op    = defop;
        paramctx.defop = defop;
      }
      else if(paramctx.varop) {
        U8 private = 0;
#ifdef OPpARG_IF_UNDEF
        if(default_if_undef) private |= OPpARG_IF_UNDEF;
        if(default_if_false) private |= OPpARG_IF_FALSE;
#else
        if(default_if_undef || default_if_false)
          /* TODO: This would be possible with a custom op but we'd basically
           * have to copy the behaviour of pp_argdefelem in that case
           */
          yyerror("This Perl version cannot handle if_undef/if_false defaulting expressions on positional parameters");
#endif

        if(!defexpr)
          defexpr = newOP(OP_UNDEF, OPf_WANT_SCALAR);

        OP *defop = (OP *)alloc_LOGOP(OP_ARGDEFELEM, defexpr, LINKLIST(defexpr));
        defop->op_targ = (PADOFFSET)sigctx->n_elems;
        defop->op_private = private;

        paramctx.varop->op_flags |= OPf_STACKED;
        op_sibling_splice(paramctx.varop, NULL, 0, defop);
        defop = op_contextualize(defop, G_SCALAR);

        LINKLIST(paramctx.varop);

        paramctx.varop->op_next = defop;
        defexpr->op_next = paramctx.varop;

        paramctx.op    = paramctx.varop;
        paramctx.defop = defop;
      }
      /* else this is `= undef` on anonymous param; nothing to do */
    }
    else {
      if(sigctx->n_optelems)
        yyerror("Mandatory parameter follows optional parameter");

      if(!paramctx.is_named)
        paramctx.op = paramctx.varop;
    }
  }
  else {
    if(paramctx.is_named)
      yyerror("Slurpy parameters may not be named");
    if(sigctx->slurpy_sigil)
      yyerror("Multiple slurpy parameters not allowed");

    if(lex_peek_unichar(0) == '=')
      yyerror("A slurpy parameter may not have a default value");
  }

  if(pending) {
    for(int i = 0; i <= AvFILL(pending); i++) {
      struct PendingSignatureFunc *p = PENDING_FROM_SV(AvARRAY(pending)[i]);

      if(p->funcs->post_defop)
        (*p->funcs->post_defop)(aTHX_ &paramctx, p->attrdata, p->funcdata);
    }
  }

  /* Only after we've run the post_defop hooks can we actually consume the
   * result in paramctx.op
   */
  sigctx_add_param(sigctx, &paramctx);
}

OP *XPS_parse_subsignature_ex(pTHX_ int flags,
  struct XPSContextWithPointer *ctx,
  struct HooksAndData hooksanddata[],
  size_t nhooks)
{
  /* Mostly reconstructed logic from perl 5.28.0's toke.c and perly.y
   */
  yy_parser *parser = PL_parser;
  struct SignatureParsingContext sigctx_ = { 0 };
  struct SignatureParsingContext *const sigctx = &sigctx_;

  if(ctx)
    ctx->sigctx = sigctx;

  assert((flags & ~(PARSE_SUBSIGNATURE_NAMED_PARAMS|PARSE_SUBSIGNATURE_PARAM_ATTRIBUTES|PARSE_SUBSIGNATURE_REFALIAS)) == 0);

  ENTER;
  SAVEDESTRUCTOR_X(&free_parsing_ctx, sigctx);

  IV hooki;
  const struct XSParseSublikeHooks *hooks;
  void *hookdata;

  FOREACH_HOOKS_FORWARD {
    if(hooks->ver >= 7 && hooks->start_signature)
      (*hooks->start_signature)(aTHX_ &(ctx->ctx), hookdata);
  }

  while(lex_peek_unichar(0) != ')') {
    lex_read_space(0);
    parse_sigelem(sigctx, flags);

    if(PL_parser->error_count) {
      LEAVE;
      return NULL;
    }

    lex_read_space(0);
    switch(lex_peek_unichar(0)) {
      case ')': goto endofelems;
      case ',': break;
      default:
        fprintf(stderr, "ARGH unsure how to proceed parse_subsignature at <%s>\n",
            parser->bufptr);
        croak("ARGH");
        break;
    }

    lex_read_unichar(0);
    lex_read_space(0);
  }

src/parse_subsignature_ex.c  view on Meta::CPAN

    }

    if(aux->n_params > 1) {
      /* Sort the params by hash value */
      qsort(&aux->params, aux->n_params, sizeof(aux->params[0]),
          &cmp_argelemsnamedparam);
    }

    OP *argelems_named_op = newUNOP_AUX(OP_CUSTOM, 0, NULL, (UNOP_AUX_item *)aux);
    argelems_named_op->op_ppaddr = &pp_argelems_named;
    if(sigctx->slurpy_sigil) {
      if(sigctx->slurpy_elem && sigctx->slurpy_elem->op_type == OP_LINESEQ) {
        /* A real named slurpy variable */
        OP *o = OpSIBLING(cLISTOPx(sigctx->slurpy_elem)->op_first);
        assert(o);
        assert(o->op_type == OP_ARGELEM);

        /* Steal the slurpy's targ and private flags */
        argelems_named_op->op_targ    = o->op_targ;
        argelems_named_op->op_private |= o->op_private & OPpARGELEM_MASK;
      }
      else {
        /* The slurpy is unnamed. Don't steal its targ but still set the
         * private flags
         */
        argelems_named_op->op_targ    = 0;
        argelems_named_op->op_private = (sigctx->slurpy_sigil == '%') ? OPpARGELEM_HV :
                                        (sigctx->slurpy_sigil == '@') ? OPpARGELEM_AV :
                                                                        0;
      }

      if(sigctx->slurpy_elem) {
        op_free(sigctx->slurpy_elem);
        sigctx->slurpy_elem = NULL;
      }
    }

    ops = op_append_list(OP_LINESEQ, ops,
        newSTATEOP(0, NULL, NULL));
    ops = op_append_list(OP_LINESEQ, ops,
        argelems_named_op);

    if(sigctx->named_elem_defops)
      /* TODO: append each elem individually */
      ops = op_append_list(OP_LINESEQ, ops,
          sigctx->named_elem_defops);
  }
  else if(sigctx->slurpy_elem) {
    ops = op_append_list(OP_LINESEQ, ops, sigctx->slurpy_elem);
  }

  /* a nextstate at the end handles context correctly for an empty
   * sub body */
  ops = op_append_elem(OP_LINESEQ, ops, newSTATEOP(0, NULL, NULL));

  LEAVE;

  return ops;
}

void XPS_register_subsignature_attribute(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata)
{
  SignatureAttributeRegistration *reg;
  Newx(reg, 1, struct SignatureAttributeRegistration);

  *reg = (struct SignatureAttributeRegistration){
    .name     = name,
    .funcs    = funcs,
    .funcdata = funcdata,
  };

  if(funcs->permit_hintkey)
    reg->permit_hintkeylen = strlen(funcs->permit_hintkey);

  reg->next = sigattrs;
  sigattrs = reg;
}

void XPS_boot_parse_subsignature_ex(pTHX)
{
  XopENTRY_set(&xop_namedargexists, xop_name, "namedargexists");
  XopENTRY_set(&xop_namedargexists, xop_desc, "named argument element exists test");
  XopENTRY_set(&xop_namedargexists, xop_class, OA_LOGOP);
  Perl_custom_op_register(aTHX_ &pp_namedargexists, &xop_namedargexists);

  XopENTRY_set(&xop_namedargassign, xop_name, "namedargassign");
  XopENTRY_set(&xop_namedargassign, xop_desc, "named argument element assignment");
  XopENTRY_set(&xop_namedargassign, xop_class, OA_UNOP);
  Perl_custom_op_register(aTHX_ &pp_namedargassign, &xop_namedargassign);

  XopENTRY_set(&xop_argelems_named, xop_name, "argelems_named");
  XopENTRY_set(&xop_argelems_named, xop_desc, "named parameter elements");
  XopENTRY_set(&xop_argelems_named, xop_class, OA_UNOP_AUX);
#ifdef HAVE_XOP_DUMP
  XopENTRY_set(&xop_argelems_named, xop_dump, &opdump_argelems_named);
#endif
  Perl_custom_op_register(aTHX_ &pp_argelems_named, &xop_argelems_named);

  XopENTRY_set(&xop_refargelem, xop_name, "refargelem");
  XopENTRY_set(&xop_refargelem, xop_desc, "refalias argument element");
  XopENTRY_set(&xop_refargelem, xop_class, OA_UNOP_AUX);
  Perl_custom_op_register(aTHX_ &pp_refargelem, &xop_refargelem);
}

#else /* !HAVE_PERL_VERSION(5, 26, 0) */

void XPS_signature_add_param(pTHX_ struct XSParseSublikeContext *ctx, struct XPSSignatureParamDetails *details)
{
}

IV XPS_signature_query(pTHX_ struct XSParseSublikeContext *ctx, int q)
{
  return 0;
}

void XPS_register_subsignature_attribute(pTHX_ const char *name, const struct XPSSignatureAttributeFuncs *funcs, void *funcdata)
{
  croak("Custom subroutine signature attributes are not supported on this verison of Perl");
}

void XPS_boot_parse_subsignature_ex(pTHX)
{
}
#endif