lib/Devel/CallChecker.xs

#define PERL_NO_GET_CONTEXT 1
#include "EXTERN.h"
#include "perl.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 PERL_VERSION_STRING
# define PERL_VERSION_STRING \
	STRINGIFY(PERL_REVISION) "." \
	STRINGIFY(PERL_VERSION) "." \
	STRINGIFY(PERL_SUBVERSION)
#endif /* !PERL_VERSION_STRING */

#ifndef newSVpvs
# define newSVpvs(s) newSVpvn(""s"", (sizeof(""s"")-1))
#endif /* !newSVpvs */

#define QPFX xAd8NP3gxZglovQRL5Hn_
#define QPFXS STRINGIFY(QPFX)
#define QCONCAT0(a,b) a##b
#define QCONCAT1(a,b) QCONCAT0(a,b)
#define QPFXD(name) QCONCAT1(QPFX, name)

#ifndef rv2cv_op_cv

# define RV2CVOPCV_MARK_EARLY     0x00000001
# define RV2CVOPCV_RETURN_NAME_GV 0x00000002

# define Perl_rv2cv_op_cv QPFXD(roc0)
# define rv2cv_op_cv(cvop, flags) Perl_rv2cv_op_cv(aTHX_ cvop, flags)
CV *QPFXD(roc0)(pTHX_ OP *cvop, U32 flags)
{
	OP *rvop;
	CV *cv;
	GV *gv;
	if(!(cvop->op_type == OP_RV2CV &&
			!(cvop->op_private & OPpENTERSUB_AMPER) &&
			(cvop->op_flags & OPf_KIDS)))
		return NULL;
	rvop = cUNOPx(cvop)->op_first;
	switch(rvop->op_type) {
		case OP_GV: {
			gv = cGVOPx_gv(rvop);
			cv = GvCVu(gv);
			if(!cv) {
				if(flags & RV2CVOPCV_MARK_EARLY)
					rvop->op_private |= OPpEARLY_CV;
				return NULL;
			}
		} break;
#if PERL_VERSION_GE(5,11,2)
		case OP_CONST: {
			SV *rv = cSVOPx_sv(rvop);
			if(!SvROK(rv)) return NULL;
			cv = (CV*)SvRV(rv);
			gv = NULL;
		} break;
#endif /* >=5.11.2 */
		default: {
			return NULL;
		} break;
	}
	if(SvTYPE((SV*)cv) != SVt_PVCV) return NULL;
	if(flags & RV2CVOPCV_RETURN_NAME_GV) {
		if(!CvANON(cv) || !gv) gv = CvGV(cv);
		return (CV*)gv;
	} else {
		return cv;
	}
}

# define Q_PROVIDE_RV2CV_OP_CV 1

#endif /* !rv2cv_op_cv */

#ifndef ck_entersub_args_proto_or_list

# ifndef newSV_type
#  define newSV_type(type) THX_newSV_type(aTHX_ type)
static SV *THX_newSV_type(pTHX_ svtype type)
{
	SV *sv = newSV(0);
	(void) SvUPGRADE(sv, type);
	return sv;
}
# endif /* !newSV_type */

# ifndef GvCV_set
#  define GvCV_set(gv, cv) (GvCV(gv) = (cv))
# endif /* !GvCV_set */

# define entersub_extract_args(eo) THX_entersub_extract_args(aTHX_ eo)
static OP *THX_entersub_extract_args(pTHX_ OP *entersubop)
{
	OP *pushop, *aop, *bop, *cop;
	if(!(entersubop->op_flags & OPf_KIDS)) return NULL;
	pushop = cUNOPx(entersubop)->op_first;
	if(!pushop->op_sibling) {
		if(!(pushop->op_flags & OPf_KIDS)) return NULL;
		pushop = cUNOPx(pushop)->op_first;
		if(!pushop->op_sibling) return NULL;
	}
	for(bop = pushop; (cop = bop->op_sibling)->op_sibling; bop = cop) ;
	if(bop == pushop) return NULL;
	aop = pushop->op_sibling;
	pushop->op_sibling = cop;
	bop->op_sibling = NULL;
	return aop;
}

# define entersub_inject_args(eo, ao) THX_entersub_inject_args(aTHX_ eo, ao)
static void THX_entersub_inject_args(pTHX_ OP *entersubop, OP *aop)
{
	OP *pushop, *bop, *cop;
	if(!aop) return;
	if(!(entersubop->op_flags & OPf_KIDS)) {
		abort:
		while(aop) {
			bop = aop->op_sibling;
			op_free(aop);
			aop = bop;
		}
		return;
	}
	pushop = cUNOPx(entersubop)->op_first;
	if(!pushop->op_sibling) {
		if(!(pushop->op_flags & OPf_KIDS)) goto abort;
		pushop = cUNOPx(pushop)->op_first;
		if(!pushop->op_sibling) goto abort;
	}
	for(bop = aop; (cop = bop->op_sibling); bop = cop) ;
	bop->op_sibling = pushop->op_sibling;
	pushop->op_sibling = aop;
}

