lib/Params/Classify.xs - metacpan.org

#define PERL_NO_GET_CONTEXT 1
#include "EXTERN.h"
#include "perl.h"
#include "callchecker0.h"
#include "XSUB.h"

#define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
#define PERL_DECIMAL_VERSION \
	PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
#define PERL_VERSION_GE(r,v,s) \
	(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))

#ifndef cBOOL
# define cBOOL(x) ((bool)!!(x))
#endif /* !cBOOL */

#ifndef PERL_UNUSED_VAR
# define PERL_UNUSED_VAR(x) ((void)x)
#endif /* !PERL_UNUSED_VAR */

#ifndef PERL_UNUSED_ARG
# define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x)
#endif /* !PERL_UNUSED_ARG */

#ifndef Newx
# define Newx(v,n,t) New(0,v,n,t)
#endif /* !Newx */

#ifndef HvNAME_get
# define HvNAME_get(hv) HvNAME(hv)
#endif

#ifndef newSVpvs_share
# define newSVpvs_share(s) newSVpvn_share(""s"", (sizeof(""s"")-1), 0)
#endif /* !newSVpvs_share */

#ifndef newSVpvn_share
# define newSVpvn_share(s, l, h) newSVpvn(s, l)
#endif /* !newSVpvn_share */

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

#ifndef DPTR2FPTR
# define DPTR2FPTR(t,x) ((t)(UV)(x))
#endif /* !DPTR2FPTR */

#ifndef FPTR2DPTR
# define FPTR2DPTR(t,x) ((t)(UV)(x))
#endif /* !FPTR2DPTR */

#ifndef OpMORESIB_set
# define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
# define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
# define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
#endif /* !OpMORESIB_set */
#ifndef OpSIBLING
# define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
# define OpSIBLING(o) (0 + (o)->op_sibling)
#endif /* !OpSIBLING */

#ifdef cv_set_call_checker
# define QUSE_CUSTOM_OPS 1
#else /* !cv_set_call_checker */
# define QUSE_CUSTOM_OPS 0
#endif /* !cv_set_call_checker */

#if defined(QUSE_CUSTOM_OPS) && !defined(ptr_table_new)

struct q_ptr_tbl_ent {
	struct q_ptr_tbl_ent *next;
	void *from, *to;
};

# undef PTR_TBL_t
# define PTR_TBL_t struct q_ptr_tbl_ent *

# define ptr_table_new() THX_ptr_table_new(aTHX)
static PTR_TBL_t *THX_ptr_table_new(pTHX)
{
	PTR_TBL_t *tbl;
	Newx(tbl, 1, PTR_TBL_t);
	*tbl = NULL;
	return tbl;
}

# if 0
#  define ptr_table_free(tbl) THX_ptr_table_free(aTHX_ tbl)
static void THX_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
{
	struct q_ptr_tbl_ent *ent = *tbl;
	Safefree(tbl);
	while(ent) {
		struct q_ptr_tbl_ent *nent = ent->next;
		Safefree(ent);
		ent = nent;
	}
}
# endif /* 0 */

# define ptr_table_store(tbl, from, to) THX_ptr_table_store(aTHX_ tbl, from, to)
static void THX_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *from, void *to)
{
	struct q_ptr_tbl_ent *ent;
	Newx(ent, 1, struct q_ptr_tbl_ent);
	ent->next = *tbl;
	ent->from = from;
	ent->to = to;
	*tbl = ent;
}

# define ptr_table_fetch(tbl, from) THX_ptr_table_fetch(aTHX_ tbl, from)
static void *THX_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *from)
{
	struct q_ptr_tbl_ent *ent;
	for(ent = *tbl; ent; ent = ent->next) {
		if(ent->from == from) return ent->to;
	}
	return NULL;
}

#endif /* QUSE_CUSTOM_OPS && !ptr_table_new */

