File Coverage

lib/Syntax/Operator/In.xs

Criterion	Covered	Total	%
statement	42	61	68.8
branch	14	58	24.1
condition			n/a
subroutine			n/a
pod			n/a
total	56	119	47.0

/*  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, 2021 -- [e-mail]
 */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#define HAVE_PERL_VERSION(R, V, S) \
    (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))

#include "newOP_CUSTOM.c.inc"

#include "XSParseInfix.h"

enum Inop_Operator {
  INOP_NUMBER,
  INOP_STRING,
};

static OP *pp_in(pTHX)
{
  dSP;
  dMARK;
  SV **svp;
  enum Inop_Operator type = PL_op->op_private;

  OP cmpop;
  switch(type) {
    case INOP_NUMBER:
      cmpop.op_type = OP_EQ;
      cmpop.op_flags = 0;
      cmpop.op_ppaddr = PL_ppaddr[OP_EQ];
      break;

    case INOP_STRING:
      cmpop.op_type = OP_SEQ;
      cmpop.op_flags = 0;
      cmpop.op_ppaddr = PL_ppaddr[OP_SEQ];
      break;
  }

  SV *lhs = *MARK;
  SV **listend = SP;

  SP = MARK - 1;
  PUTBACK;

  ENTER;
  SAVEVPTR(PL_op);
  PL_op = &cmpop;
  EXTEND(SP, 2);

  for(svp = MARK + 1; svp <= listend; svp++) {
    SV *rhs = *svp;

    PUSHs(lhs);
    PUSHs(rhs);
    PUTBACK;

    (*cmpop.op_ppaddr)(aTHX);

    SPAGAIN;

    SV *ret = POPs;

    if(SvTRUE(ret)) {
      LEAVE;

      PUSHs(&PL_sv_yes);
      RETURN;
    }
  }

  LEAVE;

  PUSHs(&PL_sv_no);
  RETURN;
}

#ifndef isIDCONT_utf8_safe
/* It doesn't really matter that this is not "safe", because the function is
 * only ever called on perls new enough to have PL_infix_plugin, and in that
 * case they'll have the _safe version anyway
 */
#  define isIDCONT_utf8_safe(s, e)  isIDCONT_utf8(s)
#endif

static void parse_in(pTHX_ U32 flags, ANY *parsedata, void *hookdata)
{
  if(lex_peek_unichar(0) != '<')
    croak("Expected '<'");
  lex_read_unichar(0);

  lex_read_space(0);

  /* TODO: Need to parse this via XS::Parse::Infix ourselves so we can pick up
   * other custom infix equality operators like `equ`
   */
  if(strnEQ(PL_parser->bufptr, "==", 2)) {
    parsedata->any_iv = INOP_NUMBER;
    lex_read_to(PL_parser->bufptr + 2);
  }
  else if(strnEQ(PL_parser->bufptr, "eq", 2) && !isIDCONT_utf8_safe(PL_parser->bufptr + 2, PL_parser->bufend)) {
    parsedata->any_iv = INOP_STRING;
    lex_read_to(PL_parser->bufptr + 2);
  }
  else
    croak("Expected an equality test operator name");

  if(lex_peek_unichar(0) != '>')
    croak("Expected '>'");
  lex_read_unichar(0);
}

static OP *newop_in(pTHX_ U32 flags, OP *lhs, OP *rhs, ANY *parsedata, void *hookdata)
{
  OP *ret = newBINOP_CUSTOM(&pp_in, 0, lhs, rhs);
  ret->op_private = parsedata->any_iv;

  return ret;
}

static OP *newop_in_str(pTHX_ U32 flags, OP *lhs, OP *rhs, ANY *parsedata, void *hookdata)
{
  OP *ret = newBINOP_CUSTOM(&pp_in, 0, lhs, rhs);
  ret->op_private = INOP_STRING;

  return ret;
}

static OP *newop_in_num(pTHX_ U32 flags, OP *lhs, OP *rhs, ANY *parsedata, void *hookdata)
{
  OP *ret = newBINOP_CUSTOM(&pp_in, 0, lhs, rhs);
  ret->op_private = INOP_NUMBER;

  return ret;
}

struct XSParseInfixHooks infix_in = {
  .cls            = XPI_CLS_MATCH_MISC,
  .rhs_flags      = XPI_OPERAND_LIST,
  .permit_hintkey = "Syntax::Operator::In/in",

  .parse = &parse_in,
  .new_op = &newop_in,
};

struct XSParseInfixHooks infix_elem_str = {
  .cls            = XPI_CLS_MATCH_MISC,
  .rhs_flags      = XPI_OPERAND_LIST,
  .permit_hintkey = "Syntax::Operator::Elem/elem",

  .wrapper_func_name = "Syntax::Operator::Elem::elem_str",

  .new_op = &newop_in_str,
};

struct XSParseInfixHooks infix_elem_num = {
  .cls            = XPI_CLS_MATCH_MISC,
  .rhs_flags      = XPI_OPERAND_LIST,
  .permit_hintkey = "Syntax::Operator::Elem/elem",

  .wrapper_func_name = "Syntax::Operator::Elem::elem_num",

  .new_op = &newop_in_num,
};

MODULE = Syntax::Operator::In    PACKAGE = Syntax::Operator::In

BOOT:
  boot_xs_parse_infix(0.26);

  register_xs_parse_infix("in", &infix_in, NULL);

  register_xs_parse_infix("elem", &infix_elem_str, NULL);
  register_xs_parse_infix("∈",    &infix_elem_num, NULL);