# define ck_entersub_args_stalk(eo, so) THX_ck_entersub_args_stalk(aTHX_ eo, so)
static OP *THX_ck_entersub_args_stalk(pTHX_ OP *entersubop, OP *stalkcvop)
{
	OP *stalkenterop = newLISTOP(OP_LIST, 0, newCVREF(0, stalkcvop), NULL);
	entersub_inject_args(stalkenterop, entersub_extract_args(entersubop));
	stalkenterop = newUNOP(OP_ENTERSUB, OPf_STACKED, stalkenterop);
	entersub_inject_args(entersubop, entersub_extract_args(stalkenterop));
	op_free(stalkenterop);
	return entersubop;
}

# define Perl_ck_entersub_args_list QPFXD(eal0)
# define ck_entersub_args_list(o) Perl_ck_entersub_args_list(aTHX_ o)
OP *QPFXD(eal0)(pTHX_ OP *entersubop)
{
	return ck_entersub_args_stalk(entersubop, newOP(OP_PADANY, 0));
}

# define Perl_ck_entersub_args_proto QPFXD(eap0)
# define ck_entersub_args_proto(o, gv, sv) \
	Perl_ck_entersub_args_proto(aTHX_ o, gv, sv)
OP *QPFXD(eap0)(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
{
	const char *proto;
	STRLEN proto_len;
	CV *stalkcv;
	GV *stalkgv;
	if(SvTYPE(protosv) == SVt_PVCV ? !SvPOK(protosv) : !SvOK(protosv))
		croak("panic: ck_entersub_args_proto CV with no proto");
	proto = SvPV(protosv, proto_len);
	stalkcv = (CV*)newSV_type(SVt_PVCV);
	sv_setpvn((SV*)stalkcv, proto, proto_len);
	stalkgv = (GV*)newSV(0);
	gv_init(stalkgv, GvSTASH(namegv), GvNAME(namegv), GvNAMELEN(namegv), 0);
	GvCV_set(stalkgv, stalkcv);
	return ck_entersub_args_stalk(entersubop, newGVOP(OP_GV, 0, stalkgv));
}

# define Perl_ck_entersub_args_proto_or_list QPFXD(ean0)
# define ck_entersub_args_proto_or_list(o, gv, sv) \
	Perl_ck_entersub_args_proto_or_list(aTHX_ o, gv, sv)
OP *QPFXD(ean0)(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
{
	if(SvTYPE(protosv) == SVt_PVCV ? SvPOK(protosv) : SvOK(protosv))
		return ck_entersub_args_proto(entersubop, namegv, protosv);
	else
		return ck_entersub_args_list(entersubop);
}

# define Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST 1

#endif /* !ck_entersub_args_proto_or_list */

#ifndef cv_set_call_checker

# ifndef Newxz
#  define Newxz(v,n,t) Newz(0,v,n,t)
# endif /* !Newxz */

# ifndef SvMAGIC_set
#  define SvMAGIC_set(sv, mg) (SvMAGIC(sv) = (mg))
# endif /* !SvMAGIC_set */

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

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

# ifndef op_null
#  define op_null(o) THX_op_null(aTHX_ o)
static void THX_op_null(pTHX_ OP *o)
{
	if(o->op_type == OP_NULL) return;
	/* must not be used on any op requiring non-trivial clearing */
	o->op_targ = o->op_type;
	o->op_type = OP_NULL;
	o->op_ppaddr = PL_ppaddr[OP_NULL];
}
# endif /* !op_null */

# ifndef mg_findext
#  define mg_findext(sv, type, vtbl) THX_mg_findext(aTHX_ sv, type, vtbl)
static MAGIC *THX_mg_findext(pTHX_ SV *sv, int type, MGVTBL const *vtbl)
{
	MAGIC *mg;
	if(sv)
		for(mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic)
			if(mg->mg_type == type && mg->mg_virtual == vtbl)
				return mg;
	return NULL;
}
# endif /* !mg_findext */

# ifndef sv_unmagicext
#  define sv_unmagicext(sv, type, vtbl) THX_sv_unmagicext(aTHX_ sv, type, vtbl)
static int THX_sv_unmagicext(pTHX_ SV *sv, int type, MGVTBL const *vtbl)
{
	MAGIC *mg, **mgp;
	if((vtbl && vtbl->svt_free)
#  ifdef PERL_MAGIC_regex_global
			|| type == PERL_MAGIC_regex_global
#  endif /* PERL_MAGIC_regex_global */
			)
		/* exceeded intended usage of this reserve implementation */
		return 0;
	if(SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0;
	mgp = NULL;
	for(mg = mgp ? *mgp : SvMAGIC(sv); mg; mg = mgp ? *mgp : SvMAGIC(sv)) {
		if(mg->mg_type == type && mg->mg_virtual == vtbl) {
			if(mgp)
				*mgp = mg->mg_moremagic;
			else
				SvMAGIC_set(sv, mg->mg_moremagic);
			if(mg->mg_flags & MGf_REFCOUNTED)
				SvREFCNT_dec(mg->mg_obj);
			Safefree(mg);
		} else {
			mgp = &mg->mg_moremagic;
		}
	}
	SvMAGICAL_off(sv);
	mg_magical(sv);
	return 0;
}
# endif /* !sv_unmagicext */

# ifndef sv_magicext
#  define sv_magicext(sv, obj, type, vtbl, name, namlen) \
	THX_sv_magicext(aTHX_ sv, obj, type, vtbl, name, namlen)
static MAGIC *THX_sv_magicext(pTHX_ SV *sv, SV *obj, int type,
	MGVTBL const *vtbl, char const *name, I32 namlen)
{
	MAGIC *mg;
	if(!(obj == &PL_sv_undef && !name && !namlen))
		/* exceeded intended usage of this reserve implementation */
		return NULL;
	Newxz(mg, 1, MAGIC);
	mg->mg_virtual = (MGVTBL*)vtbl;
	mg->mg_type = type;
	mg->mg_obj = &PL_sv_undef;
	(void) SvUPGRADE(sv, SVt_PVMG);
	mg->mg_moremagic = SvMAGIC(sv);
	SvMAGIC_set(sv, mg);
	SvMAGICAL_off(sv);
	mg_magical(sv);
	return mg;
}
# endif /* !sv_magicext */

# ifndef PERL_MAGIC_ext
#  define PERL_MAGIC_ext '~'
# endif /* !PERL_MAGIC_ext */

static MGVTBL mgvtbl_checkcall;

typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);

# define Perl_cv_get_call_checker QPFXD(gcc0)
# define cv_get_call_checker(cv, ckfun_p, ckobj_p) \
	Perl_cv_get_call_checker(aTHX_ cv, ckfun_p, ckobj_p)
void QPFXD(gcc0)(pTHX_ CV *cv, Perl_call_checker *ckfun_p, SV **ckobj_p)
{
	MAGIC *callmg = SvMAGICAL((SV*)cv) ?
		mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_checkcall) : NULL;
	if(callmg) {
		*ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
		*ckobj_p = callmg->mg_obj;
	} else {
		*ckfun_p = Perl_ck_entersub_args_proto_or_list;
		*ckobj_p = (SV*)cv;
	}
}

# define Perl_cv_set_call_checker QPFXD(scc0)
# define cv_set_call_checker(cv, ckfun, ckobj) \
	Perl_cv_set_call_checker(aTHX_ cv, ckfun, ckobj)
void QPFXD(scc0)(pTHX_ CV *cv, Perl_call_checker ckfun, SV *ckobj)
{
	if(ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv) {
		if(SvMAGICAL((SV*)cv))
			sv_unmagicext((SV*)cv, PERL_MAGIC_ext,
				&mgvtbl_checkcall);
	} else {
		MAGIC *callmg =
			mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_checkcall);
		if(!callmg)
			callmg = sv_magicext((SV*)cv, &PL_sv_undef,
				PERL_MAGIC_ext, &mgvtbl_checkcall, NULL, 0);
		if(callmg->mg_flags & MGf_REFCOUNTED) {
			SvREFCNT_dec(callmg->mg_obj);
			callmg->mg_flags &= ~MGf_REFCOUNTED;
		}
		callmg->mg_ptr = FPTR2DPTR(char *, ckfun);
		callmg->mg_obj = ckobj;
		if(ckobj != (SV*)cv) {
			SvREFCNT_inc(ckobj);
			callmg->mg_flags |= MGf_REFCOUNTED;
		}
	}
}

