1 #define PERL_NO_GET_CONTEXT 1
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "callck_callchecker0.h"
5 #include "XSUB.h"
6 
7 #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s)
8 #define PERL_DECIMAL_VERSION \
9 	PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION)
10 #define PERL_VERSION_GE(r,v,s) \
11 	(PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s))
12 
13 #ifndef cBOOL
14 # define cBOOL(x) ((bool)!!(x))
15 #endif /* !cBOOL */
16 
17 #ifndef PERL_UNUSED_VAR
18 # define PERL_UNUSED_VAR(x) ((void)x)
19 #endif /* !PERL_UNUSED_VAR */
20 
21 #ifndef PERL_UNUSED_ARG
22 # define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x)
23 #endif /* !PERL_UNUSED_ARG */
24 
25 #ifndef FPTR2DPTR
26 # define FPTR2DPTR(t,x) ((t)(UV)(x))
27 #endif /* !FPTR2DPTR */
28 
29 #ifndef OpMORESIB_set
30 # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
31 # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
32 # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
33 #endif /* !OpMORESIB_set */
34 #ifndef OpSIBLING
35 # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
36 # define OpSIBLING(o) (0 + (o)->op_sibling)
37 #endif /* !OpSIBLING */
38 
39 #ifndef op_contextualize
40 # define op_contextualize(o, c) THX_op_contextualize(aTHX_ o, c)
THX_op_contextualize(pTHX_ OP * o,I32 c)41 static OP *THX_op_contextualize(pTHX_ OP *o, I32 c)
42 {
43 	if(c == G_SCALAR) {
44 		OP *sib, *assop, *nullop;
45 		sib = o->op_sibling;
46 		o->op_sibling = NULL;
47 		assop = newASSIGNOP(0, newOP(OP_NULL, 0), 0, o);
48 		o = cBINOPx(assop)->op_first;
49 		nullop = newOP(OP_NULL, 0);
50 		nullop->op_sibling = o->op_sibling;
51 		cBINOPx(assop)->op_first = nullop;
52 		if(!nullop->op_sibling) cBINOPx(assop)->op_last = nullop;
53 		op_free(assop);
54 		o->op_sibling = sib;
55 		return o;
56 	} else {
57 		croak("reserve op_contextualize abused");
58 	}
59 }
60 #endif /* !op_contextualize */
61 
THX_ck_entersub_args_lists(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)62 static OP *THX_ck_entersub_args_lists(pTHX_ OP *entersubop,
63 	GV *namegv, SV *ckobj)
64 {
65 	PERL_UNUSED_ARG(namegv);
66 	PERL_UNUSED_ARG(ckobj);
67 	return ck_entersub_args_list(entersubop);
68 }
69 
THX_ck_entersub_args_scalars(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)70 static OP *THX_ck_entersub_args_scalars(pTHX_ OP *entersubop,
71 	GV *namegv, SV *ckobj)
72 {
73 	OP *aop = cUNOPx(entersubop)->op_first;
74 	PERL_UNUSED_ARG(namegv);
75 	PERL_UNUSED_ARG(ckobj);
76 	if (!OpHAS_SIBLING(aop))
77 		aop = cUNOPx(aop)->op_first;
78 	for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) {
79 		op_contextualize(aop, G_SCALAR);
80 	}
81 	return entersubop;
82 }
83 
THX_ck_entersub_multi_sum(pTHX_ OP * entersubop,GV * namegv,SV * ckobj)84 static OP *THX_ck_entersub_multi_sum(pTHX_ OP *entersubop,
85 	GV *namegv, SV *ckobj)
86 {
87 	OP *sumop = NULL;
88 	OP *pushop = cUNOPx(entersubop)->op_first;
89 	PERL_UNUSED_ARG(namegv);
90 	PERL_UNUSED_ARG(ckobj);
91 	if (!OpHAS_SIBLING(pushop))
92 		pushop = cUNOPx(pushop)->op_first;
93 	while (1) {
94 		OP *aop = OpSIBLING(pushop);
95 		OP *as;
96 		if (!OpHAS_SIBLING(aop)) break;
97 		as = OpSIBLING(aop);
98 		OpMORESIB_set(pushop, as);
99 		OpLASTSIB_set(aop, NULL);
100 		op_contextualize(aop, G_SCALAR);
101 		if (sumop) {
102 			sumop = newBINOP(OP_ADD, 0, sumop, aop);
103 		} else {
104 			sumop = aop;
105 		}
106 	}
107 	if (!sumop)
108 		sumop = newSVOP(OP_CONST, 0, newSViv(0));
109 	op_free(entersubop);
110 	return sumop;
111 }
112 
113 MODULE = t::callck PACKAGE = t::callck
114 
115 PROTOTYPES: DISABLE
116 
117 void
118 test_cv_getset_call_checker()
119 PROTOTYPE:
120 PREINIT:
121 	CV *t0_cv, *t1_cv;
122 	Perl_call_checker ckfun;
123 	SV *ckobj;
124 CODE:
125 #define croak_fail() croak("fail at " __FILE__ " line %d", __LINE__)
126 #define croak_fail_ne(h, w) \
127 	croak("fail %p!=%p at " __FILE__ " line %d", (h), (w), __LINE__)
128 #define check_cc(cv, xckfun, xckobj) \
129 	do { \
130 		cv_get_call_checker((cv), &ckfun, &ckobj); \
131 		if (ckfun != (xckfun)) \
132 			croak_fail_ne(FPTR2DPTR(void *, ckfun), xckfun); \
133 		if (ckobj != (xckobj)) \
134 			croak_fail_ne(FPTR2DPTR(void *, ckobj), xckobj); \
135 	} while(0)
136 	t0_cv = get_cv("t::callck::t0", 0);
137 	t1_cv = get_cv("t::callck::t1", 0);
138 	check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv);
139 	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv);
140 	cv_set_call_checker(t1_cv, Perl_ck_entersub_args_proto_or_list,
141 				&PL_sv_yes);
142 	check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv);
143 	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
144 	cv_set_call_checker(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
145 	check_cc(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
146 	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, &PL_sv_yes);
147 	cv_set_call_checker(t1_cv, Perl_ck_entersub_args_proto_or_list,
148 				(SV*)t1_cv);
149 	check_cc(t0_cv, THX_ck_entersub_args_scalars, &PL_sv_no);
150 	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv);
151 	cv_set_call_checker(t0_cv, Perl_ck_entersub_args_proto_or_list,
152 				(SV*)t0_cv);
153 	check_cc(t0_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t0_cv);
154 	check_cc(t1_cv, Perl_ck_entersub_args_proto_or_list, (SV*)t1_cv);
155 	if (SvMAGICAL((SV*)t0_cv) || SvMAGIC((SV*)t0_cv)) croak_fail();
156 	if (SvMAGICAL((SV*)t1_cv) || SvMAGIC((SV*)t1_cv)) croak_fail();
157 #undef check_cc
158 #undef croak_fail_ne
159 #undef croak_fail
160 
161 void
162 t0()
163 PROTOTYPE:
164 CODE:
165 	;
166 
167 void
168 t1()
169 PROTOTYPE:
170 CODE:
171 	;
172 
173 void
174 cv_set_call_checker_lists(CV *cv)
175 PROTOTYPE: $
176 CODE:
177 	cv_set_call_checker(cv, THX_ck_entersub_args_lists, &PL_sv_undef);
178 
179 void
180 cv_set_call_checker_scalars(CV *cv)
181 PROTOTYPE: $
182 CODE:
183 	cv_set_call_checker(cv, THX_ck_entersub_args_scalars, &PL_sv_undef);
184 
185 void
186 cv_set_call_checker_proto(CV *cv, SV *proto)
187 PROTOTYPE: $$
188 CODE:
189 	if (SvROK(proto))
190 		proto = SvRV(proto);
191 	cv_set_call_checker(cv, Perl_ck_entersub_args_proto, proto);
192 
193 void
194 cv_set_call_checker_proto_or_list(CV *cv, SV *proto)
195 PROTOTYPE: $$
196 CODE:
197 	if (SvROK(proto))
198 		proto = SvRV(proto);
199 	cv_set_call_checker(cv, Perl_ck_entersub_args_proto_or_list, proto);
200 
201 void
202 cv_set_call_checker_multi_sum(CV *cv)
203 PROTOTYPE: $
204 CODE:
205 	cv_set_call_checker(cv, THX_ck_entersub_multi_sum, &PL_sv_undef);
206