File Coverage

src/constraints.c

Criterion	Covered	Total	%
statement	460	478	96.2
branch	284	320	88.7
condition			n/a
subroutine			n/a
pod			n/a
total	744	798	93.2

/*  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, 2024-2025 -- [e-mail]
 */

#include "EXTERN.h"
#include "perl.h"

#include "constraints.h"

#include "perl-backcompat.c.inc"

#include "make_argcheck_ops.c.inc"
#include "newOP_CUSTOM.c.inc"
#include "optree-additions.c.inc"
#include "sv_regexp_match.c.inc"
#include "sv_streq.c.inc"
#include "sv_numcmp.c.inc"

#include "ckcall_constfold.c.inc"

#if HAVE_PERL_VERSION(5, 28, 0)
   /* perl 5.28.0 onward can do gv_fetchmeth superclass lookups without caching
    */
#  define HAVE_FETCHMETH_SUPER_NOCACHE
#endif

#define newSVsv_num(osv)  S_newSVsv_num(aTHX_ osv)
static SV *S_newSVsv_num(pTHX_ SV *osv)
{
  if(SvNOK(osv))
    return newSVnv(SvNV(osv));
  if(SvIOK(osv) && SvIsUV(osv))
    return newSVuv(SvUV(osv));

  return newSViv(SvIV(osv));
}

#define newSVsv_str(osv)  S_newSVsv_str(aTHX_ osv)
static SV *S_newSVsv_str(pTHX_ SV *osv)
{
  SV *nsv = newSV(0);
  sv_copypv(nsv, osv);
  return nsv;
}

#if !HAVE_PERL_VERSION(5, 32, 0)
# 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 */

  return sv_derived_from_sv(sv, namesv, 0);
}
#endif

#ifndef op_force_list
#  define op_force_list(o)  S_op_force_list(aTHX_ o)
static OP *S_op_force_list(pTHX_ OP *o)
/* Sufficiently good enough for our purposes */
{
  op_null(o);
  return o;
}
#endif

#define alloc_constraint(svp, constraintp, func, n)  S_alloc_constraint(aTHX_ svp, constraintp, func, n)
static void S_alloc_constraint(pTHX_ SV **svp, struct Constraint **constraintp, ConstraintFunc *func, size_t n)
{
  HV *constraint_stash = gv_stashpvs("Data::Checks::Constraint", GV_ADD);

  SV *sv = newSV(sizeof(struct Constraint) + n*sizeof(SV *));
  SvPOK_on(sv);
  struct Constraint *constraint = (struct Constraint *)SvPVX(sv);
  *constraint = (struct Constraint){
    .func = func,
    .n    = n,
  };

  for(int i = 0; i < n; i++)
    constraint->args[i] = NULL;

  *svp = sv_bless(newRV_noinc(sv), constraint_stash);
  *constraintp = constraint;
}

SV *DataChecks_extract_constraint(pTHX_ SV *sv)
{
  if(!sv_isa(sv, "Data::Checks::Constraint"))
    croak("Expected a Constraint instance as argument");

  return SvRV(sv);
}

#define sv_has_overload(sv, method)  S_sv_has_overload(aTHX_ sv, method)
static bool S_sv_has_overload(pTHX_ SV *sv, int method)
{
  assert(SvROK(sv));

  HV *stash = SvSTASH(SvRV(sv));
  if(!stash || !Gv_AMG(stash))
    return false;

  MAGIC *mg = mg_find((const SV *)stash, PERL_MAGIC_overload_table);
  if(!mg)
    return false;

  CV **cvp = NULL;
  if(AMT_AMAGIC((AMT *)mg->mg_ptr))
    cvp  = ((AMT *)mg->mg_ptr)->table;
  if(!cvp)
    return false;

  CV *cv = cvp[method];
  if(!cv)
    return false;

  return true;
}

static bool constraint_Defined(pTHX_ struct Constraint *c, SV *value)
{
  return SvOK(value);
}

static bool constraint_Object(pTHX_ struct Constraint *c, SV *value)
{
  return SvROK(value) && SvOBJECT(SvRV(value));
}