static OP *(*nxck_entersub)(pTHX_ OP *);
static OP *myck_entersub(pTHX_ OP *entersubop)
{
	OP *aop, *cvop;
	CV *cv;
	GV *namegv;
	Perl_call_checker ckfun;
	SV *ckobj;
	aop = cUNOPx(entersubop)->op_first;
	if(!aop->op_sibling) aop = cUNOPx(aop)->op_first;
	aop = aop->op_sibling;
	for(cvop = aop; cvop->op_sibling; cvop = cvop->op_sibling) ;
	if(!(cv = rv2cv_op_cv(cvop, 0)))
		return nxck_entersub(aTHX_ entersubop);
	cv_get_call_checker(cv, &ckfun, &ckobj);
	if(ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv)
		return nxck_entersub(aTHX_ entersubop);
	namegv = (GV*)rv2cv_op_cv(cvop,
			RV2CVOPCV_MARK_EARLY|RV2CVOPCV_RETURN_NAME_GV);
	entersubop->op_private |= OPpENTERSUB_HASTARG;
	entersubop->op_private |= (PL_hints & HINT_STRICT_REFS);
	if(PERLDB_SUB && PL_curstash != PL_debstash)
		entersubop->op_private |= OPpENTERSUB_DB;
	op_null(cvop);
	return ckfun(aTHX_ entersubop, namegv, ckobj);
}

