#define PERL_NO_GET_CONTEXT 1

#include "EXTERN.h"

#include "perl.h"

#include "callck_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 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 */

#ifndef op_contextualize

# define op_contextualize(o, c) THX_op_contextualize(aTHX_ o, c)

static OP *THX_op_contextualize(pTHX_ OP *o, I32 c)

{

	if(c == G_SCALAR) {

		OP *sib, *assop, *nullop;

		sib = o->op_sibling;

		o->op_sibling = NULL;

		assop = newASSIGNOP(0, newOP(OP_NULL, 0), 0, o);

		o = cBINOPx(assop)->op_first;

		nullop = newOP(OP_NULL, 0);

		nullop->op_sibling = o->op_sibling;

		cBINOPx(assop)->op_first = nullop;

		if(!nullop->op_sibling) cBINOPx(assop)->op_last = nullop;

		op_free(assop);

		o->op_sibling = sib;

		return o;

	} else {

		croak("reserve op_contextualize abused");

	}

}

#endif /* !op_contextualize */

static OP *THX_ck_entersub_args_lists(pTHX_ OP *entersubop,

	GV *namegv, SV *ckobj)

{

	PERL_UNUSED_ARG(namegv);

	PERL_UNUSED_ARG(ckobj);

	return ck_entersub_args_list(entersubop);

}

static OP *THX_ck_entersub_args_scalars(pTHX_ OP *entersubop,

	GV *namegv, SV *ckobj)

{

	OP *aop = cUNOPx(entersubop)->op_first;

	PERL_UNUSED_ARG(namegv);

	PERL_UNUSED_ARG(ckobj);

	if (!OpHAS_SIBLING(aop))

		aop = cUNOPx(aop)->op_first;

	for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {

		op_contextualize(aop, G_SCALAR);

	}

	return entersubop;

}

static OP *THX_ck_entersub_multi_sum(pTHX_ OP *entersubop,

	GV *namegv, SV *ckobj)

{

	OP *sumop = NULL;

	OP *pushop = cUNOPx(entersubop)->op_first;

	PERL_UNUSED_ARG(namegv);

	PERL_UNUSED_ARG(ckobj);

	if (!OpHAS_SIBLING(pushop))

		pushop = cUNOPx(pushop)->op_first;

	while (1) {

		OP *aop = OpSIBLING(pushop);

		OP *as;

		if (!OpHAS_SIBLING(aop)) break;

		as = OpSIBLING(aop);

		OpMORESIB_set(pushop, as);

		OpLASTSIB_set(aop, NULL);

		op_contextualize(aop, G_SCALAR);

		if (sumop) {

			sumop = newBINOP(OP_ADD, 0, sumop, aop);

		} else {

			sumop = aop;

		}

	}

	if (!sumop)

		sumop = newSVOP(OP_CONST, 0, newSViv(0));

	op_free(entersubop);

	return sumop;

}

MODULE = t::callck PACKAGE = t::callck

PROTOTYPES: DISABLE

void

test_cv_getset_call_checker()

PROTOTYPE:

PREINIT:

	CV *t0_cv, *t1_cv;

	Perl_call_checker ckfun;

	SV *ckobj;

CODE:

#define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)

#define croak_fail_ne(h, w) \

	croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)

#define check_cc(cv, xckfun, xckobj) \

	do { \

		cv_get_call_checker((cv), &ckfun, &ckobj); \

		if (ckfun != (xckfun)) \

			croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \

		if (ckobj != (xckobj)) \

			croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \

	} while(0)

	t0_cv = get_cv("t::callck::t0", 0);

	t1_cv = get_cv("t::callck::t1", 0);

	check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv);

	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv);

	cv_set_call_checker(t1_cv, Perl_ck_entersub_args_proto_or_list,

				&PL_sv_yes);

	check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv);

	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);

	cv_set_call_checker(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no);

	check_cc(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no);

	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);

	cv_set_call_checker(t1_cv, Perl_ck_entersub_args_proto_or_list,

				(SV*)t1_cv);

	check_cc(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no);

	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv);

	cv_set_call_checker(t0_cv, Perl_ck_entersub_args_proto_or_list,

				(SV*)t0_cv);

	check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv);

	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv);

	if (SvMAGICAL((SV*)t0_cv) || SvMAGIC((SV*)t0_cv)) croak_fail();

	if (SvMAGICAL((SV*)t1_cv) || SvMAGIC((SV*)t1_cv)) croak_fail();

#undef check_cc

#undef croak_fail_ne

#undef croak_fail

void

t0()

PROTOTYPE:

CODE:

	;

void

t1()

PROTOTYPE:

CODE:

	;

void

cv_set_call_checker_lists(CV *cv)

PROTOTYPE: $

CODE:

	cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);

void

cv_set_call_checker_scalars(CV *cv)

PROTOTYPE: $

CODE:

	cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);

void

cv_set_call_checker_proto(CV *cv, SV *proto)

PROTOTYPE: $$

CODE:

	if (SvROK(proto))

		proto = SvRV(proto);

	cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);

void

cv_set_call_checker_proto_or_list(CV *cv, SV *proto)

PROTOTYPE: $$

CODE:

	if (SvROK(proto))

		proto = SvRV(proto);

	cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);

void

cv_set_call_checker_multi_sum(CV *cv)

PROTOTYPE: $

CODE:

	cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);