static bool constraint_Str(pTHX_ struct Constraint *c, SV *value)
{
  if(!SvOK(value))
    return false;

  if(SvROK(value)) {
    SV *rv = SvRV(value);
    if(!SvOBJECT(rv))
      return false;

    if(sv_has_overload(value, string_amg))
      return true;

    return false;
  }
  else {
    return true;
  }
}

static bool constraint_StrEq(pTHX_ struct Constraint *c, SV *value)
{
  if(!constraint_Str(aTHX_ c, value))
    return false;

  SV *strs = c->args[0];
  if(SvTYPE(strs) != SVt_PVAV)
    return sv_streq(value, strs);

  /* TODO: If we were to sort the values initially we could binary-search
   * these much faster
   */
  size_t n = av_count((AV *)strs);
  SV **svp = AvARRAY(strs);
  for(size_t i = 0; i < n; i++)
    if(sv_streq(value, svp[i]))
      return true;

  return false;
}

static SV *mk_constraint_StrEq(pTHX_ size_t nargs, SV **args)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_StrEq, 1);
  sv_2mortal(ret);

  if(!nargs)
    croak("Require at least one string for StrEq()");

  if(nargs == 1)
    /* We can just store a single string directly */
    c->args[0] = newSVsv_str(args[0]);
  else {
    AV *strs = newAV_alloc_x(nargs);
    for(size_t i = 0; i < nargs; i++)
      av_store(strs, i, newSVsv_str(args[i]));

    c->args[0] = (SV *)strs;
  }

  return ret;
}

static bool constraint_StrMatch(pTHX_ struct Constraint *c, SV *value)
{
  if(!constraint_Str(aTHX_ c, value))
    return false;

  return sv_regexp_match(value, (REGEXP *)c->args[0]);
}

static SV *mk_constraint_StrMatch(pTHX_ SV *arg0)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_StrMatch, 1);
  sv_2mortal(ret);

  if(!SvROK(arg0) || !SvRXOK(SvRV(arg0)))
    croak("Require a pre-compiled regexp pattern for StrMatch()");

  c->args[0] = SvREFCNT_inc(SvRV(arg0));

  return ret;
}

static bool constraint_Num(pTHX_ struct Constraint *c, SV *value)
{
  if(!SvOK(value))
    return false;

  if(SvROK(value)) {
    SV *rv = SvRV(value);
    if(!SvOBJECT(rv))
      return false;

    if(sv_has_overload(value, numer_amg))
      return true;

    return false;
  }
  else if(SvPOK(value)) {
    if(!looks_like_number(value))
      return false;

    // reject NaN
    if(SvPVX(value)[0] == 'N' || SvPVX(value)[0] == 'n')
      return false;

    return true;
  }
  else {
    // reject NaN
    if(SvNOK(value) && Perl_isnan(SvNV(value)))
      return false;

    return true;
  }
}

enum {
  NUMBOUND_LOWER_INCLUSIVE = (1<<0),
  NUMBOUND_UPPER_INCLUSIVE = (1<<1),
};

static bool constraint_NumBound(pTHX_ struct Constraint *c, SV *value)
{
  /* First off it must be a Num */
  if(!constraint_Num(aTHX_ c, value))
    return false;

  if(c->args[0]) {
    int cmp = sv_numcmp(c->args[0], value);
    if(cmp > 0 || (cmp == 0 && !(c->flags & NUMBOUND_LOWER_INCLUSIVE)))
      return false;
  }

  if(c->args[1]) {
    int cmp = sv_numcmp(value, c->args[1]);
    if(cmp > 0 || (cmp == 0 && !(c->flags & NUMBOUND_UPPER_INCLUSIVE)))
      return false;
  }

  return true;
}

static SV *mk_constraint_NumGT(pTHX_ SV *arg0)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_NumBound, 2);
  sv_2mortal(ret);

  c->args[0] = newSVsv_num(arg0);
  c->args[1] = NULL;

  return ret;
}

static SV *mk_constraint_NumGE(pTHX_ SV *arg0)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_NumBound, 2);
  sv_2mortal(ret);

  c->flags   = NUMBOUND_LOWER_INCLUSIVE;
  c->args[0] = newSVsv_num(arg0);
  c->args[1] = NULL;

  return ret;
}

static SV *mk_constraint_NumLE(pTHX_ SV *arg0)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_NumBound, 2);
  sv_2mortal(ret);

  c->flags   = NUMBOUND_UPPER_INCLUSIVE;
  c->args[0] = NULL;
  c->args[1] = newSVsv_num(arg0);

  return ret;
}