#if PERL_VERSION_GE(5,11,0)
# define case_SVt_RV_
#else /* <5.11.0 */
# define case_SVt_RV_ case SVt_RV:
#endif /* <5.11.0 */

#if PERL_VERSION_GE(5,9,5)
# define case_SVt_PVBM_
#else /* <5.11.0 */
# define case_SVt_PVBM_ case SVt_PVBM:
#endif /* <5.11.0 */

#if PERL_VERSION_GE(5,11,0)
# define case_SVt_REGEXP_ case SVt_REGEXP:
#else /* <5.11.0 */
# define case_SVt_REGEXP_
#endif /* <5.11.0 */

#define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)

#if PERL_VERSION_GE(5,11,0)
# define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
#else /* <5.11.0 */
# define sv_is_regexp(sv) 0
#endif /* <5.11.0 */

#define sv_is_undef(sv) (!sv_is_glob(sv) && !sv_is_regexp(sv) && !SvOK(sv))

#define sv_is_string(sv) \
	(!sv_is_glob(sv) && !sv_is_regexp(sv) && \
	 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))

#define sv_is_untyped_ref(sv) (SvROK(sv) && !SvOBJECT(SvRV(sv)))
#define sv_is_untyped_blessed(sv) (SvROK(sv) && SvOBJECT(SvRV(sv)))

static bool THX_sv_is_undef(pTHX_ SV *sv) { return cBOOL(sv_is_undef(sv)); }

static bool THX_sv_is_string(pTHX_ SV *sv) { return cBOOL(sv_is_string(sv)); }

static bool THX_sv_is_glob(pTHX_ SV *sv) { return cBOOL(sv_is_glob(sv)); }

static bool THX_sv_is_regexp(pTHX_ SV *sv) {
	PERL_UNUSED_ARG(sv);
	return cBOOL(sv_is_regexp(sv));
}

static bool THX_sv_is_untyped_ref(pTHX_ SV *sv) {
	return cBOOL(sv_is_untyped_ref(sv));
}

static bool THX_sv_is_untyped_blessed(pTHX_ SV *sv) {
	return cBOOL(sv_is_untyped_blessed(sv));
}

enum {
	SCLASS_UNDEF,
	SCLASS_STRING,
	SCLASS_GLOB,
	SCLASS_REGEXP,
	SCLASS_REF,
	SCLASS_BLESSED,
	SCLASS_COUNT
};

static struct sclass_metadata {
	char const *desc_adj_or_noun_phrase, *keyword_pv;
	SV *keyword_sv;
	bool (*THX_sv_is_sclass)(pTHX_ SV *);
} sclass_metadata[SCLASS_COUNT] = {
	{ "undefined",  "UNDEF",   NULL, THX_sv_is_undef },
	{ "a string",   "STRING",  NULL, THX_sv_is_string },
	{ "a typeglob", "GLOB",    NULL, THX_sv_is_glob },
	{ "a regexp",   "REGEXP",  NULL, THX_sv_is_regexp },
	{ "a reference to plain object",
			"REF",     NULL, THX_sv_is_untyped_ref },
	{ "a reference to blessed object",
			"BLESSED", NULL, THX_sv_is_untyped_blessed },
};

enum {
	RTYPE_SCALAR,
	RTYPE_ARRAY,
	RTYPE_HASH,
	RTYPE_CODE,
	RTYPE_FORMAT,
	RTYPE_IO,
	RTYPE_COUNT
};

static struct rtype_metadata {
	char const *desc_noun, *keyword_pv;
	SV *keyword_sv;
} rtype_metadata[RTYPE_COUNT] = {
	{ "scalar", "SCALAR", NULL },
	{ "array",  "ARRAY",  NULL },
	{ "hash",   "HASH",   NULL },
	{ "code",   "CODE",   NULL },
	{ "format", "FORMAT", NULL },
	{ "io",     "IO",     NULL },
};

