1 #define PERL_NO_GET_CONTEXT 1
2 #include "EXTERN.h"
3 #include "perl.h"
4 #include "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 #if !PERL_VERSION_GE(5,7,2)
14 # undef dNOOP
15 # define dNOOP extern int Perl___notused_func(void)
16 #endif /* <5.7.2 */
17
18 #ifndef cBOOL
19 # define cBOOL(x) ((bool)!!(x))
20 #endif /* !cBOOL */
21
22 #ifndef PERL_UNUSED_VAR
23 # define PERL_UNUSED_VAR(x) ((void)x)
24 #endif /* !PERL_UNUSED_VAR */
25
26 #ifndef PERL_UNUSED_ARG
27 # define PERL_UNUSED_ARG(x) PERL_UNUSED_VAR(x)
28 #endif /* !PERL_UNUSED_ARG */
29
30 #ifndef Newx
31 # define Newx(v,n,t) New(0,v,n,t)
32 #endif /* !Newx */
33
34 #ifndef HvNAME_get
35 # define HvNAME_get(hv) HvNAME(hv)
36 #endif
37
38 #ifndef newSVpvs_share
39 # define newSVpvs_share(s) newSVpvn_share(""s"", (sizeof(""s"")-1), 0)
40 #endif /* !newSVpvs_share */
41
42 #ifndef newSVpvn_share
43 # define newSVpvn_share(s, l, h) newSVpvn(s, l)
44 #endif /* !newSVpvn_share */
45
46 #if PERL_VERSION_GE(5,19,4)
47 typedef SSize_t array_ix_t;
48 #else /* <5.19.4 */
49 typedef I32 array_ix_t;
50 #endif /* <5.19.4 */
51
52 #ifndef DPTR2FPTR
53 # define DPTR2FPTR(t,x) ((t)(UV)(x))
54 #endif /* !DPTR2FPTR */
55
56 #ifndef FPTR2DPTR
57 # define FPTR2DPTR(t,x) ((t)(UV)(x))
58 #endif /* !FPTR2DPTR */
59
60 #ifndef OpMORESIB_set
61 # define OpMORESIB_set(o, sib) ((o)->op_sibling = (sib))
62 # define OpLASTSIB_set(o, parent) ((o)->op_sibling = NULL)
63 # define OpMAYBESIB_set(o, sib, parent) ((o)->op_sibling = (sib))
64 #endif /* !OpMORESIB_set */
65 #ifndef OpSIBLING
66 # define OpHAS_SIBLING(o) (cBOOL((o)->op_sibling))
67 # define OpSIBLING(o) (0 + (o)->op_sibling)
68 #endif /* !OpSIBLING */
69
70 #ifdef cv_set_call_checker
71 # define QUSE_CUSTOM_OPS 1
72 #else /* !cv_set_call_checker */
73 # define QUSE_CUSTOM_OPS 0
74 #endif /* !cv_set_call_checker */
75
76 #if defined(QUSE_CUSTOM_OPS) && !defined(ptr_table_new)
77
78 struct q_ptr_tbl_ent {
79 struct q_ptr_tbl_ent *next;
80 void *from, *to;
81 };
82
83 # undef PTR_TBL_t
84 # define PTR_TBL_t struct q_ptr_tbl_ent *
85
86 # define ptr_table_new() THX_ptr_table_new(aTHX)
THX_ptr_table_new(pTHX)87 static PTR_TBL_t *THX_ptr_table_new(pTHX)
88 {
89 PTR_TBL_t *tbl;
90 Newx(tbl, 1, PTR_TBL_t);
91 *tbl = NULL;
92 return tbl;
93 }
94
95 # if 0
96 # define ptr_table_free(tbl) THX_ptr_table_free(aTHX_ tbl)
97 static void THX_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
98 {
99 struct q_ptr_tbl_ent *ent = *tbl;
100 Safefree(tbl);
101 while(ent) {
102 struct q_ptr_tbl_ent *nent = ent->next;
103 Safefree(ent);
104 ent = nent;
105 }
106 }
107 # endif /* 0 */
108
109 # define ptr_table_store(tbl, from, to) THX_ptr_table_store(aTHX_ tbl, from, to)
THX_ptr_table_store(pTHX_ PTR_TBL_t * tbl,void * from,void * to)110 static void THX_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *from, void *to)
111 {
112 struct q_ptr_tbl_ent *ent;
113 Newx(ent, 1, struct q_ptr_tbl_ent);
114 ent->next = *tbl;
115 ent->from = from;
116 ent->to = to;
117 *tbl = ent;
118 }
119
120 # define ptr_table_fetch(tbl, from) THX_ptr_table_fetch(aTHX_ tbl, from)
THX_ptr_table_fetch(pTHX_ PTR_TBL_t * tbl,void * from)121 static void *THX_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *from)
122 {
123 struct q_ptr_tbl_ent *ent;
124 for(ent = *tbl; ent; ent = ent->next) {
125 if(ent->from == from) return ent->to;
126 }
127 return NULL;
128 }
129
130 #endif /* QUSE_CUSTOM_OPS && !ptr_table_new */
131
132 #if PERL_VERSION_GE(5,7,3)
133 # define PERL_UNUSED_THX() NOOP
134 #else /* <5.7.3 */
135 # define PERL_UNUSED_THX() ((void)(aTHX+0))
136 #endif /* <5.7.3 */
137
138 #if PERL_VERSION_GE(5,11,0)
139 # define case_SVt_RV_
140 #else /* <5.11.0 */
141 # define case_SVt_RV_ case SVt_RV:
142 #endif /* <5.11.0 */
143
144 #if PERL_VERSION_GE(5,9,5)
145 # define case_SVt_PVBM_
146 #else /* <5.11.0 */
147 # define case_SVt_PVBM_ case SVt_PVBM:
148 #endif /* <5.11.0 */
149
150 #if PERL_VERSION_GE(5,11,0)
151 # define case_SVt_REGEXP_ case SVt_REGEXP:
152 #else /* <5.11.0 */
153 # define case_SVt_REGEXP_
154 #endif /* <5.11.0 */
155
156 #define sv_is_glob(sv) (SvTYPE(sv) == SVt_PVGV)
157
158 #if PERL_VERSION_GE(5,11,0)
159 # define sv_is_regexp(sv) (SvTYPE(sv) == SVt_REGEXP)
160 #else /* <5.11.0 */
161 # define sv_is_regexp(sv) 0
162 #endif /* <5.11.0 */
163
164 #define sv_is_undef(sv) (!sv_is_glob(sv) && !sv_is_regexp(sv) && !SvOK(sv))
165
166 #define sv_is_string(sv) \
167 (!sv_is_glob(sv) && !sv_is_regexp(sv) && \
168 (SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)))
169
170 #define sv_is_untyped_ref(sv) (SvROK(sv) && !SvOBJECT(SvRV(sv)))
171 #define sv_is_untyped_blessed(sv) (SvROK(sv) && SvOBJECT(SvRV(sv)))
172
THX_sv_is_undef(pTHX_ SV * sv)173 static bool THX_sv_is_undef(pTHX_ SV *sv) {
174 PERL_UNUSED_THX();
175 return cBOOL(sv_is_undef(sv));
176 }
177
THX_sv_is_string(pTHX_ SV * sv)178 static bool THX_sv_is_string(pTHX_ SV *sv) {
179 PERL_UNUSED_THX();
180 return cBOOL(sv_is_string(sv));
181 }
182
THX_sv_is_glob(pTHX_ SV * sv)183 static bool THX_sv_is_glob(pTHX_ SV *sv) {
184 PERL_UNUSED_THX();
185 return cBOOL(sv_is_glob(sv));
186 }
187
THX_sv_is_regexp(pTHX_ SV * sv)188 static bool THX_sv_is_regexp(pTHX_ SV *sv) {
189 PERL_UNUSED_THX();
190 PERL_UNUSED_ARG(sv);
191 return cBOOL(sv_is_regexp(sv));
192 }
193
THX_sv_is_untyped_ref(pTHX_ SV * sv)194 static bool THX_sv_is_untyped_ref(pTHX_ SV *sv) {
195 PERL_UNUSED_THX();
196 return cBOOL(sv_is_untyped_ref(sv));
197 }
198
THX_sv_is_untyped_blessed(pTHX_ SV * sv)199 static bool THX_sv_is_untyped_blessed(pTHX_ SV *sv) {
200 PERL_UNUSED_THX();
201 return cBOOL(sv_is_untyped_blessed(sv));
202 }
203
204 enum {
205 SCLASS_UNDEF,
206 SCLASS_STRING,
207 SCLASS_GLOB,
208 SCLASS_REGEXP,
209 SCLASS_REF,
210 SCLASS_BLESSED,
211 SCLASS_COUNT
212 };
213
214 static struct sclass_metadata {
215 char const *desc_adj_or_noun_phrase, *keyword_pv;
216 SV *keyword_sv;
217 bool (*THX_sv_is_sclass)(pTHX_ SV *);
218 } sclass_metadata[SCLASS_COUNT] = {
219 { "undefined", "UNDEF", NULL, THX_sv_is_undef },
220 { "a string", "STRING", NULL, THX_sv_is_string },
221 { "a typeglob", "GLOB", NULL, THX_sv_is_glob },
222 { "a regexp", "REGEXP", NULL, THX_sv_is_regexp },
223 { "a reference to plain object",
224 "REF", NULL, THX_sv_is_untyped_ref },
225 { "a reference to blessed object",
226 "BLESSED", NULL, THX_sv_is_untyped_blessed },
227 };
228
229 enum {
230 RTYPE_SCALAR,
231 RTYPE_ARRAY,
232 RTYPE_HASH,
233 RTYPE_CODE,
234 RTYPE_FORMAT,
235 RTYPE_IO,
236 RTYPE_COUNT
237 };
238
239 static struct rtype_metadata {
240 char const *desc_noun, *keyword_pv;
241 SV *keyword_sv;
242 } rtype_metadata[RTYPE_COUNT] = {
243 { "scalar", "SCALAR", NULL },
244 { "array", "ARRAY", NULL },
245 { "hash", "HASH", NULL },
246 { "code", "CODE", NULL },
247 { "format", "FORMAT", NULL },
248 { "io", "IO", NULL },
249 };
250
251 #define PC_TYPE_MASK 0x00f
252 #define PC_CROAK 0x010
253 #define PC_STRICTBLESS 0x020
254 #define PC_ABLE 0x040
255 #define PC_ALLOW_UNARY 0x100
256 #define PC_ALLOW_BINARY 0x200
257
258 #define scalar_class(arg) THX_scalar_class(aTHX_ arg)
THX_scalar_class(pTHX_ SV * arg)259 static I32 THX_scalar_class(pTHX_ SV *arg)
260 {
261 PERL_UNUSED_THX();
262 if(sv_is_glob(arg)) {
263 return SCLASS_GLOB;
264 } else if(sv_is_regexp(arg)) {
265 return SCLASS_REGEXP;
266 } else if(!SvOK(arg)) {
267 return SCLASS_UNDEF;
268 } else if(SvROK(arg)) {
269 return SvOBJECT(SvRV(arg)) ? SCLASS_BLESSED : SCLASS_REF;
270 } else if(SvFLAGS(arg) &
271 (SVf_IOK|SVf_NOK|SVf_POK|SVp_IOK|SVp_NOK|SVp_POK)) {
272 return SCLASS_STRING;
273 } else {
274 croak("unknown scalar class, please update Params::Classify\n");
275 }
276 }
277
278 #define read_reftype_or_neg(reftype) THX_read_reftype_or_neg(aTHX_ reftype)
THX_read_reftype_or_neg(pTHX_ SV * reftype)279 static I32 THX_read_reftype_or_neg(pTHX_ SV *reftype)
280 {
281 char *p;
282 STRLEN l;
283 if(!sv_is_string(reftype)) return -2;
284 p = SvPV(reftype, l);
285 if(strlen(p) != l) return -1;
286 switch(p[0]) {
287 case 'S':
288 if(!strcmp(p, "SCALAR")) return RTYPE_SCALAR;
289 return -1;
290 case 'A':
291 if(!strcmp(p, "ARRAY")) return RTYPE_ARRAY;
292 return -1;
293 case 'H':
294 if(!strcmp(p, "HASH")) return RTYPE_HASH;
295 return -1;
296 case 'C':
297 if(!strcmp(p, "CODE")) return RTYPE_CODE;
298 return -1;
299 case 'F':
300 if(!strcmp(p, "FORMAT")) return RTYPE_FORMAT;
301 return -1;
302 case 'I':
303 if(!strcmp(p, "IO")) return RTYPE_IO;
304 return -1;
305 default:
306 return -1;
307 }
308 }
309
310 #define read_reftype(reftype) THX_read_reftype(aTHX_ reftype)
THX_read_reftype(pTHX_ SV * reftype)311 static I32 THX_read_reftype(pTHX_ SV *reftype)
312 {
313 I32 rtype = read_reftype_or_neg(reftype);
314 if(rtype < 0)
315 croak(rtype == -2 ?
316 "reference type argument is not a string\n" :
317 "invalid reference type\n");
318 return rtype;
319 }
320
321 #define ref_type(referent) THX_ref_type(aTHX_ referent)
THX_ref_type(pTHX_ SV * referent)322 static I32 THX_ref_type(pTHX_ SV *referent)
323 {
324 PERL_UNUSED_THX();
325 switch(SvTYPE(referent)) {
326 case SVt_NULL: case SVt_IV: case SVt_NV: case_SVt_RV_
327 case SVt_PV: case SVt_PVIV: case SVt_PVNV:
328 case SVt_PVMG: case SVt_PVLV: case SVt_PVGV:
329 case_SVt_PVBM_ case_SVt_REGEXP_
330 return RTYPE_SCALAR;
331 case SVt_PVAV:
332 return RTYPE_ARRAY;
333 case SVt_PVHV:
334 return RTYPE_HASH;
335 case SVt_PVCV:
336 return RTYPE_CODE;
337 case SVt_PVFM:
338 return RTYPE_FORMAT;
339 case SVt_PVIO:
340 return RTYPE_IO;
341 default:
342 croak("unknown SvTYPE, "
343 "please update Params::Classify\n");
344 }
345 }
346
347 #define blessed_class(referent) THX_blessed_class(aTHX_ referent)
THX_blessed_class(pTHX_ SV * referent)348 static const char *THX_blessed_class(pTHX_ SV *referent)
349 {
350 HV *stash = SvSTASH(referent);
351 const char *name = HvNAME_get(stash);
352 PERL_UNUSED_THX();
353 return name ? name : "__ANON__";
354 }
355
356 #define call_bool_method(objref, methodname, arg) \
357 THX_call_bool_method(aTHX_ objref, methodname, arg)
THX_call_bool_method(pTHX_ SV * objref,const char * methodname,SV * arg)358 static bool THX_call_bool_method(pTHX_ SV *objref, const char *methodname,
359 SV *arg)
360 {
361 dSP;
362 int retcount;
363 SV *ret;
364 bool retval;
365 ENTER;
366 SAVETMPS;
367 PUSHMARK(SP);
368 XPUSHs(objref);
369 XPUSHs(arg);
370 PUTBACK;
371 retcount = call_method(methodname, G_SCALAR);
372 SPAGAIN;
373 if(retcount != 1) croak("call_method misbehaving\n");
374 ret = POPs;
375 retval = cBOOL(SvTRUE(ret));
376 PUTBACK;
377 FREETMPS;
378 LEAVE;
379 return retval;
380 }
381
382 #define pp1_scalar_class() THX_pp1_scalar_class(aTHX)
THX_pp1_scalar_class(pTHX)383 static void THX_pp1_scalar_class(pTHX)
384 {
385 dSP;
386 SV *arg = TOPs;
387 TOPs = sclass_metadata[scalar_class(arg)].keyword_sv;
388 }
389
390 #define pp1_ref_type() THX_pp1_ref_type(aTHX)
THX_pp1_ref_type(pTHX)391 static void THX_pp1_ref_type(pTHX)
392 {
393 dSP;
394 SV *arg, *referent;
395 arg = TOPs;
396 TOPs = !SvROK(arg) || (referent = SvRV(arg), SvOBJECT(referent)) ?
397 &PL_sv_undef :
398 rtype_metadata[ref_type(referent)].keyword_sv;
399 }
400
401 #define pp1_blessed_class() THX_pp1_blessed_class(aTHX)
THX_pp1_blessed_class(pTHX)402 static void THX_pp1_blessed_class(pTHX)
403 {
404 dSP;
405 SV *arg, *referent;
406 arg = TOPs;
407 TOPs = !SvROK(arg) || (referent = SvRV(arg), !SvOBJECT(referent)) ?
408 &PL_sv_undef :
409 sv_2mortal(newSVpv(blessed_class(referent), 0));
410 }
411
412 #define pp1_check_sclass(t) THX_pp1_check_sclass(aTHX_ t)
THX_pp1_check_sclass(pTHX_ I32 t)413 static void THX_pp1_check_sclass(pTHX_ I32 t)
414 {
415 dSP;
416 SV *arg = POPs;
417 struct sclass_metadata const *sclassmeta =
418 &sclass_metadata[t & PC_TYPE_MASK];
419 bool matches;
420 PUTBACK;
421 matches = sclassmeta->THX_sv_is_sclass(aTHX_ arg);
422 SPAGAIN;
423 if(t & PC_CROAK) {
424 if(!matches)
425 croak("argument is not %s\n",
426 sclassmeta->desc_adj_or_noun_phrase);
427 if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef);
428 } else {
429 SV *result = boolSV(matches);
430 XPUSHs(result);
431 }
432 PUTBACK;
433 }
434
435 #define pp1_check_rtype(t) THX_pp1_check_rtype(aTHX_ t)
THX_pp1_check_rtype(pTHX_ I32 t)436 static void THX_pp1_check_rtype(pTHX_ I32 t)
437 {
438 dSP;
439 SV *arg = POPs, *referent;
440 I32 rtype = t & PC_TYPE_MASK;
441 struct rtype_metadata const *rtypemeta = &rtype_metadata[rtype];
442 bool matches = SvROK(arg) &&
443 (referent = SvRV(arg), !SvOBJECT(referent)) &&
444 ref_type(referent) == rtype;
445 if(t & PC_CROAK) {
446 if(!matches)
447 croak("argument is not a reference to plain %s\n",
448 rtypemeta->desc_noun);
449 if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef);
450 } else {
451 SV *result = boolSV(matches);
452 XPUSHs(result);
453 }
454 PUTBACK;
455 }
456
457 #define pp1_check_dyn_rtype(t) THX_pp1_check_dyn_rtype(aTHX_ t)
THX_pp1_check_dyn_rtype(pTHX_ I32 t)458 static void THX_pp1_check_dyn_rtype(pTHX_ I32 t)
459 {
460 dSP;
461 SV *type_sv = POPs;
462 PUTBACK;
463 pp1_check_rtype(t | read_reftype(type_sv));
464 }
465
466 #define pp1_check_dyn_battr(t) THX_pp1_check_dyn_battr(aTHX_ t)
THX_pp1_check_dyn_battr(pTHX_ I32 t)467 static void THX_pp1_check_dyn_battr(pTHX_ I32 t)
468 {
469 dSP;
470 SV *attr, *arg, *meth = NULL;
471 bool matches;
472 attr = POPs;
473 if(t & PC_ABLE) {
474 if(sv_is_string(attr)) {
475 meth = attr;
476 } else {
477 AV *methods_av;
478 array_ix_t alen, pos;
479 if(!SvROK(attr) || SvOBJECT(SvRV(attr)) ||
480 SvTYPE(SvRV(attr)) != SVt_PVAV)
481 croak("methods argument is not "
482 "a string or array\n");
483 methods_av = (AV*)SvRV(attr);
484 alen = av_len(methods_av);
485 for(pos = 0; pos <= alen; pos++) {
486 SV **m_ptr = av_fetch(methods_av, pos, 0);
487 if(!m_ptr || !sv_is_string(*m_ptr))
488 croak("method name is not a string\n");
489 }
490 if(alen != -1) meth = *av_fetch(methods_av, 0, 0);
491 }
492 } else {
493 if(!sv_is_string(attr))
494 croak("class argument is not a string\n");
495 }
496 arg = POPs;
497 if((matches = SvROK(arg) && SvOBJECT(SvRV(arg)))) {
498 if(t & PC_ABLE) {
499 PUTBACK;
500 if(!SvROK(attr)) {
501 meth = attr;
502 matches = call_bool_method(arg, "can", attr);
503 } else {
504 AV *methods_av = (AV*)SvRV(attr);
505 array_ix_t alen = av_len(methods_av), pos;
506 for(pos = 0; pos <= alen; pos++) {
507 meth = *av_fetch(methods_av, pos, 0);
508 if(!call_bool_method(arg, "can",
509 meth)) {
510 matches = 0;
511 break;
512 }
513 }
514 }
515 SPAGAIN;
516 } else if(t & PC_STRICTBLESS) {
517 char const *actual_class = blessed_class(SvRV(arg));
518 char const *check_class;
519 STRLEN check_len;
520 check_class = SvPV(attr, check_len);
521 matches = check_len == strlen(actual_class) &&
522 !strcmp(check_class, actual_class);
523 } else {
524 PUTBACK;
525 matches = call_bool_method(arg, "isa", attr);
526 SPAGAIN;
527 }
528 }
529 if(t & PC_CROAK) {
530 if(!matches) {
531 if(t & PC_ABLE) {
532 if(meth) {
533 croak("argument is not able to "
534 "perform method \"%s\"\n",
535 SvPV_nolen(meth));
536 } else {
537 croak("argument is not able to "
538 "perform at all\n");
539 }
540 } else {
541 croak("argument is not a reference to "
542 "%sblessed %s\n",
543 t & PC_STRICTBLESS ? "strictly " : "",
544 SvPV_nolen(attr));
545 }
546 }
547 if(GIMME_V == G_SCALAR) XPUSHs(&PL_sv_undef);
548 } else {
549 SV *result = boolSV(matches);
550 XPUSHs(result);
551 }
552 PUTBACK;
553 }
554
555 #if QUSE_CUSTOM_OPS
556
THX_pp_scalar_class(pTHX)557 static OP *THX_pp_scalar_class(pTHX)
558 {
559 pp1_scalar_class();
560 return NORMAL;
561 }
562
THX_pp_ref_type(pTHX)563 static OP *THX_pp_ref_type(pTHX)
564 {
565 pp1_ref_type();
566 return NORMAL;
567 }
568
THX_pp_blessed_class(pTHX)569 static OP *THX_pp_blessed_class(pTHX)
570 {
571 pp1_blessed_class();
572 return NORMAL;
573 }
574
THX_pp_check_sclass(pTHX)575 static OP *THX_pp_check_sclass(pTHX)
576 {
577 pp1_check_sclass(PL_op->op_private);
578 return NORMAL;
579 }
580
THX_pp_check_rtype(pTHX)581 static OP *THX_pp_check_rtype(pTHX)
582 {
583 pp1_check_rtype(PL_op->op_private);
584 return NORMAL;
585 }
586
THX_pp_check_dyn_rtype(pTHX)587 static OP *THX_pp_check_dyn_rtype(pTHX)
588 {
589 pp1_check_dyn_rtype(PL_op->op_private);
590 return NORMAL;
591 }
592
THX_pp_check_dyn_battr(pTHX)593 static OP *THX_pp_check_dyn_battr(pTHX)
594 {
595 pp1_check_dyn_battr(PL_op->op_private);
596 return NORMAL;
597 }
598
599 #endif /* QUSE_CUSTOM_OPS */
600
601 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
602 static void S_croak_xs_usage(const CV *, const char *);
603 # define croak_xs_usage(cv, params) S_croak_xs_usage(cv, params)
604 #endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */
605
THX_xsfunc_scalar_class(pTHX_ CV * cv)606 static void THX_xsfunc_scalar_class(pTHX_ CV *cv)
607 {
608 dMARK; dSP;
609 if(SP - MARK != 1) croak_xs_usage(cv, "arg");
610 pp1_scalar_class();
611 }
612
THX_xsfunc_ref_type(pTHX_ CV * cv)613 static void THX_xsfunc_ref_type(pTHX_ CV *cv)
614 {
615 dMARK; dSP;
616 if(SP - MARK != 1) croak_xs_usage(cv, "arg");
617 pp1_ref_type();
618 }
619
THX_xsfunc_blessed_class(pTHX_ CV * cv)620 static void THX_xsfunc_blessed_class(pTHX_ CV *cv)
621 {
622 dMARK; dSP;
623 if(SP - MARK != 1) croak_xs_usage(cv, "arg");
624 pp1_blessed_class();
625 }
626
THX_xsfunc_check_sclass(pTHX_ CV * cv)627 static void THX_xsfunc_check_sclass(pTHX_ CV *cv)
628 {
629 dMARK; dSP;
630 if(SP - MARK != 1) croak_xs_usage(cv, "arg");
631 pp1_check_sclass(CvXSUBANY(cv).any_i32);
632 }
633
THX_xsfunc_check_ref(pTHX_ CV * cv)634 static void THX_xsfunc_check_ref(pTHX_ CV *cv)
635 {
636 I32 cvflags = CvXSUBANY(cv).any_i32;
637 dMARK; dSP;
638 switch(SP - MARK) {
639 case 1: pp1_check_sclass(cvflags); break;
640 case 2: pp1_check_dyn_rtype(cvflags & ~PC_TYPE_MASK); break;
641 default: croak_xs_usage(cv, "arg, type");
642 }
643 }
644
THX_xsfunc_check_blessed(pTHX_ CV * cv)645 static void THX_xsfunc_check_blessed(pTHX_ CV *cv)
646 {
647 I32 cvflags = CvXSUBANY(cv).any_i32;
648 dMARK; dSP;
649 switch(SP - MARK) {
650 case 1: pp1_check_sclass(cvflags); break;
651 case 2: pp1_check_dyn_battr(cvflags & ~PC_TYPE_MASK); break;
652 default: croak_xs_usage(cv, "arg, class");
653 }
654 }
655
656 #ifndef PERL_ARGS_ASSERT_CROAK_XS_USAGE
657 # undef croak_xs_usage
658 #endif /* !PERL_ARGS_ASSERT_CROAK_XS_USAGE */
659
660 #if QUSE_CUSTOM_OPS
661
662 static PTR_TBL_t *ppmap;
663
THX_ck_entersub_pc(pTHX_ OP * entersubop,GV * namegv,SV * protosv)664 static OP *THX_ck_entersub_pc(pTHX_ OP *entersubop, GV *namegv, SV *protosv)
665 {
666 CV *cv = (CV*)protosv;
667 OP *(*THX_ppfunc)(pTHX) =
668 DPTR2FPTR(OP*(*)(pTHX), ptr_table_fetch(ppmap, cv));
669 I32 cvflags = CvXSUBANY(cv).any_i32;
670 OP *pushop, *aop, *bop, *cop, *op;
671 entersubop = ck_entersub_args_proto(entersubop, namegv, protosv);
672 pushop = cUNOPx(entersubop)->op_first;
673 if(!OpHAS_SIBLING(pushop)) pushop = cUNOPx(pushop)->op_first;
674 aop = OpSIBLING(pushop);
675 bop = OpSIBLING(aop);
676 cop = bop ? OpSIBLING(bop) : NULL;
677 if(bop && !cop) {
678 if(!(cvflags & PC_ALLOW_UNARY)) return entersubop;
679 unary:
680 OpMORESIB_set(pushop, bop);
681 OpLASTSIB_set(aop, NULL);
682 op_free(entersubop);
683 op = newUNOP(OP_NULL, 0, aop);
684 op->op_type = OP_RAND;
685 op->op_ppaddr = THX_ppfunc;
686 op->op_private = (U8)cvflags;
687 return op;
688 } else if(cop && !OpHAS_SIBLING(cop)) {
689 if(!(cvflags & PC_ALLOW_BINARY)) return entersubop;
690 if(THX_ppfunc == THX_pp_check_sclass &&
691 (cvflags & PC_TYPE_MASK) == SCLASS_REF) {
692 I32 rtype;
693 cvflags &= ~PC_TYPE_MASK;
694 if(bop->op_type == OP_CONST &&
695 (rtype = read_reftype_or_neg(cSVOPx_sv(bop)))
696 >= 0) {
697 cvflags |= rtype;
698 THX_ppfunc = THX_pp_check_rtype;
699 goto unary;
700 }
701 THX_ppfunc = THX_pp_check_dyn_rtype;
702 } else if(THX_ppfunc == THX_pp_check_sclass &&
703 (cvflags & PC_TYPE_MASK) == SCLASS_BLESSED) {
704 cvflags &= ~PC_TYPE_MASK;
705 THX_ppfunc = THX_pp_check_dyn_battr;
706 }
707 OpMORESIB_set(pushop, cop);
708 OpLASTSIB_set(aop, NULL);
709 OpLASTSIB_set(bop, NULL);
710 op_free(entersubop);
711 op = newBINOP(OP_NULL, 0, aop, bop);
712 op->op_type = OP_RAND;
713 op->op_ppaddr = THX_ppfunc;
714 op->op_private = (U8)cvflags;
715 return op;
716 } else {
717 return entersubop;
718 }
719 }
720
721 #endif /* QUSE_CUSTOM_OPS */
722
723 MODULE = Params::Classify PACKAGE = Params::Classify
724
725 PROTOTYPES: DISABLE
726
727 BOOT:
728 {
729 int i;
730 for(i = RTYPE_COUNT; i--; ) {
731 struct rtype_metadata *rtypemeta = &rtype_metadata[i];
732 rtypemeta->keyword_sv =
733 newSVpvn_share(rtypemeta->keyword_pv,
734 strlen(rtypemeta->keyword_pv), 0);
735 }
736 }
737 {
738 int i;
739 SV *tsv = sv_2mortal(newSV(0));
740 #if QUSE_CUSTOM_OPS
741 ppmap = ptr_table_new();
742 # define SETUP_CUSTOM_OP(pcv, THX_ppfunc) \
743 do { \
744 ptr_table_store(ppmap, FPTR2DPTR(void*, pcv), \
745 FPTR2DPTR(void*, THX_ppfunc)); \
746 cv_set_call_checker(pcv, THX_ck_entersub_pc, (SV*)pcv); \
747 } while(0)
748 #else /* !QUSE_CUSTOM_OPS */
749 # define SETUP_CUSTOM_OP(pcv, THX_ppfunc) ((void)0)
750 #endif /* !QUSE_CUSTOM_OPS */
751 #define SETUP_SIMPLE_UNARY_XSUB(NAME) \
752 do { \
753 CV *pcv = newXSproto_portable("Params::Classify::"#NAME, \
754 THX_xsfunc_##NAME, __FILE__, "$"); \
755 CvXSUBANY(pcv).any_i32 = PC_ALLOW_UNARY; \
756 SETUP_CUSTOM_OP(pcv, THX_pp_##NAME); \
757 } while(0)
758 SETUP_SIMPLE_UNARY_XSUB(scalar_class);
759 SETUP_SIMPLE_UNARY_XSUB(ref_type);
760 SETUP_SIMPLE_UNARY_XSUB(blessed_class);
761 for(i = SCLASS_COUNT; i--; ) {
762 bool is_refish = i >= SCLASS_REF;
763 struct sclass_metadata *sclassmeta = &sclass_metadata[i];
764 char const *keyword_pv = sclassmeta->keyword_pv, *p;
765 char lckeyword[8], *q;
766 I32 cvflags = PC_ALLOW_UNARY |
767 (is_refish ? PC_ALLOW_BINARY : 0) | i;
768 I32 variant = (i == SCLASS_BLESSED ? PC_ABLE : 0) | PC_CROAK;
769 void (*THX_xsfunc)(pTHX_ CV*) =
770 i == SCLASS_REF ? THX_xsfunc_check_ref :
771 i == SCLASS_BLESSED ? THX_xsfunc_check_blessed :
772 THX_xsfunc_check_sclass;
773 for(p = keyword_pv, q = lckeyword; *p; p++, q++)
774 *q = *p | 0x20;
775 *q = 0;
776 sclassmeta->keyword_sv =
777 newSVpvn_share(keyword_pv, strlen(keyword_pv), 0);
778 for(; variant >= 0; variant -= PC_CROAK) {
779 CV *pcv;
780 sv_setpvf(tsv, "Params::Classify::%s_%s",
781 variant & PC_CROAK ? "check" : "is",
782 variant & PC_ABLE ? "able" :
783 variant & PC_STRICTBLESS ? "strictly_blessed" :
784 lckeyword);
785 pcv = newXSproto_portable(SvPVX(tsv),
786 THX_xsfunc, __FILE__, is_refish ? "$;$" : "$");
787 CvXSUBANY(pcv).any_i32 = cvflags | variant;
788 SETUP_CUSTOM_OP(pcv, THX_pp_check_sclass);
789 }
790 }
791 }
792