static SV *mk_constraint_NumLT(pTHX_ SV *arg0)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_NumBound, 2);
  sv_2mortal(ret);

  c->args[0] = NULL;
  c->args[1] = newSVsv_num(arg0);

  return ret;
}

static SV *mk_constraint_NumRange(pTHX_ SV *arg0, SV *arg1)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_NumBound, 2);
  sv_2mortal(ret);

  c->flags   = NUMBOUND_LOWER_INCLUSIVE;
  c->args[0] = newSVsv_num(arg0);
  c->args[1] = newSVsv_num(arg1);

  return ret;
}

static bool constraint_NumEq(pTHX_ struct Constraint *c, SV *value)
{
  if(!constraint_Num(aTHX_ c, value))
    return false;

  SV *nums = c->args[0];
  if(SvTYPE(nums) != SVt_PVAV)
    return sv_numcmp(value, nums) == 0;

  /* TODO: If we were to sort the values initially we could binary-search
   * these much faster
   */
  size_t n = av_count((AV *)nums);
  SV **svp = AvARRAY(nums);
  for(size_t i = 0; i < n; i++)
    if(sv_numcmp(value, svp[i]) == 0)
      return true;

  return false;
}

static SV *mk_constraint_NumEq(pTHX_ size_t nargs, SV **args)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_NumEq, 1);
  sv_2mortal(ret);

  if(!nargs)
    croak("Require at least one number for NumEq()");

  if(nargs == 1)
    /* We can just store a single number directly */
    c->args[0] = newSVsv_num(args[0]);
  else {
    AV *nums = newAV_alloc_x(nargs);
    for(size_t i = 0; i < nargs; i++)
      av_store(nums, i, newSVsv_num(args[i]));

    c->args[0] = (SV *)nums;
  }

  return ret;
}

static bool constraint_Isa(pTHX_ struct Constraint *c, SV *value)
{
  return sv_isa_sv(value, c->args[0]);
}

static SV *mk_constraint_Isa(pTHX_ SV *arg0)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_Isa, 1);

  c->args[0] = newSVsv(arg0);

  return sv_2mortal(ret);
}

static bool constraint_Can(pTHX_ struct Constraint *c, SV *value)
{
  HV *stash;
  if(SvROK(value) && SvOBJECT(SvRV(value)))
    stash = SvSTASH(SvRV(value));
  else if(SvOK(value)) {
    stash = gv_stashsv(value, GV_NOADD_NOINIT);
    if(!stash)
      return false;
  }
  else
    return false;

  /* TODO: we could cache which classes do or don't satisfy the constraints
   * and store it somewhere, maybe in an HV in ->args[1] or somesuch */

  SV *methods = c->args[0];
  size_t nmethods = SvTYPE(methods) == SVt_PVAV ? av_count((AV *)methods) : 1;
  for(size_t idx = 0; idx < nmethods; idx++) {
    SV *method = SvTYPE(methods) == SVt_PVAV ? AvARRAY((AV *)methods)[idx] : methods;
    if(!gv_fetchmeth_sv(stash, method,
#ifdef HAVE_FETCHMETH_SUPER_NOCACHE
          -1,
#else
          0,
#endif
          0))
      return false;
  }

  return true;
}

static SV *mk_constraint_Can(pTHX_ size_t nargs, SV **args)
{
  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_Can, 1);
  sv_2mortal(ret);

  if(!nargs)
    croak("Require at least one method name for Can()");

  if(nargs == 1)
    /* We can just store a single string directly */
    c->args[0] = newSVsv_str(args[0]);
  else {
    AV *strs = newAV_alloc_x(nargs);
    for(size_t i = 0; i < nargs; i++)
      av_store(strs, i, newSVsv_str(args[i]));

    c->args[0] = (SV *)strs;
  }

  return ret;
}

static bool constraint_ArrayRef(pTHX_ struct Constraint *c, SV *value)
{
  if(!SvOK(value) || !SvROK(value))
    return false;

  SV *rv = SvRV(value);

  if(!SvOBJECT(rv))
    /* plain ref */
    return SvTYPE(rv) == SVt_PVAV;
  else
    return sv_has_overload(value, to_av_amg);
}