#define PC_TYPE_MASK    0x00f
#define PC_CROAK        0x010
#define PC_STRICTBLESS  0x020
#define PC_ABLE         0x040
#define PC_ALLOW_UNARY  0x100
#define PC_ALLOW_BINARY 0x200

#define scalar_class(arg) THX_scalar_class(aTHX_ arg)
static I32 THX_scalar_class(pTHX_ SV *arg)
{
	if(sv_is_glob(arg)) {
		return SCLASS_GLOB;
	} else if(sv_is_regexp(arg)) {
		return SCLASS_REGEXP;
	} else if(!SvOK(arg)) {
		return SCLASS_UNDEF;
	} else if(SvROK(arg)) {
		return SvOBJECT(SvRV(arg)) ? SCLASS_BLESSED : SCLASS_REF;
	} else if(SvFLAGS(arg) &
			(SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)) {
		return SCLASS_STRING;
	} else {
		croak("unknown scalar class, please update Params::Classify\n");
	}
}

#define read_reftype_or_neg(reftype) THX_read_reftype_or_neg(aTHX_ reftype)
static I32 THX_read_reftype_or_neg(pTHX_ SV *reftype)
{
	char *p;
	STRLEN l;
	if(!sv_is_string(reftype)) return -2;
	p = SvPV(reftype, l);
	if(strlen(p) != l) return -1;
	switch(p[0]) {
		case 'S':
			if(!strcmp(p, "SCALAR")) return RTYPE_SCALAR;
			return -1;
		case 'A':
			if(!strcmp(p, "ARRAY")) return RTYPE_ARRAY;
			return -1;
		case 'H':
			if(!strcmp(p, "HASH")) return RTYPE_HASH;
			return -1;
		case 'C':
			if(!strcmp(p, "CODE")) return RTYPE_CODE;
			return -1;
		case 'F':
			if(!strcmp(p, "FORMAT")) return RTYPE_FORMAT;
			return -1;
		case 'I':
			if(!strcmp(p, "IO")) return RTYPE_IO;
			return -1;
		default:
			return -1;
	}
}

#define read_reftype(reftype) THX_read_reftype(aTHX_ reftype)
static I32 THX_read_reftype(pTHX_ SV *reftype)
{
	I32 rtype = read_reftype_or_neg(reftype);
	if(rtype < 0)
		croak(rtype == -2 ?
			"reference type argument is not a string\n" :
			"invalid reference type\n");
	return rtype;
}

#define ref_type(referent) THX_ref_type(aTHX_ referent)
static I32 THX_ref_type(pTHX_ SV *referent)
{
	switch(SvTYPE(referent)) {
		case SVt_NULL: case SVt_IV: case SVt_NV: case_SVt_RV_
		case SVt_PV: case SVt_PVIV: case SVt_PVNV:
		case SVt_PVMG: case SVt_PVLV: case SVt_PVGV:
		case_SVt_PVBM_ case_SVt_REGEXP_
			return RTYPE_SCALAR;
		case SVt_PVAV:
			return RTYPE_ARRAY;
		case SVt_PVHV:
			return RTYPE_HASH;
		case SVt_PVCV:
			return RTYPE_CODE;
		case SVt_PVFM:
			return RTYPE_FORMAT;
		case SVt_PVIO:
			return RTYPE_IO;
		default:
			croak("unknown SvTYPE, "
				"please update Params::Classify\n");
	}
}

#define blessed_class(referent) THX_blessed_class(aTHX_ referent)
static const char *THX_blessed_class(pTHX_ SV *referent)
{
	HV *stash = SvSTASH(referent);
	const char *name = HvNAME_get(stash);
	return name ? name : "__ANON__";
}

#define call_bool_method(objref, methodname, arg) \
	THX_call_bool_method(aTHX_ objref, methodname, arg)
