File Coverage

XS.xs
Criterion Covered Total %
statement 410 522 78.5
branch 386 760 50.7
condition n/a
subroutine n/a
pod n/a
total 796 1282 62.0


line stmt bran cond sub pod time code
1             #include "typetiny.h"
2             #include "xs_version.h"
3              
4             #ifndef SvRXOK
5             #define SvRXOK(sv) (SvROK(sv) && SvMAGICAL(SvRV(sv)) && mg_find(SvRV(sv), PERL_MAGIC_qr))
6             #endif
7              
8             #define MY_CXT_KEY "Type::Tiny::XS::_guts" XS_VERSION
9             typedef struct sui_cxt{
10             GV* universal_isa;
11             GV* universal_can;
12             AV* tc_extra_args;
13             } my_cxt_t;
14             START_MY_CXT
15              
16             typedef int (*check_fptr_t)(pTHX_ SV* const data, SV* const sv);
17              
18             static
19             XSPROTO(XS_TypeTiny_constraint_check);
20              
21             /*
22             NOTE: typetiny_tc_check() handles GETMAGIC
23             */
24             int
25 131           typetiny_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
26 131           CV* const cv = (CV*)SvRV(tc_code);
27             assert(SvTYPE(cv) == SVt_PVCV);
28              
29 131 50         if(CvXSUB(cv) == XS_TypeTiny_constraint_check){ /* built-in type constraints */
30 131           MAGIC* const mg = (MAGIC*)CvXSUBANY(cv).any_ptr;
31              
32             assert(CvXSUBANY(cv).any_ptr != NULL);
33             assert(mg->mg_ptr != NULL);
34              
35 131 50         SvGETMAGIC(sv);
    0          
36             /* call the check function directly, skipping call_sv() */
37 131           return CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv);
38             }
39             else { /* custom */
40             int ok;
41 0           dSP;
42             dMY_CXT;
43              
44 0           ENTER;
45 0           SAVETMPS;
46              
47 0 0         PUSHMARK(SP);
48 0 0         XPUSHs(sv);
49 0 0         if( MY_CXT.tc_extra_args ) {
50 0           AV* const av = MY_CXT.tc_extra_args;
51 0           I32 const len = AvFILLp(av) + 1;
52             int i;
53 0 0         for(i = 0; i < len; i++) {
54 0 0         XPUSHs( AvARRAY(av)[i] );
55             }
56             }
57 0           PUTBACK;
58              
59 0           call_sv(tc_code, G_SCALAR);
60              
61 0           SPAGAIN;
62 0           ok = sv_true(POPs);
63 0           PUTBACK;
64              
65 0 0         FREETMPS;
66 0           LEAVE;
67              
68 0           return ok;
69             }
70             }
71              
72             /*
73             The following type check functions return an integer, not a bool, to keep
74             the code simple,
75             so if you assign these return value to a bool variable, you must use
76             "expr ? TRUE : FALSE".
77             */
78              
79             int
80 3           typetiny_tc_Any(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv PERL_UNUSED_DECL) {
81             assert(sv);
82 3           return TRUE;
83             }
84              
85             int
86 6           typetiny_tc_Bool(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
87             assert(sv);
88              
89 6 100         if (SvROK(sv)) {
90 2           return FALSE;
91             }
92              
93 4 100         if(sv_true(sv)){
94 1 50         if(SvPOKp(sv)){ /* "1" */
95 0 0         return SvCUR(sv) == 1 && SvPVX(sv)[0] == '1';
    0          
96             }
97 1 50         else if(SvIOKp(sv)){
98 1           return SvIVX(sv) == 1;
99             }
100 0 0         else if(SvNOKp(sv)){
101 0           return SvNVX(sv) == 1.0;
102             }
103             else{
104             STRLEN len;
105 0 0         char * ptr = SvPV(sv, len);
106 0 0         if(len == 1 && ptr[0] == '1'){
    0          
107 0           return TRUE;
108             } else {
109 0           return FALSE;
110             }
111             }
112             }
113             else{
114             /* any false value is a boolean */
115 3           return TRUE;
116             }
117             }
118              
119             int
120 3           typetiny_tc_Undef(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
121             assert(sv);
122 3 50         return !SvOK(sv);
    50          
    50          
123             }
124              
125             int
126 0           typetiny_tc_Defined(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
127             assert(sv);
128 0 0         return SvOK(sv);
    0          
    0          
129             }
130              
131             int
132 0           typetiny_tc_Value(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
133             assert(sv);
134 0 0         return SvOK(sv) && !SvROK(sv);
    0          
    0          
    0          
135             }
136              
137             int
138 35           typetiny_tc_Num(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
139             assert(sv);
140 35           return LooksLikeNumber(sv);
141             }
142              
143             static int
144 45           S_pv_is_integer(pTHX_ char* const pv) {
145             const char* p;
146 45           p = &pv[0];
147              
148             /* -?[0-9]+ */
149 45 100         if(*p == '-') p++;
150              
151 45 100         if (!*p) return FALSE;
152              
153 90 100         while(*p){
154 75 100         if(!isDIGIT(*p)){
155 24           return FALSE;
156             }
157 51           p++;
158             }
159 15           return TRUE;
160             }
161              
162             static int
163 8           S_nv_is_integer(pTHX_ NV const nv) {
164 8 100         if(nv == (NV)(IV)nv){
165 4           return TRUE;
166             }
167             else {
168             char buf[64]; /* Must fit sprintf/Gconvert of longest NV */
169             const char* p;
170 4           (void)Gconvert(nv, NV_DIG, 0, buf);
171 4           return S_pv_is_integer(aTHX_ buf);
172             }
173             }
174              
175             int
176 47           typetiny_tc_Int(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
177             assert(sv);
178 47 100         if (SvOK(sv) && !SvROK(sv) && !isGV(sv)) {
    50          
    50          
    100          
    50          
179 43 100         if(SvPOK(sv)){
180 18           return S_pv_is_integer(aTHX_ SvPVX(sv));
181             }
182 25 100         else if(SvIOK(sv)){
183 22           return TRUE;
184             }
185 3 50         else if(SvNOK(sv)) {
186 3           return S_nv_is_integer(aTHX_ SvNVX(sv));
187             }
188             }
189 4           return FALSE;
190             }
191              
192             int
193 29           typetiny_tc_PositiveInt(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
194             char* i;
195             STRLEN len;
196             assert(sv);
197             int j;
198 29 100         if ((!SvOK(sv)) || SvROK(sv) || isGV(sv)) {
    50          
    50          
    100          
    50          
199 3           return FALSE;
200             }
201 26 100         if(SvPOKp(sv)){
202 13 100         if (!S_pv_is_integer(aTHX_ SvPVX(sv))) {
203 8           return FALSE;
204             }
205             }
206 13 100         else if(SvIOKp(sv)){
207             /* ok */
208             }
209 5 50         else if(SvNOKp(sv)) {
210 5 100         if (!S_nv_is_integer(aTHX_ SvNVX(sv))) {
211 1           return FALSE;
212             }
213             }
214            
215 17 100         i = SvPVx(sv, len);
216 17 100         if (len == 1 && i[0] == '0') {
    100          
217 3           return FALSE;
218             }
219 14 100         else if (i[0] == '0') {
220 7 100         for (j = 0; j < len; j++) {
221 5 50         if (i[j] != '0') {
222 0           return TRUE; // "01", "001", etc
223             }
224             }
225 2           return FALSE; // "00", "000", etc
226             }
227 29 50         return ((len > 0 && i[0] != '-') ? TRUE : FALSE);
    100          
228             }
229              
230             int
231 15           typetiny_tc_PositiveOrZeroInt(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
232             char* i;
233             STRLEN len;
234             assert(sv);
235 15 100         if ((!SvOK(sv)) || SvROK(sv) || isGV(sv)) {
    50          
    50          
    100          
    50          
236 2           return FALSE;
237             }
238 13 100         if(SvPOKp(sv)){
239 10 100         if (!S_pv_is_integer(aTHX_ SvPVX(sv))) {
240 7           return FALSE;
241             }
242             }
243 3 50         else if(SvIOKp(sv)){
244             /* ok */
245             }
246 0 0         else if(SvNOKp(sv)) {
247 0 0         if (!S_nv_is_integer(aTHX_ SvNVX(sv))) {
248 0           return FALSE;
249             }
250             }
251            
252 6 100         i = SvPVx(sv, len);
253 15 50         return ((len > 0 && i[0] != '-') ? TRUE : FALSE);
    100          
254             }
255              
256             int
257 3           typetiny_tc_Str(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
258             assert(sv);
259 3 100         return SvOK(sv) && !SvROK(sv) && !isGV(sv);
    50          
    50          
    50          
    50          
260             }
261              
262             int
263 12           typetiny_tc_StringLike(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
264             HV *stash;
265             MAGIC *mg;
266             AMT *amtp;
267             CV **cvp;
268            
269             assert(sv);
270            
271 12 50         if ( SvOK(sv) && !SvROK(sv) && !isGV(sv) ) {
    0          
    0          
    100          
    50          
272 6           return TRUE;
273             }
274            
275 6 50         if ( SvAMAGIC(sv)
    100          
    50          
276 5 50         && ( stash = SvSTASH(SvRV(sv)) )
277 5 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
278 5 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
279 5 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
280 5 50         && ( cvp = amtp->table )
281 5 100         && cvp[0x0a] // AMG_STRING
282             ) {
283 3           return TRUE;
284             }
285            
286 3           return FALSE;
287             }
288              
289             int
290 0           typetiny_tc_Enum(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
291             assert(sv);
292 0 0         return SvOK(sv) && !SvROK(sv) && !isGV(sv);
    0          
    0          
    0          
    0          
293             }
294              
295             int
296 8           typetiny_tc_NonEmptyStr(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
297             assert(sv);
298 8 100         if (SvOK(sv) && !SvROK(sv) && !isGV(sv)) {
    50          
    50          
    100          
    50          
299 5           STRLEN l = sv_len(sv);
300 5           return( (l==0) ? FALSE : TRUE );
301             }
302 3           return FALSE;
303             }
304              
305             int
306 0           typetiny_tc_ClassName(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv){
307             assert(sv);
308 0           return is_class_loaded(sv);
309             }
310              
311             int
312 0           typetiny_tc_Ref(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
313             assert(sv);
314 0           return SvROK(sv);
315             }
316              
317             int
318 8           typetiny_tc_ScalarRef(pTHX_ SV* const data PERL_UNUSED_DECL, SV* sv) {
319             assert(sv);
320 8 50         if(SvROK(sv)){
321 8           sv = SvRV(sv);
322 8 50         return !SvOBJECT(sv) && (SvTYPE(sv) <= SVt_PVLV && !isGV(sv));
    50          
    50          
323             }
324 0           return FALSE;
325             }
326              
327             int
328 2           typetiny_tc_ArrayRef(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
329             assert(sv);
330 2 100         return IsArrayRef(sv);
    50          
    50          
331             }
332              
333             int
334 13           typetiny_tc_ArrayLike(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
335             HV *stash;
336             MAGIC *mg;
337             AMT *amtp;
338             CV **cvp;
339            
340             assert(sv);
341            
342 13 100         if ( IsArrayRef(sv) ) {
    100          
    100          
343 6           return TRUE;
344             }
345            
346 7 100         if ( SvAMAGIC(sv)
    100          
    50          
347 5 50         && ( stash = SvSTASH(SvRV(sv)) )
348 5 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
349 5 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
350 5 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
351 5 50         && ( cvp = amtp->table )
352 5 100         && cvp[0x02] // AMG_TO_AV
353             ) {
354 3           return TRUE;
355             }
356            
357 4           return FALSE;
358             }
359              
360             int
361 0           typetiny_tc_HashRef(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
362             assert(sv);
363 0 0         return IsHashRef(sv);
    0          
    0          
364             }
365              
366             int
367 13           typetiny_tc_HashLike(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
368             HV *stash;
369             MAGIC *mg;
370             AMT *amtp;
371             CV **cvp;
372            
373             assert(sv);
374            
375 13 100         if ( IsHashRef(sv) ) {
    100          
    100          
376 6           return TRUE;
377             }
378            
379 7 100         if ( SvAMAGIC(sv)
    100          
    50          
380 4 50         && ( stash = SvSTASH(SvRV(sv)) )
381 4 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
382 4 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
383 4 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
384 4 50         && ( cvp = amtp->table )
385 4 100         && cvp[0x03] // AMG_TO_HV
386             ) {
387 2           return TRUE;
388             }
389            
390 5           return FALSE;
391             }
392              
393             int
394 0           typetiny_tc_Map(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
395             assert(sv);
396 0 0         return IsHashRef(sv);
    0          
    0          
397             }
398              
399             int
400 0           typetiny_tc_Tuple(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
401             assert(sv);
402 0 0         return IsArrayRef(sv);
    0          
    0          
403             }
404              
405             int
406 0           typetiny_tc_CodeRef(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
407             assert(sv);
408 0 0         return IsCodeRef(sv);
    0          
    0          
409             }
410              
411             int
412 13           typetiny_tc_CodeLike(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
413             HV *stash;
414             MAGIC *mg;
415             AMT *amtp;
416             CV **cvp;
417            
418             assert(sv);
419            
420 13 100         if ( IsCodeRef(sv) ) {
    100          
    100          
421 6           return TRUE;
422             }
423            
424 7 100         if ( SvAMAGIC(sv)
    100          
    50          
425 5 50         && ( stash = SvSTASH(SvRV(sv)) )
426 5 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
427 5 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
428 5 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
429 5 50         && ( cvp = amtp->table )
430 5 100         && cvp[0x05] // AMG_TO_CV
431             ) {
432 3           return TRUE;
433             }
434            
435 4           return FALSE;
436             }
437              
438             int
439 0           typetiny_tc_RegexpRef(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
440             assert(sv);
441 0           return SvRXOK(sv);
442             }
443              
444             int
445 0           typetiny_tc_GlobRef(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
446             assert(sv);
447 0 0         return SvROK(sv) && !SvOBJECT(SvRV(sv)) && isGV(SvRV(sv));
    0          
    0          
448             }
449              
450             int
451 0           typetiny_tc_FileHandle(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
452             GV* gv;
453             assert(sv);
454              
455             /* see pp_fileno() in pp_sys.c and Scalar::Util::openhandle() */
456              
457 0 0         gv = (GV*)(SvROK(sv) ? SvRV(sv) : sv);
458 0 0         if(isGV(gv) || SvTYPE(gv) == SVt_PVIO){
    0          
459 0 0         IO* const io = isGV(gv) ? GvIO(gv) : (IO*)gv;
    0          
    0          
    0          
    0          
460              
461 0 0         if(io && ( IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar) )){
    0          
    0          
    0          
462 0           return TRUE;
463             }
464             }
465              
466 0           return is_an_instance_of("IO::Handle", sv);
467             }
468              
469             int
470 0           typetiny_tc_Object(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
471             assert(sv);
472 0 0         return SvROK(sv) && SvOBJECT(SvRV(sv));
    0          
473             }
474              
475             /* Parameterized type constraints */
476              
477             static int
478 27           typetiny_parameterized_ArrayRef(pTHX_ SV* const param, SV* const sv) {
479 27 100         if(IsArrayRef(sv)){
    50          
    100          
480 22           AV* const av = (AV*)SvRV(sv);
481 22           I32 const len = av_len(av) + 1;
482             I32 i;
483 63 100         for(i = 0; i < len; i++){
484 49           SV* const value = *av_fetch(av, i, TRUE);
485 49 100         if(!typetiny_tc_check(aTHX_ param, value)){
486 8           return FALSE;
487             }
488             }
489 14           return TRUE;
490             }
491 5           return FALSE;
492             }
493              
494             static int
495 5           typetiny_parameterized_ArrayLike(pTHX_ SV* const param, SV* const sv) {
496             HV *stash;
497             MAGIC *mg;
498             AMT *amtp;
499             CV **cvp;
500             SV *retsv;
501            
502             assert(sv);
503            
504 5 50         if( IsArrayRef(sv) ) {
    100          
    50          
505 2           return typetiny_parameterized_ArrayRef( param, sv );
506             }
507            
508 3 50         if( SvAMAGIC(sv)
    50          
    50          
509 3 50         && ( stash = SvSTASH(SvRV(sv)) )
510 3 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
511 3 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
512 3 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
513 3 50         && ( cvp = amtp->table )
514 3 100         && cvp[0x02]
515             ) {
516 2           dSP;
517 2           PUTBACK;
518 2           ENTER;
519 2           SAVETMPS;
520 2 50         EXTEND(SP, 1);
521 2 50         PUSHMARK(SP);
522 2           PUSHs(sv);
523 2           PUTBACK;
524 2           call_sv(cvp[0x02], G_SCALAR);
525 2           SPAGAIN;
526 2           retsv = POPs;
527 2           PUTBACK;
528 2 50         FREETMPS;
529 2           LEAVE;
530            
531 2           AV* const av = (AV*)SvRV(retsv);
532 2           I32 const len = av_len(av) + 1;
533             I32 i;
534 22 100         for(i = 0; i < len; i++){
535 21           SV* const value = *av_fetch(av, i, TRUE);
536 21 100         if(!typetiny_tc_check(aTHX_ param, value)){
537 1           return FALSE;
538             }
539             }
540 1           return TRUE;
541             }
542 1           return FALSE;
543             }
544              
545             static int
546 16           typetiny_parameterized_HashRef(pTHX_ SV* const param, SV* const sv) {
547 16 100         if(IsHashRef(sv)){
    50          
    100          
548 13           HV* const hv = (HV*)SvRV(sv);
549             HE* he;
550              
551 13           hv_iterinit(hv);
552 24 100         while((he = hv_iternext(hv))){
553 14           SV* const value = hv_iterval(hv, he);
554 14 100         if(!typetiny_tc_check(aTHX_ param, value)){
555 3           hv_iterinit(hv); /* reset */
556 3           return FALSE;
557             }
558             }
559 10           return TRUE;
560             }
561 3           return FALSE;
562             }
563              
564             static int
565 7           typetiny_parameterized_HashLike(pTHX_ SV* const param, SV* const sv) {
566             HV *stash;
567             MAGIC *mg;
568             AMT *amtp;
569             CV **cvp;
570             SV *retsv;
571            
572             assert(sv);
573            
574 7 50         if( IsHashRef(sv) ) {
    100          
    100          
575 3           return typetiny_parameterized_HashRef( param, sv );
576             }
577            
578 4 50         if( SvAMAGIC(sv)
    100          
    50          
579 3 50         && ( stash = SvSTASH(SvRV(sv)) )
580 3 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
581 3 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
582 3 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
583 3 50         && ( cvp = amtp->table )
584 3 100         && cvp[0x03]
585             ) {
586 2           dSP;
587 2           PUTBACK;
588 2           ENTER;
589 2           SAVETMPS;
590 2 50         EXTEND(SP, 1);
591 2 50         PUSHMARK(SP);
592 2           PUSHs(sv);
593 2           PUTBACK;
594 2           call_sv(cvp[0x03], G_SCALAR);
595 2           SPAGAIN;
596 2           retsv = POPs;
597 2           PUTBACK;
598 2 50         FREETMPS;
599 2           LEAVE;
600            
601 2           HV* const hv = (HV*)SvRV(retsv);
602             HE* he;
603              
604 2           hv_iterinit(hv);
605 3 100         while((he = hv_iternext(hv))){
606 2           SV* const value = hv_iterval(hv, he);
607 2 100         if(!typetiny_tc_check(aTHX_ param, value)){
608 1           hv_iterinit(hv); /* reset */
609 1           return FALSE;
610             }
611             }
612 1           return TRUE;
613             }
614 2           return FALSE;
615             }
616              
617             static int
618 8           typetiny_parameterized_Map(pTHX_ SV* const param, SV* const sv) {
619 8 100         if(IsHashRef(sv)){
    50          
    100          
620 6           HV* const hv = (HV*)SvRV(sv);
621             HE* he;
622              
623 6           AV* const params = (AV*)SvRV(param);
624 6           SV* const param1 = *av_fetch(params, 0, TRUE);
625 6           SV* const param2 = *av_fetch(params, 1, TRUE);
626              
627 6           hv_iterinit(hv);
628 9 100         while((he = hv_iternext(hv))){
629 6           SV* const key = hv_iterkeysv(he);
630 6           SV* const value = hv_iterval(hv, he);
631            
632 6 100         if(!typetiny_tc_check(aTHX_ param1, key)
633 5 100         || !typetiny_tc_check(aTHX_ param2, value)){
634 3           hv_iterinit(hv); /* reset */
635 3           return FALSE;
636             }
637             }
638 3           return TRUE;
639             }
640 2           return FALSE;
641             }
642              
643             static int
644 9           typetiny_parameterized_Tuple(pTHX_ SV* const param, SV* const sv) {
645             I32 i;
646 9 50         if(IsArrayRef(sv)){
    50          
    100          
647 8           AV* const av = (AV*)SvRV(sv);
648 8           I32 const len = av_len(av) + 1;
649              
650 8           AV* const params = (AV*)SvRV(param);
651 8 100         if (len - 1 != av_len(params)) {
652 3           return FALSE;
653             }
654              
655 16 100         for(i = 0; i < len; i++){
656 13           SV* const check = *av_fetch(params, i, TRUE);
657 13           SV* const value = *av_fetch(av, i, TRUE);
658 13 100         if(!typetiny_tc_check(aTHX_ check, value)){
659 2           return FALSE;
660             }
661             }
662 3           return TRUE;
663             }
664 1           return FALSE;
665             }
666              
667             static int
668 23           typetiny_parameterized_Enum(pTHX_ SV* const param, SV* const sv) {
669             AV* av;
670             I32 len;
671             I32 i;
672            
673             assert(sv);
674 23 100         if(!(SvOK(sv) && !SvROK(sv) && !isGV(sv))) {
    50          
    50          
    100          
    50          
675 6           return FALSE;
676             }
677              
678 17           av = (AV*)SvRV(param);
679 17           len = av_len(av) + 1;
680 56 100         for(i = 0; i < len; i++){
681 49           SV* const x = *av_fetch(av, i, TRUE);
682 49 100         if(sv_eq(sv, x)){
683 10           return TRUE;
684             }
685             }
686              
687 7           return FALSE;
688             }
689              
690             static int
691 0           typetiny_parameterized_Maybe(pTHX_ SV* const param, SV* const sv) {
692 0 0         if(SvOK(sv)){
    0          
    0          
693 0           return typetiny_tc_check(aTHX_ param, sv);
694             }
695 0           return TRUE;
696             }
697              
698             int
699 0           typetiny_tc_AnyOf(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv PERL_UNUSED_DECL) {
700             assert(sv);
701 0           return FALSE;
702             }
703              
704             int
705 0           typetiny_tc_AllOf(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv PERL_UNUSED_DECL) {
706             assert(sv);
707 0           return TRUE;
708             }
709              
710             static int
711 7           typetiny_parameterized_AnyOf(pTHX_ SV* const param, SV* const sv) {
712 7           AV *types = (AV*)SvRV(param);
713 7           I32 const len = AvFILLp(types) + 1;
714             I32 i;
715              
716 16 100         for(i = 0; i < len; i++){
717 12 100         if(typetiny_tc_check(aTHX_ AvARRAY(types)[i], sv)){
718 3           return TRUE;
719             }
720             }
721              
722 4           return FALSE;
723             }
724              
725             static int
726 6           typetiny_parameterized_AllOf(pTHX_ SV* const param, SV* const sv) {
727 6           AV *types = (AV*)SvRV(param);
728 6           I32 const len = AvFILLp(types) + 1;
729             I32 i;
730              
731 6           ENTER;
732 6           SAVE_DEFSV;
733 6           DEFSV_set(sv);
734              
735 11 100         for(i = 0; i < len; i++){
736 9 100         if(!typetiny_tc_check(aTHX_ AvARRAY(types)[i], sv)){
737 4           LEAVE;
738 4           return FALSE;
739             }
740             }
741              
742 2           LEAVE;
743              
744 2           return TRUE;
745             }
746              
747             /*
748             * This class_type generator is taken from Scalar::Util::Instance
749             */
750              
751              
752             #define MG_klass_stash(mg) ((HV*)(mg)->mg_obj)
753             #define MG_klass_pv(mg) ((mg)->mg_ptr)
754             #define MG_klass_len(mg) ((mg)->mg_len)
755              
756             static const char*
757 4           typetiny_canonicalize_package_name(const char* name){
758              
759             /* "::Foo" -> "Foo" */
760 4 50         if(name[0] == ':' && name[1] == ':'){
    0          
761 0           name += 2;
762             }
763              
764             /* "main::main::main::Foo" -> "Foo" */
765 4 50         while(strnEQ(name, "main::", sizeof("main::")-1)){
766 0           name += sizeof("main::")-1;
767             }
768              
769 4           return name;
770             }
771              
772             static int
773 2           typetiny_lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
774 2           AV* const linearized_isa = mro_get_linear_isa(instance_stash);
775 2           SV** svp = AvARRAY(linearized_isa);
776 2           SV** const end = svp + AvFILLp(linearized_isa) + 1;
777              
778 4 100         while(svp != end){
779             assert(SvPVX(*svp));
780 3 100         if(strEQ(klass_pv, typetiny_canonicalize_package_name(SvPVX(*svp)))){
781 1           return TRUE;
782             }
783 2           svp++;
784             }
785 1           return FALSE;
786             }
787              
788             #define find_method_pvn(a, b, c) typetiny_stash_find_method(aTHX_ a, b, c)
789             #define find_method_pvs(a, b) typetiny_stash_find_method(aTHX_ a, STR_WITH_LEN(b))
790              
791             STATIC_INLINE GV*
792 4           typetiny_stash_find_method(pTHX_ HV* const stash, const char* const name, I32 const namelen){
793 4           GV** const gvp = (GV**)hv_fetch(stash, name, namelen, FALSE);
794 4 100         if(gvp && isGV(*gvp) && GvCV(*gvp)){ /* shortcut */
    50          
    50          
795 1           return *gvp;
796             }
797              
798 3           return gv_fetchmeth(stash, name, namelen, 0);
799             }
800              
801             int
802 4           typetiny_is_an_instance_of(pTHX_ HV* const stash, SV* const instance){
803             assert(stash);
804             assert(SvTYPE(stash) == SVt_PVHV);
805              
806 4 50         if(IsObject(instance)){
    50          
807             dMY_CXT;
808 4           HV* const instance_stash = SvSTASH(SvRV(instance));
809 4           GV* const myisa = find_method_pvs(instance_stash, "isa");
810              
811             /* the instance has no own isa method */
812 4 50         if(myisa == NULL || GvCV(myisa) == GvCV(MY_CXT.universal_isa)){
    100          
813 3           return stash == instance_stash
814 3 100         || typetiny_lookup_isa(aTHX_ instance_stash, HvNAME_get(stash));
    50          
    50          
    50          
    0          
    50          
    50          
    100          
815             }
816             /* the instance has its own isa method */
817             else {
818 1           dSP;
819 1 50         CV *isacv = isGV(myisa) ? GvCV(myisa) : (CV *)myisa;
820             SV *retsv;
821             SV *package;
822             bool ret;
823              
824 1 50         package = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
    0          
    50          
    50          
825              
826 1           PUTBACK;
827              
828 1           ENTER;
829 1           SAVETMPS;
830              
831 1 50         EXTEND(SP, 2);
832 1 50         PUSHMARK(SP);
833 1           PUSHs(instance);
834 1           PUSHs(package);
835 1           PUTBACK;
836              
837 1           call_sv((SV *)isacv, G_SCALAR);
838              
839 1           SPAGAIN;
840 1           retsv = POPs;
841 1 50         ret = SvTRUE(retsv);
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
842 1           PUTBACK;
843              
844 1 50         FREETMPS;
845 1           LEAVE;
846              
847 1           return ret;
848             }
849             }
850 0           return FALSE;
851             }
852              
853             static int
854 0           typetiny_is_an_instance_of_universal(pTHX_ SV* const data, SV* const sv){
855             PERL_UNUSED_ARG(data);
856 0 0         return SvROK(sv) && SvOBJECT(SvRV(sv));
    0          
857             }
858              
859             static int
860 0           typetiny_can_methods(pTHX_ AV* const methods, SV* const instance){
861 0 0         if(IsObject(instance)){
    0          
862             dMY_CXT;
863 0           HV* const mystash = SvSTASH(SvRV(instance));
864 0           GV* const mycan = find_method_pvs(mystash, "can");
865 0 0         bool const use_builtin = (mycan == NULL || GvCV(mycan) == GvCV(MY_CXT.universal_can)) ? TRUE : FALSE;
    0          
866 0           I32 const len = AvFILLp(methods) + 1;
867             I32 i;
868 0 0         for(i = 0; i < len; i++){
869 0 0         SV* const name = TYPETINY_av_at(methods, i);
870              
871 0 0         if(use_builtin){
872 0 0         if(!find_method_pvn(mystash, SvPVX(name), SvCUR(name))){
873 0           return FALSE;
874             }
875             }
876             else{
877             bool ok;
878              
879 0           ENTER;
880 0           SAVETMPS;
881              
882 0           ok = sv_true(mcall1s(instance, "can", sv_mortalcopy(name)));
883              
884 0 0         FREETMPS;
885 0           LEAVE;
886              
887 0 0         if(!ok){
888 0           return FALSE;
889             }
890             }
891             }
892 0           return TRUE;
893             }
894 0           return FALSE;
895             }
896              
897             static MGVTBL typetiny_util_type_constraints_vtbl; /* not used, only for identity */
898              
899             static CV*
900 561           typetiny_tc_generate(pTHX_ const char* const name, check_fptr_t const fptr, SV* const param) {
901             CV* xsub;
902              
903 561           xsub = newXS(name, XS_TypeTiny_constraint_check, __FILE__);
904 561           CvXSUBANY(xsub).any_ptr = sv_magicext(
905             (SV*)xsub,
906             param, /* mg_obj: refcnt will be increased */
907             PERL_MAGIC_ext,
908             &typetiny_util_type_constraints_vtbl,
909             (char*)fptr, /* mg_ptr */
910             0 /* mg_len: 0 for static data */
911             );
912              
913 561 100         if(!name){
914 21           sv_2mortal((SV*)xsub);
915             }
916              
917 561           return xsub;
918             }
919              
920             CV*
921 1           typetiny_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name){
922             STRLEN klass_len;
923 1 50         const char* klass_pv = SvPV_const(klass, klass_len);
924             SV* param;
925             check_fptr_t fptr;
926              
927 1           klass_pv = typetiny_canonicalize_package_name(klass_pv);
928              
929 1 50         if(strNE(klass_pv, "UNIVERSAL")){
930 1           param = (SV*)gv_stashpvn(klass_pv, klass_len, GV_ADD);
931 1           fptr = (check_fptr_t)typetiny_is_an_instance_of;
932              
933             }
934             else{
935 0           param = NULL;
936 0           fptr = (check_fptr_t)typetiny_is_an_instance_of_universal;
937             }
938              
939 1           return typetiny_tc_generate(aTHX_ predicate_name, fptr, param);
940             }
941              
942             CV*
943 0           typetiny_generate_can_predicate_for(pTHX_ SV* const methods, const char* const predicate_name){
944             AV* av;
945 0           AV* const param = newAV_mortal();
946             I32 len;
947             I32 i;
948              
949 0           must_ref(methods, "an ARRAY ref for method names", SVt_PVAV);
950 0           av = (AV*)SvRV(methods);
951              
952 0           len = av_len(av) + 1;
953 0 0         for(i = 0; i < len; i++){
954 0           SV* const name = *av_fetch(av, i, TRUE);
955             STRLEN pvlen;
956 0 0         const char* const pv = SvPV_const(name, pvlen);
957              
958 0           av_push(param, newSVpvn_share(pv, pvlen, 0U));
959             }
960              
961 0           return typetiny_tc_generate(aTHX_ predicate_name, (check_fptr_t)typetiny_can_methods, (SV*)param);
962             }
963              
964             static
965 186           XSPROTO(XS_TypeTiny_constraint_check) {
966             dVAR;
967 186           dXSARGS;
968 186           MAGIC* const mg = (MAGIC*)XSANY.any_ptr;
969             SV* sv;
970              
971 186 100         if(items < 1){
972 1           sv = &PL_sv_undef;
973             }
974             else {
975 185           sv = ST(0);
976 185 50         SvGETMAGIC(sv);
    0          
977             }
978              
979 186 100         ST(0) = boolSV( CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv) );
980 186           XSRETURN(1);
981             }
982              
983             static
984 0           XSPROTO(XS_TypeTiny_TypeConstraint_fallback) {
985 0           dXSARGS;
986             PERL_UNUSED_VAR(cv);
987             PERL_UNUSED_VAR(items);
988 0           XSRETURN_EMPTY;
989             }
990              
991             static void
992 18           setup_my_cxt(pTHX_ pMY_CXT){
993 18           MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
994 18           SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
995              
996 18           MY_CXT.universal_can = gv_fetchpvs("UNIVERSAL::can", GV_ADD, SVt_PVCV);
997 18           SvREFCNT_inc_simple_void_NN(MY_CXT.universal_can);
998              
999 18           MY_CXT.tc_extra_args = NULL;
1000 18           }
1001              
1002             XSPROTO(boot_Type__Tiny__XS__Util);
1003              
1004             #define DEFINE_TC(name) typetiny_tc_generate(aTHX_ "Type::Tiny::XS::" STRINGIFY(name), CAT2(typetiny_tc_, name), NULL)
1005              
1006             #define MTC_CLASS "Type::Tiny::XS::TC"
1007              
1008             MODULE = Type::Tiny::XS PACKAGE = Type::Tiny::XS
1009              
1010             PROTOTYPES: DISABLE
1011             VERSIONCHECK: DISABLE
1012              
1013             BOOT:
1014             {
1015             MY_CXT_INIT;
1016 18 50         PUSHMARK(MARK);
1017 18           boot_Type__Tiny__XS__Util(aTHX_ cv);
1018 18           setup_my_cxt(aTHX_ aMY_CXT);
1019            
1020             /* setup built-in type constraints */
1021 18           DEFINE_TC(Any);
1022 18           DEFINE_TC(Undef);
1023 18           DEFINE_TC(Defined);
1024 18           DEFINE_TC(Bool);
1025 18           DEFINE_TC(Value);
1026 18           DEFINE_TC(Ref);
1027 18           DEFINE_TC(Str);
1028 18           DEFINE_TC(StringLike);
1029 18           DEFINE_TC(NonEmptyStr);
1030 18           DEFINE_TC(Num);
1031 18           DEFINE_TC(Int);
1032 18           DEFINE_TC(PositiveInt);
1033 18           DEFINE_TC(PositiveOrZeroInt);
1034 18           DEFINE_TC(ScalarRef);
1035 18           DEFINE_TC(ArrayRef);
1036 18           DEFINE_TC(ArrayLike);
1037 18           DEFINE_TC(HashRef);
1038 18           DEFINE_TC(HashLike);
1039 18           DEFINE_TC(Map);
1040 18           DEFINE_TC(Enum);
1041 18           DEFINE_TC(Tuple);
1042 18           DEFINE_TC(CodeRef);
1043 18           DEFINE_TC(CodeLike);
1044 18           DEFINE_TC(GlobRef);
1045 18           DEFINE_TC(FileHandle);
1046 18           DEFINE_TC(RegexpRef);
1047 18           DEFINE_TC(Object);
1048 18           DEFINE_TC(ClassName);
1049 18           DEFINE_TC(AnyOf);
1050 18           DEFINE_TC(AllOf);
1051             }
1052              
1053             #ifdef USE_ITHREADS
1054              
1055             void
1056             CLONE(...)
1057             CODE:
1058             {
1059             MY_CXT_CLONE;
1060             setup_my_cxt(aTHX_ aMY_CXT);
1061             PERL_UNUSED_VAR(items);
1062             }
1063              
1064             #endif /* !USE_ITHREADS */
1065              
1066             #define TYPETINY_TC_MAYBE 0
1067             #define TYPETINY_TC_ARRAY_REF 1
1068             #define TYPETINY_TC_HASH_REF 2
1069             #define TYPETINY_TC_MAP 3
1070             #define TYPETINY_TC_TUPLE 4
1071             #define TYPETINY_TC_ENUM 5
1072             #define TYPETINY_TC_ANYOF 6
1073             #define TYPETINY_TC_ALLOF 7
1074             #define TYPETINY_TC_ARRAYLIKE 8
1075             #define TYPETINY_TC_HASHLIKE 9
1076              
1077             CV*
1078             _parameterize_ArrayRef_for(SV* param)
1079             ALIAS:
1080             _parameterize_ArrayRef_for = TYPETINY_TC_ARRAY_REF
1081             _parameterize_HashRef_for = TYPETINY_TC_HASH_REF
1082             _parameterize_Maybe_for = TYPETINY_TC_MAYBE
1083             _parameterize_Map_for = TYPETINY_TC_MAP
1084             _parameterize_Tuple_for = TYPETINY_TC_TUPLE
1085             _parameterize_Enum_for = TYPETINY_TC_ENUM
1086             _parameterize_AnyOf_for = TYPETINY_TC_ANYOF
1087             _parameterize_AllOf_for = TYPETINY_TC_ALLOF
1088             _parameterize_ArrayLike_for = TYPETINY_TC_ARRAYLIKE
1089             _parameterize_HashLike_for = TYPETINY_TC_HASHLIKE
1090             CODE:
1091             {
1092             check_fptr_t fptr;
1093 20           SV* const tc_code = param;
1094 20 100         if(ix == TYPETINY_TC_MAP
1095 18 100         || ix == TYPETINY_TC_TUPLE
1096 16 100         || ix == TYPETINY_TC_ENUM
1097 13 100         || ix == TYPETINY_TC_ANYOF
1098 12 100         || ix == TYPETINY_TC_ALLOF) {
1099 9 50         if(!IsArrayRef(tc_code)){
    50          
    50          
1100 0           croak("Didn't supply an ARRAY reference");
1101             }
1102             }
1103             else {
1104 11 50         if(!IsCodeRef(tc_code)){
    50          
    50          
1105 0           croak("Didn't supply a CODE reference");
1106             }
1107             }
1108              
1109 20           switch(ix){
1110             case TYPETINY_TC_ARRAY_REF:
1111 7           fptr = typetiny_parameterized_ArrayRef;
1112 7           break;
1113             case TYPETINY_TC_HASH_REF:
1114 2           fptr = typetiny_parameterized_HashRef;
1115 2           break;
1116             case TYPETINY_TC_MAP:
1117 2           fptr = typetiny_parameterized_Map;
1118 2           break;
1119             case TYPETINY_TC_TUPLE:
1120 2           fptr = typetiny_parameterized_Tuple;
1121 2           break;
1122             case TYPETINY_TC_ENUM:
1123 3           fptr = typetiny_parameterized_Enum;
1124 3           break;
1125             case TYPETINY_TC_ANYOF:
1126 1           fptr = typetiny_parameterized_AnyOf;
1127 1           break;
1128             case TYPETINY_TC_ALLOF:
1129 1           fptr = typetiny_parameterized_AllOf;
1130 1           break;
1131             case TYPETINY_TC_ARRAYLIKE:
1132 1           fptr = typetiny_parameterized_ArrayLike;
1133 1           break;
1134             case TYPETINY_TC_HASHLIKE:
1135 1           fptr = typetiny_parameterized_HashLike;
1136 1           break;
1137             default: /* Maybe type */
1138 0           fptr = typetiny_parameterized_Maybe;
1139             }
1140 20           RETVAL = typetiny_tc_generate(aTHX_ NULL, fptr, tc_code);
1141             }
1142             OUTPUT:
1143             RETVAL