static bool constraint_HashRef(pTHX_ struct Constraint *c, SV *value)
{
  if(!SvOK(value) || !SvROK(value))
    return false;

  SV *rv = SvRV(value);

  if(!SvOBJECT(rv))
    /* plain ref */
    return SvTYPE(rv) == SVt_PVHV;
  else
    return sv_has_overload(value, to_hv_amg);
}

static bool constraint_Callable(pTHX_ struct Constraint *c, SV *value)
{
  if(!SvOK(value) || !SvROK(value))
    return false;

  SV *rv = SvRV(value);

  if(!SvOBJECT(rv))
    /* plain ref */
    return SvTYPE(rv) == SVt_PVCV;
  else
    return sv_has_overload(value, to_cv_amg);
}

static bool constraint_Maybe(pTHX_ struct Constraint *c, SV *value)
{
  if(!SvOK(value))
    return true;

  struct Constraint *inner = (struct Constraint *)SvPVX(c->args[0]);
  return (*inner->func)(aTHX_ inner, value);
}

static SV *mk_constraint_Maybe(pTHX_ SV *arg0)
{
  SV *inner = extract_constraint(arg0);

  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_Maybe, 1);
  sv_2mortal(ret);

  c->args[0] = SvREFCNT_inc(inner);

  return ret;
}

static bool constraint_Any(pTHX_ struct Constraint *c, SV *value)
{
  AV *inners = (AV *)c->args[0];
  SV **innersvs = AvARRAY(inners);
  size_t n = av_count(inners);

  for(size_t i = 0; i < n; i++) {
    struct Constraint *inner = (struct Constraint *)SvPVX(innersvs[i]);
    if((*inner->func)(aTHX_ inner, value))
      return true;
  }

  return false;
}

static SV *mk_constraint_Any(pTHX_ size_t nargs, SV **args)
{
  if(!nargs)
    croak("Any() requires at least one inner constraint");
  if(nargs == 1)
    return args[0];

  AV *inners = newAV();
  sv_2mortal((SV *)inners); // in case of croak during construction

  for(size_t i = 0; i < nargs; i++) {
    SV *innersv = extract_constraint(args[i]);
    struct Constraint *inner = (struct Constraint *)SvPVX(innersv);

    if(inner->func == &constraint_Any) {
      AV *kidav = (AV *)inner->args[0];
      size_t nkids = av_count(kidav);
      for(size_t kidi = 0; kidi < nkids; kidi++) {
        av_push(inners, SvREFCNT_inc(AvARRAY(kidav)[kidi]));
      }
    }
    else
      av_push(inners, SvREFCNT_inc(innersv));
  }

  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_Any, 1);
  sv_2mortal(ret);

  c->args[0] = SvREFCNT_inc(inners);

  return ret;
}

static bool constraint_All(pTHX_ struct Constraint *c, SV *value)
{
  AV *inners = (AV *)c->args[0];
  if(!inners)
    return true;

  SV **innersvs = AvARRAY(inners);
  size_t n = av_count(inners);

  for(size_t i = 0; i < n; i++) {
    struct Constraint *inner = (struct Constraint *)SvPVX(innersvs[i]);
    if(!(*inner->func)(aTHX_ inner, value))
      return false;
  }

  return true;
}