static bool THX_call_bool_method(pTHX_ SV *objref, const char *methodname,
	SV *arg)
{
	dSP;
	int retcount;
	SV *ret;
	bool retval;
	ENTER;
	SAVETMPS;
	PUSHMARK(SP);
	XPUSHs(objref);
	XPUSHs(arg);
	PUTBACK;
	retcount = call_method(methodname, G_SCALAR);
	SPAGAIN;
	if(retcount != 1) croak("call_method misbehaving\n");
	ret = POPs;
	retval = cBOOL(SvTRUE(ret));
	PUTBACK;
	FREETMPS;
	LEAVE;
	return retval;
}

#define pp1_scalar_class() THX_pp1_scalar_class(aTHX)
static void THX_pp1_scalar_class(pTHX)
{
	dSP;
	SV *arg = TOPs;
	TOPs = sclass_metadata[scalar_class(arg)].keyword_sv;
}

#define pp1_ref_type() THX_pp1_ref_type(aTHX)
static void THX_pp1_ref_type(pTHX)
{
	dSP;
	SV *arg, *referent;
	arg = TOPs;
	TOPs = !SvROK(arg) || (referent = SvRV(arg), SvOBJECT(referent)) ?
		&PL_sv_undef :
		rtype_metadata[ref_type(referent)].keyword_sv;
}

#define pp1_blessed_class() THX_pp1_blessed_class(aTHX)
static void THX_pp1_blessed_class(pTHX)
{
	dSP;
	SV *arg, *referent;
	arg = TOPs;
	TOPs = !SvROK(arg) || (referent = SvRV(arg), !SvOBJECT(referent)) ?
		&PL_sv_undef :
		sv_2mortal(newSVpv(blessed_class(referent), 0));
}

#define pp1_check_sclass(t) THX_pp1_check_sclass(aTHX_ t)
static void THX_pp1_check_sclass(pTHX_ I32 t)
{
	dSP;
	SV *arg = POPs;
	struct sclass_metadata const *sclassmeta =
		&sclass_metadata[t & PC_TYPE_MASK];
	bool matches;
	PUTBACK;
	matches = sclassmeta->THX_sv_is_sclass(aTHX_ arg);
	SPAGAIN;
	if(t & PC_CROAK) {
		if(!matches)
			croak("argument is not %s\n",
				sclassmeta->desc_adj_or_noun_phrase);
		if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef);
	} else {
		SV *result = boolSV(matches);
		XPUSHs(result);
	}
	PUTBACK;
}

#define pp1_check_rtype(t) THX_pp1_check_rtype(aTHX_ t)
static void THX_pp1_check_rtype(pTHX_ I32 t)
{
	dSP;
	SV *arg = POPs, *referent;
	I32 rtype = t & PC_TYPE_MASK;
	struct rtype_metadata const *rtypemeta = &rtype_metadata[rtype];
	bool matches = SvROK(arg) &&
		(referent = SvRV(arg), !SvOBJECT(referent)) &&
		ref_type(referent) == rtype;
	if(t & PC_CROAK) {
		if(!matches)
			croak("argument is not a reference to plain %s\n",
				rtypemeta->desc_noun);
		if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef);
	} else {
		SV *result = boolSV(matches);
		XPUSHs(result);
	}
	PUTBACK;
}

#define pp1_check_dyn_rtype(t) THX_pp1_check_dyn_rtype(aTHX_ t)
static void THX_pp1_check_dyn_rtype(pTHX_ I32 t)
{
	dSP;
	SV *type_sv = POPs;
	PUTBACK;
	pp1_check_rtype(t | read_reftype(type_sv));
}

