#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 cBOOL
# define cBOOL(x) ((bool)!!(x))
#endif /* !cBOOL */

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

#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 */

#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)

#if defined(WIN32) && PERL_VERSION_GE(5,13,6)
# define MY_BASE_CALLCONV EXTERN_C
# define MY_BASE_CALLCONV_S "EXTERN_C"
#else /* !(WIN32 && >= 5.13.6) */
# define MY_BASE_CALLCONV PERL_CALLCONV
# define MY_BASE_CALLCONV_S "PERL_CALLCONV"
#endif /* !(WIN32 && >= 5.13.6) */

#define MY_EXPORT_CALLCONV MY_BASE_CALLCONV

#if defined(WIN32) || defined(__CYGWIN__)
# define MY_IMPORT_CALLCONV_S MY_BASE_CALLCONV_S" __declspec(dllimport)"
#else
# define MY_IMPORT_CALLCONV_S MY_BASE_CALLCONV_S
#endif

#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)
MY_EXPORT_CALLCONV 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 */

# ifndef CvGV_set
#  define CvGV_set(cv, gv) (CvGV(cv) = (gv))
# endif /* !CvGV_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(!OpHAS_SIBLING(pushop)) {
		if(!(pushop->op_flags & OPf_KIDS)) return NULL;
		pushop = cUNOPx(pushop)->op_first;
		if(!OpHAS_SIBLING(pushop)) return NULL;
	}
	for(bop = pushop; (cop = OpSIBLING(bop), OpHAS_SIBLING(cop));
			bop = cop) ;
	if(bop == pushop) return NULL;
	aop = OpSIBLING(pushop);
	OpMORESIB_set(pushop, cop);
	OpLASTSIB_set(bop, 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 = OpSIBLING(aop);
			op_free(aop);
			aop = bop;
		}
		return;
	}
	pushop = cUNOPx(entersubop)->op_first;
	if(!OpHAS_SIBLING(pushop)) {
		if(!(pushop->op_flags & OPf_KIDS)) goto abort;
		pushop = cUNOPx(pushop)->op_first;
		if(!OpHAS_SIBLING(pushop)) goto abort;
	}
	for(bop = aop; (cop = OpSIBLING(bop)); bop = cop) ;
	OpMORESIB_set(bop, OpSIBLING(pushop));
	OpMORESIB_set(pushop, 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)
MY_EXPORT_CALLCONV 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)
MY_EXPORT_CALLCONV 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*)sv_2mortal(newSV(0));
	gv_init(stalkgv, GvSTASH(namegv), GvNAME(namegv), GvNAMELEN(namegv), 0);
	GvCV_set(stalkgv, stalkcv);
	CvGV_set(stalkcv, stalkgv);
	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)
MY_EXPORT_CALLCONV 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 */

# if !PERL_VERSION_GE(5,9,3)
typedef OP *(*Perl_check_t)(pTHX_ OP *);
# endif /* <5.9.3 */

# if !PERL_VERSION_GE(5,10,1)
typedef unsigned Optype;
# endif /* <5.10.1 */

# ifndef wrap_op_checker
#  define wrap_op_checker(c,n,o) THX_wrap_op_checker(aTHX_ c,n,o)
static void THX_wrap_op_checker(pTHX_ Optype opcode,
	Perl_check_t new_checker, Perl_check_t *old_checker_p)
{
	if(*old_checker_p) return;
	OP_REFCNT_LOCK;
	if(!*old_checker_p) {
		*old_checker_p = PL_check[opcode];
		PL_check[opcode] = new_checker;
	}
	OP_REFCNT_UNLOCK;
}
# endif /* !wrap_op_checker */

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, THX_ckfun_p, ckobj_p) \
	Perl_cv_get_call_checker(aTHX_ cv, THX_ckfun_p, ckobj_p)
MY_EXPORT_CALLCONV void QPFXD(gcc0)(pTHX_ CV *cv,
	Perl_call_checker *THX_ckfun_p, SV **ckobj_p)
{
	MAGIC *callmg = SvMAGICAL((SV*)cv) ?
		mg_findext((SV*)cv, PERL_MAGIC_ext, &mgvtbl_checkcall) : NULL;
	if(callmg) {
		*THX_ckfun_p = DPTR2FPTR(Perl_call_checker, callmg->mg_ptr);
		*ckobj_p = callmg->mg_obj;
	} else {
		*THX_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, THX_ckfun, ckobj) \
	Perl_cv_set_call_checker(aTHX_ cv, THX_ckfun, ckobj)
MY_EXPORT_CALLCONV void QPFXD(scc0)(pTHX_ CV *cv,
	Perl_call_checker THX_ckfun, SV *ckobj)
{
	if(THX_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 *, THX_ckfun);
		callmg->mg_obj = ckobj;
		if(ckobj != (SV*)cv) {
			SvREFCNT_inc(ckobj);
			callmg->mg_flags |= MGf_REFCOUNTED;
		}
	}
}

static OP *(*THX_nxck_entersub)(pTHX_ OP *);

static OP *THX_myck_entersub(pTHX_ OP *entersubop)
{
	OP *aop, *cvop;
	CV *cv;
	GV *namegv;
	Perl_call_checker THX_ckfun;
	SV *ckobj;
	aop = cUNOPx(entersubop)->op_first;
	if(!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first;
	aop = OpSIBLING(aop);
	for(cvop = aop; OpHAS_SIBLING(cvop); cvop = OpSIBLING(cvop)) ;
	if(!(cv = rv2cv_op_cv(cvop, 0)))
		return THX_nxck_entersub(aTHX_ entersubop);
	cv_get_call_checker(cv, &THX_ckfun, &ckobj);
	if(THX_ckfun == Perl_ck_entersub_args_proto_or_list && ckobj == (SV*)cv)
		return THX_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 THX_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
	wrap_op_checker(OP_ENTERSUB, THX_myck_entersub, &THX_nxck_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)
#if PERL_VERSION & 1
			" && PERL_SUBVERSION == "STRINGIFY(PERL_SUBVERSION)
#endif /* PERL_VERSION & 1 */
			")\n"
		" #error this callchecker0.h is for Perl "
			STRINGIFY(PERL_REVISION)"."STRINGIFY(PERL_VERSION)
#if PERL_VERSION & 1
			"."STRINGIFY(PERL_SUBVERSION)
#endif /* PERL_VERSION & 1 */
			" only\n"
		"#endif /* Perl version mismatch */\n"
#define DEFFN(RETTYPE, PUBNAME, PRIVNAME, ARGTYPES, ARGNAMES) \
	MY_IMPORT_CALLCONV_S" "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