static SV *mk_constraint_All(pTHX_ size_t nargs, SV **args)
{
  /* nargs == 0 is valid */
  if(nargs == 1)
    return args[0];

  AV *inners = NULL;
  if(nargs) {
    inners = newAV();
    sv_2mortal((SV *)inners); // in case of croak during construction

    /* However many NumBound constraints are in 'inners' it's always possible to
     * optimise them down into just one
     */
    struct Constraint *all_nums = NULL;
    SV *all_nums_sv;

    for(size_t i = 0; i < nargs; i++) {
      SV *innersv = extract_constraint(args[i]);
      struct Constraint *inner = (struct Constraint *)SvPVX(innersv);

      if(inner->func == &constraint_All) {
        AV *kidav = (AV *)inner->args[0];
        size_t nkids = av_count(kidav);
        for(size_t kidi = 0; kidi < nkids; kidi++) {
          av_push(inners, SvREFCNT_inc(AvARRAY(kidav)[kidi]));
        }
      }
      else if(inner->func == &constraint_NumBound) {
        if(!all_nums) {
          alloc_constraint(&all_nums_sv, &all_nums, &constraint_NumBound, 2);
          av_push(inners, SvRV(all_nums_sv)); /* no SvREFCNT_inc() */
        }
        SV *innerL = inner->args[0],
           *innerU = inner->args[1];

        int cmp;

        if(innerL) {
          if(!all_nums->args[0] || (cmp = sv_numcmp(all_nums->args[0], innerL)) < 0) {
            SvREFCNT_dec(all_nums->args[0]);
            all_nums->args[0] = newSVsv_num(innerL);
            all_nums->flags = (all_nums->flags & ~NUMBOUND_LOWER_INCLUSIVE)
                              | (inner->flags & NUMBOUND_LOWER_INCLUSIVE);
          }
          else if(cmp == 0 && !(inner->flags & NUMBOUND_LOWER_INCLUSIVE))
            all_nums->flags &= ~NUMBOUND_LOWER_INCLUSIVE;
        }
        if(innerU) {
          if(!all_nums->args[1] || (cmp = sv_numcmp(all_nums->args[1], innerU)) > 0) {
            SvREFCNT_dec(all_nums->args[1]);
            all_nums->args[1] = newSVsv_num(innerU);
            all_nums->flags = (all_nums->flags & ~NUMBOUND_UPPER_INCLUSIVE)
                              | (inner->flags & NUMBOUND_UPPER_INCLUSIVE);
          }
          else if(cmp == 0 && !(inner->flags & NUMBOUND_UPPER_INCLUSIVE))
            all_nums->flags &= ~NUMBOUND_UPPER_INCLUSIVE;
        }
      }
      else
        av_push(inners, SvREFCNT_inc(innersv));
    }

    /* it's possible we've now squashed all the Num* bounds into a single one
     * and nothing else is left */
    if(all_nums_sv && av_count(inners) == 1)
      return all_nums_sv;
  }

  SV *ret;
  struct Constraint *c;
  alloc_constraint(&ret, &c, &constraint_All, 1);
  sv_2mortal(ret);

  c->args[0] = SvREFCNT_inc(inners);

  return ret;
}

#define MAKE_0ARG_CONSTRAINT(name)   S_make_0arg_constraint(aTHX_ #name, &constraint_##name)
static void S_make_0arg_constraint(pTHX_ const char *name, ConstraintFunc *func)
{
  HV *stash = gv_stashpvs("Data::Checks", GV_ADD);
  AV *exportok = get_av("Data::Checks::EXPORT_OK", GV_ADD);

  SV *namesv = newSVpvf("Data::Checks::%s", name);

  /* Before perl 5.38, XSUBs cannot be exported lexically. newCONSTSUB() makes
   * XSUBs. We'll have to build our own constant-value sub instead
   */

  I32 floor_ix = start_subparse(FALSE, 0);

  SV *sv;
  struct Constraint *constraint;
  alloc_constraint(&sv, &constraint, func, 0);

  OP *body = make_argcheck_ops(0, 0, 0, namesv);
  body = op_append_elem(OP_LINESEQ,
    body,
    newSTATEOP(0, NULL,
      newSVOP(OP_CONST, 0, sv)));

  CV *cv = newATTRSUB(floor_ix, newSVOP(OP_CONST, 0, namesv), NULL, NULL, body);
  cv_set_call_checker(cv, &ckcall_constfold, &PL_sv_undef);

  av_push(exportok, newSVpv(name, 0));
}

