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