view release on metacpan or  search on metacpan

lib/B/CallChecker.xs  view on Meta::CPAN

	*ckobj_p = valp ? *valp : &PL_sv_undef;
}

static OP *cckfun_perl_ckfun(pTHX_ OP *entersubop, GV *namegv, SV *cckobj)
{
	SV *ckobj_st, *namegv_st, *entersubop_st, *ckobj;
	CV *ckfun;
	ckfun_decode_perl_as_c(0, cckobj, &ckfun, &ckobj);
	entersubop_st = encode_bop(entersubop);
	namegv_st = sv_2mortal(newRV_inc((SV*)namegv));
	ckobj_st = sv_2mortal(newRV_inc(ckobj));
	ENTER;
	{
		dSP;
		PUSHMARK(SP);
		EXTEND(SP, 3);
		PUSHs(entersubop_st);
		PUSHs(namegv_st);
		PUSHs(ckobj_st);
		PUTBACK;
		call_sv((SV*)ckfun, G_SCALAR);
		SPAGAIN;
		entersubop_st = POPs;
		PUTBACK;
	}
	LEAVE;
	return decode_bop(entersubop_st);
}

#define install_cv(cv, name) THX_install_cv(aTHX_ cv, name)
static void THX_install_cv(pTHX_ CV *cv, char const *name)
{
	GV *gv = gv_fetchpv(name, GV_ADDMULTI, SVt_PVCV);
	GvCV_set(gv, cv);
	GvCVGEN(gv) = 0;
	CvGV_set(cv, gv);
}

typedef SV *SVREF;

MODULE = B::CallChecker PACKAGE = B::CallChecker

PROTOTYPES: DISABLE

BOOT:
	ckfun_cap_map = ptr_table_new();
	stash_bop = gv_stashpvs("B::OP", 1);
	install_cv(ckfun_encode_c_as_perl(Perl_ck_entersub_args_proto),
		"B::CallChecker::ck_entersub_args_proto");
	install_cv(ckfun_encode_c_as_perl(Perl_ck_entersub_args_proto_or_list),
		"B::CallChecker::ck_entersub_args_proto_or_list");

void
cv_get_call_checker(CV *tgtcv)
PROTOTYPE: $
PREINIT:
	Perl_call_checker cckfun;
	SV *cckobj;
	CV *ckfun;
	SV *ckobj;
PPCODE:
	PUTBACK;
	cv_get_call_checker(tgtcv, &cckfun, &cckobj);
	if(ckfun_c_is_encoded_perl(cckfun)) {
		ckfun_decode_perl_as_c(cckfun, cckobj, &ckfun, &ckobj);
	} else {
		ckfun = ckfun_encode_c_as_perl(cckfun);
		ckobj = cckobj;
	}
	SPAGAIN;
	EXTEND(SP, 2);
	PUSHs(sv_2mortal(newRV_inc((SV*)ckfun)));
	PUSHs(sv_2mortal(newRV_inc(ckobj)));

void
cv_set_call_checker(CV *tgtcv, CV *ckfun, SVREF ckobj)
PROTOTYPE: $$$
PREINIT:
	Perl_call_checker cckfun;
	SV *cckobj;
CODE:
	PUTBACK;
	if(ckfun_perl_is_encoded_c(ckfun)) {
		cckfun = ckfun_decode_c_as_perl(ckfun);
		cckobj = ckobj;
	} else {
		ckfun_encode_perl_as_c(ckfun, ckobj, &cckfun, &cckobj);
	}
	cv_set_call_checker(tgtcv, cckfun, cckobj);
	SPAGAIN;

OP *
ck_entersub_args_list(OP *entersubop)
PROTOTYPE: $
CODE:
	PUTBACK;
	RETVAL = ck_entersub_args_list(entersubop);
	SPAGAIN;
OUTPUT:
	RETVAL