static XOP xop_make_constraint;
static OP *pp_make_constraint(pTHX)
{
  dSP;
  int nargs = PL_op->op_private;

  SV *ret;
  switch(nargs) {
    case 1:
    {
      SV *(*mk_constraint)(pTHX_ SV *arg0) =
        (SV * (*)(pTHX_ SV *))cUNOP_AUX->op_aux;

      SV *arg0 = POPs;

      ret = (*mk_constraint)(aTHX_ arg0);
      break;
    }

    case 2:
    {
      SV *(*mk_constraint)(pTHX_ SV *arg0, SV *arg1) =
        (SV * (*)(pTHX_ SV *, SV *))cUNOP_AUX->op_aux;

      SV *arg1 = POPs;
      SV *arg0 = POPs;

      ret = (*mk_constraint)(aTHX_ arg0, arg1);
      break;
    }

    case (U8)-1:
    {
      SV *(*mk_constraint)(pTHX_ size_t nargs, SV **args) =
        (SV * (*)(pTHX_ size_t, SV **))cUNOP_AUX->op_aux;

      SV **svp = PL_stack_base + POPMARK + 1;
      size_t nargs = SP - svp + 1;
      SP -= nargs;

      if(!nargs)
        EXTEND(SP, 1);

      ret = (*mk_constraint)(aTHX_ nargs, svp);
      break;
    }

    default:
      croak("ARGH unreachable nargs=%d", nargs);
  }

  PUSHs(ret);

  RETURN;
}

#define MAKE_1ARG_CONSTRAINT(name)  S_make_1arg_constraint(aTHX_ #name, &mk_constraint_##name)
static void S_make_1arg_constraint(pTHX_ const char *name, SV *(*mk_constraint)(pTHX_ SV *arg0))
{
  HV *stash = gv_stashpvs("Data::Checks", GV_ADD);
  HV *constraint_stash = gv_stashpvs("Data::Checks::Constraint", GV_ADD);
  AV *exportok = get_av("Data::Checks::EXPORT_OK", GV_ADD);

  SV *namesv = newSVpvf("Data::Checks::%s", name);

  I32 floor_ix = start_subparse(FALSE, 0);

  OP *mkop = newUNOP_AUX_CUSTOM(&pp_make_constraint, 0,
        newSLUGOP(0),
        (UNOP_AUX_item *)mk_constraint);
  mkop->op_private = 1;

  OP *body = make_argcheck_ops(1, 0, 0, namesv);
  body = op_append_elem(OP_LINESEQ,
    body,
    newSTATEOP(0, NULL, mkop));

  CV *cv = newATTRSUB(floor_ix, newSVOP(OP_CONST, 0, namesv), NULL, NULL, body);
  cv_set_call_checker(cv, &ckcall_constfold, &PL_sv_undef);

  av_push(exportok, newSVpv(name, 0));
}

#define MAKE_2ARG_CONSTRAINT(name)  S_make_2arg_constraint(aTHX_ #name, &mk_constraint_##name)
static void S_make_2arg_constraint(pTHX_ const char *name, SV *(*mk_constraint)(pTHX_ SV *arg0, SV *arg1))
{
  HV *stash = gv_stashpvs("Data::Checks", GV_ADD);
  HV *constraint_stash = gv_stashpvs("Data::Checks::Constraint", GV_ADD);
  AV *exportok = get_av("Data::Checks::EXPORT_OK", GV_ADD);

  SV *namesv = newSVpvf("Data::Checks::%s", name);

  I32 floor_ix = start_subparse(FALSE, 0);

  OP *mkop = newUNOP_AUX_CUSTOM(&pp_make_constraint, 0,
        newLISTOPn(OP_LIST, OPf_WANT_LIST, newSLUGOP(0), newSLUGOP(1), NULL),
        (UNOP_AUX_item *)mk_constraint);
  mkop->op_private = 2;

  OP *body = make_argcheck_ops(2, 0, 0, namesv);
  body = op_append_elem(OP_LINESEQ,
    body,
    newSTATEOP(0, NULL, mkop));

  CV *cv = newATTRSUB(floor_ix, newSVOP(OP_CONST, 0, namesv), NULL, NULL, body);
  cv_set_call_checker(cv, &ckcall_constfold, &PL_sv_undef);

  av_push(exportok, newSVpv(name, 0));
}