#define Q_PROVIDE_CV_SET_CALL_CHECKER 1

#endif /* !cv_set_call_checker */

MODULE = Devel::CallChecker PACKAGE = Devel::CallChecker

PROTOTYPES: DISABLE

BOOT:
#if Q_PROVIDE_CV_SET_CALL_CHECKER
	nxck_entersub = PL_check[OP_ENTERSUB];
	PL_check[OP_ENTERSUB] = myck_entersub;
#endif /* Q_PROVIDE_CV_SET_CALL_CHECKER */

SV *
callchecker0_h()
CODE:
	RETVAL = newSVpvs(
		"/* DO NOT EDIT -- generated "
			"by Devel::CallChecker version "XS_VERSION" */\n"
		"#ifndef "QPFXS"INCLUDED\n"
		"#define "QPFXS"INCLUDED 1\n"
		"#ifndef PERL_VERSION\n"
		" #error you must include perl.h before callchecker0.h\n"
		"#elif !(PERL_REVISION == "STRINGIFY(PERL_REVISION)" && "
			"PERL_VERSION == "STRINGIFY(PERL_VERSION)" && "
			"PERL_SUBVERSION == "STRINGIFY(PERL_SUBVERSION)")\n"
		" #error this callchecker0.h is for "
			"Perl "PERL_VERSION_STRING" only\n"
		"#endif /* Perl version mismatch */\n"
#define DEFFN(RETTYPE, PUBNAME, PRIVNAME, ARGTYPES, ARGNAMES) \
	RETTYPE" "QPFXS PRIVNAME"(pTHX_ "ARGTYPES");\n" \
	"#define Perl_"PUBNAME" "QPFXS PRIVNAME"\n" \
	"#define "PUBNAME"("ARGNAMES") Perl_"PUBNAME"(aTHX_ "ARGNAMES")\n"
#if Q_PROVIDE_RV2CV_OP_CV
		"#define RV2CVOPCV_MARK_EARLY     0x00000001\n"
		"#define RV2CVOPCV_RETURN_NAME_GV 0x00000002\n"
		DEFFN("CV *", "rv2cv_op_cv", "roc0", "OP *, U32", "cvop, flags")
#endif /* Q_PROVIDE_RV2CV_OP_CV */
#if Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST
		DEFFN("OP *", "ck_entersub_args_list", "eal0", "OP *", "o")
		DEFFN("OP *", "ck_entersub_args_proto", "eap0",
			"OP *, GV *, SV *", "o, gv, sv")
		DEFFN("OP *", "ck_entersub_args_proto_or_list", "ean0",
			"OP *, GV *, SV *", "o, gv, sv")
#endif /* Q_PROVIDE_CK_ENTERSUB_ARGS_PROTO_OR_LIST */
#if Q_PROVIDE_CV_SET_CALL_CHECKER
		"typedef OP *(*Perl_call_checker)(pTHX_ OP *, GV *, SV *);\n"
		DEFFN("void", "cv_get_call_checker", "gcc0",
			"CV *, Perl_call_checker *, SV **", "cv, fp, op")
		DEFFN("void", "cv_set_call_checker", "scc0",
			"CV *, Perl_call_checker, SV *", "cv, f, o")
#endif /* Q_PROVIDE_CV_SET_CALL_CHECKER */
		"#endif /* !"QPFXS"INCLUDED */\n"
	);
OUTPUT:
	RETVAL
	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)
Keyboard Shortcuts