#define pp1_check_dyn_battr(t) THX_pp1_check_dyn_battr(aTHX_ t)
static void THX_pp1_check_dyn_battr(pTHX_ I32 t)
{
	dSP;
	SV *attr, *arg, *meth = NULL;
	bool matches;
	attr = POPs;
	if(t & PC_ABLE) {
		if(sv_is_string(attr)) {
			meth = attr;
		} else {
			AV *methods_av;
			array_ix_t alen, pos;
			if(!SvROK(attr) || SvOBJECT(SvRV(attr)) ||
					SvTYPE(SvRV(attr)) != SVt_PVAV)
				croak("methods argument is not "
					"a string or array\n");
			methods_av = (AV*)SvRV(attr);
			alen = av_len(methods_av);
			for(pos = 0; pos <= alen; pos++) {
				SV **m_ptr = av_fetch(methods_av, pos, 0);
				if(!m_ptr || !sv_is_string(*m_ptr))
					croak("method name is not a string\n");
			}
			if(alen != -1) meth = *av_fetch(methods_av, 0, 0);
		}
	} else {
		if(!sv_is_string(attr))
			croak("class argument is not a string\n");
	}
	arg = POPs;
	if((matches = SvROK(arg) && SvOBJECT(SvRV(arg)))) {
		if(t & PC_ABLE) {
			PUTBACK;
			if(!SvROK(attr)) {
				meth = attr;
				matches = call_bool_method(arg, "can", attr);
			} else {
				AV *methods_av = (AV*)SvRV(attr);
				array_ix_t alen = av_len(methods_av), pos;
				for(pos = 0; pos <= alen; pos++) {
					meth = *av_fetch(methods_av, pos, 0);
					if(!call_bool_method(arg, "can",
							meth)) {
						matches = 0;
						break;
					}
				}
			}
			SPAGAIN;
		} else if(t & PC_STRICTBLESS) {
			char const *actual_class = blessed_class(SvRV(arg));
			char const *check_class;
			STRLEN check_len;
			check_class = SvPV(attr, check_len);
			matches = check_len == strlen(actual_class) &&
					!strcmp(check_class, actual_class);
		} else {
			PUTBACK;
			matches = call_bool_method(arg, "isa", attr);
			SPAGAIN;
		}
	}
	if(t & PC_CROAK) {
		if(!matches) {
			if(t & PC_ABLE) {
				if(meth) {
					croak("argument is not able to "
						"perform method \"%s\"\n",
						SvPV_nolen(meth));
				} else {
					croak("argument is not able to "
						"perform at all\n");
				}
			} else {
				croak("argument is not a reference to "
					"%sblessed %s\n",
					t & PC_STRICTBLESS ? "strictly " : "",
					SvPV_nolen(attr));
			}
		}
		if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef);
	} else {
		SV *result = boolSV(matches);
		XPUSHs(result);
	}
	PUTBACK;
}

#if QUSE_CUSTOM_OPS

static OP *THX_pp_scalar_class(pTHX)
{
	pp1_scalar_class();
	return NORMAL;
}

static OP *THX_pp_ref_type(pTHX)
{
	pp1_ref_type();
	return NORMAL;
}

static OP *THX_pp_blessed_class(pTHX)
{
	pp1_blessed_class();
	return NORMAL;
}

static OP *THX_pp_check_sclass(pTHX)
{
	pp1_check_sclass(PL_op->op_private);
	return NORMAL;
}

static OP *THX_pp_check_rtype(pTHX)
{
	pp1_check_rtype(PL_op->op_private);
	return NORMAL;
}

static OP *THX_pp_check_dyn_rtype(pTHX)
{
	pp1_check_dyn_rtype(PL_op->op_private);
	return NORMAL;
}

static OP *THX_pp_check_dyn_battr(pTHX)
{
	pp1_check_dyn_battr(PL_op->op_private);
	return NORMAL;
}

#endif /* QUSE_CUSTOM_OPS */

#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
static void S_croak_xs_usage(pTHX_ const CV *, const char *);
# define croak_xs_usage(cv, params) S_croak_xs_usage(aTHX_ cv, params)
#endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */

static void THX_xsfunc_scalar_class(pTHX_ CV *cv)
{
	dMARK; dSP;
	if(SP - MARK != 1) croak_xs_usage(cv, "arg");
	pp1_scalar_class();
}