#define MAKE_nARG_CONSTRAINT(name)  S_make_narg_constraint(aTHX_ #name, &mk_constraint_##name)
static void S_make_narg_constraint(pTHX_ const char *name, SV *(*mk_constraint)(pTHX_ size_t nargs, SV **args))
{
  HV *stash = gv_stashpvs("Data::Checks", GV_ADD);
  HV *constraint_stash = gv_stashpvs("Data::Checks::Constraint", GV_ADD);
  AV *exportok = get_av("Data::Checks::EXPORT_OK", GV_ADD);

  SV *namesv = newSVpvf("Data::Checks::%s", name);

  I32 floor_ix = start_subparse(FALSE, 0);

  OP *mkop = newUNOP_AUX_CUSTOM(&pp_make_constraint, 0,
        op_force_list(newLISTOPn(OP_LIST, OPf_WANT_LIST,
          newUNOP(OP_RV2AV, OPf_WANT_LIST, newGVOP(OP_GV, 0, PL_defgv)),
          NULL)),
        (UNOP_AUX_item *)mk_constraint);
  mkop->op_private = -1;

  OP *body = make_argcheck_ops(0, 0, '@', namesv);
  body = op_append_elem(OP_LINESEQ,
    body,
    newSTATEOP(0, NULL, mkop));

  CV *cv = newATTRSUB(floor_ix, newSVOP(OP_CONST, 0, namesv), NULL, NULL, body);
  cv_set_call_checker(cv, &ckcall_constfold, &PL_sv_undef);

  av_push(exportok, newSVpv(name, 0));
}

/* This does NOT use SVf_quoted as that is intended for C's quoting
 * rules; we want qq()-style perlish ones. This means that $ and @ need to be
 * escaped as well.
 */
#define sv_catsv_quoted(buf, sv, quote)  S_sv_catsv_quoted(aTHX_ buf, sv, quote)
static void S_sv_catsv_quoted(pTHX_ SV *buf, SV *sv, char quote)
{
  STRLEN len;
  const char *s = SvPV_const(sv, len);
  sv_catpvn(buf, "e, 1);
  for(STRLEN i = 0; i < len; i++) {
    if(len == 256) {
      sv_catpvs(buf, "...");
      break;
    }
    char c = s[i];
    if(c == '\\' || c == quote || (quote != '\'' && (c == '$' || c == '@')))
      sv_catpvs(buf, "\\");
    /* TODO: UTF-8 */
    sv_catpvn(buf, &c, 1);
  }
  sv_catpvn(buf, "e, 1);
}

#define sv_catsv_quoted_list(buf, av, quote, sep)  S_sv_catsv_quoted_list(aTHX_ buf, av, quote, sep)
static void S_sv_catsv_quoted_list(pTHX_ SV *buf, AV *av, char quote, char sep)
{
  U32 n = av_count(av);
  SV **vals = AvARRAY(av);
  for(U32 i = 0; i < n; i++) {
    if(i > 0)
      sv_catpvn(buf, &sep, 1), sv_catpvs(buf, " ");
    sv_catsv_quoted(buf, vals[i], quote);
  }
}

SV *DataChecks_stringify_constraint(pTHX_ struct Constraint *c)
{
  const char *name = NULL;
  SV *args = sv_2mortal(newSVpvn("", 0));

  /* such a shame C doesn't let us use function addresses as case labels */

  // 0arg
  if     (c->func == &constraint_Defined)
    name = "Defined";
  else if(c->func == &constraint_Object)
    name = "Object";
  else if(c->func == &constraint_ArrayRef)
    name = "ArrayRef";
  else if(c->func == &constraint_HashRef)
    name = "HashRef";
  else if(c->func == &constraint_Callable)
    name = "Callable";
  else if(c->func == &constraint_Num)
    name = "Num";
  else if(c->func == &constraint_Str)
    name = "Str";
  // 1arg
  else if(c->func == &constraint_Isa) {
    name = "Isa";
    sv_catsv_quoted(args, c->args[0], '"');
  }
  else if(c->func == &constraint_StrMatch) {
    name = "StrMatch";
    sv_catpvs(args, "qr");
    sv_catsv_quoted(args, c->args[0], '/');
  }
  else if(c->func == &constraint_Maybe) {
    name = "Maybe";
    args = stringify_constraint_sv(c->args[0]);
  }
  // 2arg
  else if(c->func == &constraint_NumBound) {
    if(!c->args[0])
      name = (c->flags & NUMBOUND_UPPER_INCLUSIVE ) ? "NumLE" : "NumLT";
    else if(!c->args[1])
      name = (c->flags & NUMBOUND_LOWER_INCLUSIVE ) ? "NumGE" : "NumGT";
    else if(c->flags == NUMBOUND_LOWER_INCLUSIVE)
      name = "NumRange";
    else {
      /* This was optimised from an All() call on at least two different ones;
       * we'll have to just stringify it as best we can
       */
      name = "All";
      sv_catpvf(args, "NumG%c(%" SVf "), NumL%c(%" SVf ")",
          (c->flags & NUMBOUND_LOWER_INCLUSIVE) ? 'E' : 'T', SVfARG(c->args[0]),
          (c->flags & NUMBOUND_UPPER_INCLUSIVE) ? 'E' : 'T', SVfARG(c->args[1]));
    }

    if(!SvCUR(args)) {
      if(c->args[0])
        sv_catsv(args, c->args[0]);
      if(c->args[0] && c->args[1])
        sv_catpvs(args, ", ");
      if(c->args[1])
        sv_catsv(args, c->args[1]);
    }
  }
  // narg
  else if(c->func == &constraint_NumEq) {
    name = "NumEq";
    if(SvTYPE(c->args[0]) != SVt_PVAV)
      sv_catsv(args, c->args[0]);
    else {
      U32 n = av_count((AV *)c->args[0]);
      SV **vals = AvARRAY(c->args[0]);
      for(U32 i = 0; i < n; i++) {
        if(i > 0)
          sv_catpvs(args, ", ");
        sv_catsv(args, vals[i]);
      }
    }
  }
  else if(c->func == &constraint_StrEq) {
    name = "StrEq";
    if(SvTYPE(c->args[0]) == SVt_PVAV)
      sv_catsv_quoted_list(args, (AV *)c->args[0], '"', ',');
    else
      sv_catsv_quoted(args, c->args[0], '"');
  }
  else if(c->func == &constraint_Can) {
    name = "Can";
    if(SvTYPE(c->args[0]) == SVt_PVAV)
      sv_catsv_quoted_list(args, (AV *)c->args[0], '"', ',');
    else
      sv_catsv_quoted(args, c->args[0], '"');
  }
  else if(c->func == &constraint_Any || c->func == &constraint_All) {
    name = (c->func == &constraint_Any) ? "Any" : "All";
    if(c->args[0]) {
      U32 n = av_count((AV *)c->args[0]);
      SV **inners = AvARRAY(c->args[0]);
      for(U32 i = 0; i < n; i++) {
        if(i > 0)
          sv_catpvs(args, ", ");
        sv_catsv(args, stringify_constraint_sv(inners[i]));
      }
    }
  }

  else
    return newSVpvs_flags("TODO: debug inspect constraint", SVs_TEMP);

  SV *ret = newSVpvf("%s", name);
  if(SvCUR(args))
    sv_catpvf(ret, "(%" SVf ")", SVfARG(args));

  return sv_2mortal(ret);
}

void boot_Data_Checks__constraints(pTHX)
{
  MAKE_0ARG_CONSTRAINT(Defined);
  MAKE_0ARG_CONSTRAINT(Object);
  MAKE_0ARG_CONSTRAINT(Str);
  MAKE_0ARG_CONSTRAINT(Num);

  MAKE_nARG_CONSTRAINT(StrEq);
  MAKE_1ARG_CONSTRAINT(StrMatch);

  MAKE_1ARG_CONSTRAINT(NumGT);
  MAKE_1ARG_CONSTRAINT(NumGE);
  MAKE_1ARG_CONSTRAINT(NumLE);
  MAKE_1ARG_CONSTRAINT(NumLT);
  MAKE_2ARG_CONSTRAINT(NumRange);
  MAKE_nARG_CONSTRAINT(NumEq);

  MAKE_1ARG_CONSTRAINT(Isa);
  MAKE_nARG_CONSTRAINT(Can);
  MAKE_0ARG_CONSTRAINT(ArrayRef);
  MAKE_0ARG_CONSTRAINT(HashRef);
  MAKE_0ARG_CONSTRAINT(Callable);
  MAKE_1ARG_CONSTRAINT(Maybe);
  MAKE_nARG_CONSTRAINT(Any);
  MAKE_nARG_CONSTRAINT(All);

  XopENTRY_set(&xop_make_constraint, xop_name, "make_constraint");
  XopENTRY_set(&xop_make_constraint, xop_desc, "make constraint");
  XopENTRY_set(&xop_make_constraint, xop_class, OA_UNOP_AUX);
  Perl_custom_op_register(aTHX_ &pp_make_constraint, &xop_make_constraint);
}