static void THX_xsfunc_ref_type(pTHX_ CV *cv)
{
	dMARK; dSP;
	if(SP - MARK != 1) croak_xs_usage(cv, "arg");
	pp1_ref_type();
}

static void THX_xsfunc_blessed_class(pTHX_ CV *cv)
{
	dMARK; dSP;
	if(SP - MARK != 1) croak_xs_usage(cv, "arg");
	pp1_blessed_class();
}

static void THX_xsfunc_check_sclass(pTHX_ CV *cv)
{
	dMARK; dSP;
	if(SP - MARK != 1) croak_xs_usage(cv, "arg");
	pp1_check_sclass(CvXSUBANY(cv).any_i32);
}

static void THX_xsfunc_check_ref(pTHX_ CV *cv)
{
	I32 cvflags = CvXSUBANY(cv).any_i32;
	dMARK; dSP;
	switch(SP - MARK) {
		case 1: pp1_check_sclass(cvflags); break;
		case 2: pp1_check_dyn_rtype(cvflags & ~PC_TYPE_MASK); break;
		default: croak_xs_usage(cv, "arg, type");
	}
}

static void THX_xsfunc_check_blessed(pTHX_ CV *cv)
{
	I32 cvflags = CvXSUBANY(cv).any_i32;
	dMARK; dSP;
	switch(SP - MARK) {
		case 1: pp1_check_sclass(cvflags); break;
		case 2: pp1_check_dyn_battr(cvflags & ~PC_TYPE_MASK); break;
		default: croak_xs_usage(cv, "arg, class");
	}
}

#ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
# undef croak_xs_usage
#endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */

#if QUSE_CUSTOM_OPS

static PTR_TBL_t *ppmap;

static OP *THX_ck_entersub_pc(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
{
	CV *cv = (CV*)protosv;
	OP *(*THX_ppfunc)(pTHX) =
		DPTR2FPTR(OP*(*)(pTHX), ptr_table_fetch(ppmap, cv));
	I32 cvflags = CvXSUBANY(cv).any_i32;
	OP *pushop, *aop, *bop, *cop, *op;
	entersubop = ck_entersub_args_proto(entersubop, namegv, protosv);
	pushop = cUNOPx(entersubop)->op_first;
	if(!OpHAS_SIBLING(pushop)) pushop = cUNOPx(pushop)->op_first;
	aop = OpSIBLING(pushop);
	bop = OpSIBLING(aop);
	cop = bop ? OpSIBLING(bop) : NULL;
	if(bop && !cop) {
		if(!(cvflags & PC_ALLOW_UNARY)) return entersubop;
		unary:
		OpMORESIB_set(pushop, bop);
		OpLASTSIB_set(aop, NULL);
		op_free(entersubop);
		op = newUNOP(OP_NULL, 0, aop);
		op->op_type = OP_RAND;
		op->op_ppaddr = THX_ppfunc;
		op->op_private = (U8)cvflags;
		return op;
	} else if(cop && !OpHAS_SIBLING(cop)) {
		if(!(cvflags & PC_ALLOW_BINARY)) return entersubop;
		if(THX_ppfunc == THX_pp_check_sclass &&
				(cvflags & PC_TYPE_MASK) == SCLASS_REF) {
			I32 rtype;
			cvflags &= ~PC_TYPE_MASK;
			if(bop->op_type == OP_CONST &&
				(rtype = read_reftype_or_neg(cSVOPx_sv(bop)))
					>= 0) {
				cvflags |= rtype;
				THX_ppfunc = THX_pp_check_rtype;
				goto unary;
			}
			THX_ppfunc = THX_pp_check_dyn_rtype;
		} else if(THX_ppfunc == THX_pp_check_sclass &&
				(cvflags & PC_TYPE_MASK) == SCLASS_BLESSED) {
			cvflags &= ~PC_TYPE_MASK;
			THX_ppfunc = THX_pp_check_dyn_battr;
		}
		OpMORESIB_set(pushop, cop);
		OpLASTSIB_set(aop, NULL);
		OpLASTSIB_set(bop, NULL);
		op_free(entersubop);
		op = newBINOP(OP_NULL, 0, aop, bop);
		op->op_type = OP_RAND;
		op->op_ppaddr = THX_ppfunc;
		op->op_private = (U8)cvflags;
		return op;
	} else {
		return entersubop;
	}
}

#endif /* QUSE_CUSTOM_OPS */

MODULE = Params::Classify PACKAGE = Params::Classify

PROTOTYPES: DISABLE

BOOT:
{
	int i;
	for(i = RTYPE_COUNT; i--; ) {
		struct rtype_metadata *rtypemeta = &rtype_metadata[i];
		rtypemeta->keyword_sv =
			newSVpvn_share(rtypemeta->keyword_pv,
					strlen(rtypemeta->keyword_pv), 0);
	}
}
{
	int i;
	SV *tsv = sv_2mortal(newSV(0));
#if QUSE_CUSTOM_OPS
	ppmap = ptr_table_new();
# define SETUP_CUSTOM_OP(cv, THX_ppfunc) \
	do { \
		ptr_table_store(ppmap, FPTR2DPTR(void*, cv), \
			FPTR2DPTR(void*, THX_ppfunc)); \
		cv_set_call_checker(cv, THX_ck_entersub_pc, (SV*)cv); \
	} while(0)
#else /* !QUSE_CUSTOM_OPS */
# define SETUP_CUSTOM_OP(cv, THX_ppfunc) ((void)0)
#endif /* !QUSE_CUSTOM_OPS */
#define SETUP_SIMPLE_UNARY_XSUB(NAME) \
	do { \
		CV *cv = newXSproto_portable("Params::Classify::"#NAME, \
			THX_xsfunc_##NAME, __FILE__, "$"); \
		CvXSUBANY(cv).any_i32 = PC_ALLOW_UNARY; \
		SETUP_CUSTOM_OP(cv, THX_pp_##NAME); \
	} while(0)
	SETUP_SIMPLE_UNARY_XSUB(scalar_class);
	SETUP_SIMPLE_UNARY_XSUB(ref_type);
	SETUP_SIMPLE_UNARY_XSUB(blessed_class);
	for(i = SCLASS_COUNT; i--; ) {
		bool is_refish = i >= SCLASS_REF;
		struct sclass_metadata *sclassmeta = &sclass_metadata[i];
		char const *keyword_pv = sclassmeta->keyword_pv, *p;
		char lckeyword[8], *q;
		I32 cvflags = PC_ALLOW_UNARY |
			(is_refish ? PC_ALLOW_BINARY : 0) | i;
		I32 variant = (i == SCLASS_BLESSED ? PC_ABLE : 0) | PC_CROAK;
		void (*THX_xsfunc)(pTHX_ CV*) =
			i == SCLASS_REF ? THX_xsfunc_check_ref :
			i == SCLASS_BLESSED ? THX_xsfunc_check_blessed :
			THX_xsfunc_check_sclass;
		for(p = keyword_pv, q = lckeyword; *p; p++, q++)
			*q = *p | 0x20;
		*q = 0;
		sclassmeta->keyword_sv =
			newSVpvn_share(keyword_pv, strlen(keyword_pv), 0);
		for(; variant >= 0; variant -= PC_CROAK) {
			CV *cv;
			sv_setpvf(tsv, "Params::Classify::%s_%s",
				variant & PC_CROAK ? "check" : "is",
				variant & PC_ABLE ? "able" :
				variant & PC_STRICTBLESS ? "strictly_blessed" :
				lckeyword);
			cv = newXSproto_portable(SvPVX(tsv),
				THX_xsfunc, __FILE__, is_refish ? "$;$" : "$");
			CvXSUBANY(cv).any_i32 = cvflags | variant;
			SETUP_CUSTOM_OP(cv, THX_pp_check_sclass);
		}
	}
}
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)