File Coverage

XS.xs
Criterion Covered Total %
statement 384 496 77.4
branch 380 748 50.8
condition n/a
subroutine n/a
pod n/a
total 764 1244 61.4


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 137           typetiny_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
26 137           CV* const cv = (CV*)SvRV(tc_code);
27             assert(SvTYPE(cv) == SVt_PVCV);
28              
29 137 50         if(CvXSUB(cv) == XS_TypeTiny_constraint_check){ /* built-in type constraints */
30 137           MAGIC* const mg = (MAGIC*)CvXSUBANY(cv).any_ptr;
31              
32             assert(CvXSUBANY(cv).any_ptr != NULL);
33             assert(mg->mg_ptr != NULL);
34              
35 137 50         SvGETMAGIC(sv);
    0          
36             /* call the check function directly, skipping call_sv() */
37 137           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 37           typetiny_tc_Num(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
139             assert(sv);
140 37           return LooksLikeNumber(sv);
141             }
142              
143             static int
144 47           S_pv_is_integer(pTHX_ char* const pv) {
145             const char* p;
146 47           p = &pv[0];
147              
148             /* -?[0-9]+ */
149 47 100         if(*p == '-') p++;
150              
151 47 100         if (!*p) return FALSE;
152              
153 94 100         while(*p){
154 77 100         if(!isDIGIT(*p)){
155 24           return FALSE;
156             }
157 53           p++;
158             }
159 17           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 49           typetiny_tc_Int(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
177             assert(sv);
178 49 100         if (SvOK(sv) && !SvROK(sv) && !isGV(sv)) {
    50          
    50          
    100          
    50          
179 45 100         if(SvPOK(sv)){
180 20           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 5           typetiny_tc_Str(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv) {
258             assert(sv);
259 5 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            
501             assert(sv);
502            
503 5 50         if( IsArrayRef(sv) ) {
    100          
    50          
504 2           return typetiny_parameterized_ArrayRef( aTHX_ param, sv );
505             }
506            
507 3 50         if( SvAMAGIC(sv)
    50          
    50          
508 3 50         && ( stash = SvSTASH(SvRV(sv)) )
509 3 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
510 3 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
511 3 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
512 3 50         && ( cvp = amtp->table )
513 3 100         && cvp[0x02] // AMG_TO_AV
514             ) {
515 2           SV* const retsv = amagic_call( sv, &PL_sv_undef, 0x02, AMGf_noright | AMGf_unary );
516 2           AV* const av = (AV*)SvRV(retsv);
517 2           I32 const len = av_len(av) + 1;
518             I32 i;
519 22 100         for(i = 0; i < len; i++){
520 21           SV* const value = *av_fetch(av, i, TRUE);
521 21 100         if(!typetiny_tc_check(aTHX_ param, value)){
522 1           return FALSE;
523             }
524             }
525 1           return TRUE;
526             }
527 1           return FALSE;
528             }
529              
530             static int
531 16           typetiny_parameterized_HashRef(pTHX_ SV* const param, SV* const sv) {
532 16 100         if(IsHashRef(sv)){
    50          
    100          
533 13           HV* const hv = (HV*)SvRV(sv);
534             HE* he;
535              
536 13           hv_iterinit(hv);
537 26 100         while((he = hv_iternext(hv))){
538 16           SV* const value = hv_iterval(hv, he);
539 16 100         if(!typetiny_tc_check(aTHX_ param, value)){
540 3           hv_iterinit(hv); /* reset */
541 3           return FALSE;
542             }
543             }
544 10           return TRUE;
545             }
546 3           return FALSE;
547             }
548              
549             static int
550 7           typetiny_parameterized_HashLike(pTHX_ SV* const param, SV* const sv) {
551             HV *stash;
552             MAGIC *mg;
553             AMT *amtp;
554             CV **cvp;
555            
556             assert(sv);
557            
558 7 50         if( IsHashRef(sv) ) {
    100          
    100          
559 3           return typetiny_parameterized_HashRef( aTHX_ param, sv );
560             }
561            
562 4 50         if( SvAMAGIC(sv)
    100          
    50          
563 3 50         && ( stash = SvSTASH(SvRV(sv)) )
564 3 50         && Gv_AMG(stash)
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
565 3 50         && ( mg = mg_find((const SV*)stash, PERL_MAGIC_overload_table) )
566 3 50         && AMT_AMAGIC( amtp = (AMT*)mg->mg_ptr )
567 3 50         && ( cvp = amtp->table )
568 3 100         && cvp[0x03] // AMG_TO_HV
569             ) {
570 2           SV* const retsv = amagic_call( sv, &PL_sv_undef, 0x03, AMGf_noright | AMGf_unary );
571 2           HV* const hv = (HV*)SvRV(retsv);
572             HE* he;
573              
574 2           hv_iterinit(hv);
575 3 100         while((he = hv_iternext(hv))){
576 2           SV* const value = hv_iterval(hv, he);
577 2 100         if(!typetiny_tc_check(aTHX_ param, value)){
578 1           hv_iterinit(hv); /* reset */
579 1           return FALSE;
580             }
581             }
582 1           return TRUE;
583             }
584 2           return FALSE;
585             }
586              
587             static int
588 8           typetiny_parameterized_Map(pTHX_ SV* const param, SV* const sv) {
589 8 100         if(IsHashRef(sv)){
    50          
    100          
590 6           HV* const hv = (HV*)SvRV(sv);
591             HE* he;
592              
593 6           AV* const params = (AV*)SvRV(param);
594 6           SV* const param1 = *av_fetch(params, 0, TRUE);
595 6           SV* const param2 = *av_fetch(params, 1, TRUE);
596              
597 6           hv_iterinit(hv);
598 11 100         while((he = hv_iternext(hv))){
599 8           SV* const key = hv_iterkeysv(he);
600 8           SV* const value = hv_iterval(hv, he);
601            
602 8 100         if(!typetiny_tc_check(aTHX_ param1, key)
603 7 100         || !typetiny_tc_check(aTHX_ param2, value)){
604 3           hv_iterinit(hv); /* reset */
605 3           return FALSE;
606             }
607             }
608 3           return TRUE;
609             }
610 2           return FALSE;
611             }
612              
613             static int
614 9           typetiny_parameterized_Tuple(pTHX_ SV* const param, SV* const sv) {
615             I32 i;
616 9 50         if(IsArrayRef(sv)){
    50          
    100          
617 8           AV* const av = (AV*)SvRV(sv);
618 8           I32 const len = av_len(av) + 1;
619              
620 8           AV* const params = (AV*)SvRV(param);
621 8 100         if (len - 1 != av_len(params)) {
622 3           return FALSE;
623             }
624              
625 16 100         for(i = 0; i < len; i++){
626 13           SV* const check = *av_fetch(params, i, TRUE);
627 13           SV* const value = *av_fetch(av, i, TRUE);
628 13 100         if(!typetiny_tc_check(aTHX_ check, value)){
629 2           return FALSE;
630             }
631             }
632 3           return TRUE;
633             }
634 1           return FALSE;
635             }
636              
637             static int
638 23           typetiny_parameterized_Enum(pTHX_ SV* const param, SV* const sv) {
639             AV* av;
640             I32 len;
641             I32 i;
642            
643             assert(sv);
644 23 100         if(!(SvOK(sv) && !SvROK(sv) && !isGV(sv))) {
    50          
    50          
    100          
    50          
645 6           return FALSE;
646             }
647              
648 17           av = (AV*)SvRV(param);
649 17           len = av_len(av) + 1;
650 56 100         for(i = 0; i < len; i++){
651 49           SV* const x = *av_fetch(av, i, TRUE);
652 49 100         if(sv_eq(sv, x)){
653 10           return TRUE;
654             }
655             }
656              
657 7           return FALSE;
658             }
659              
660             static int
661 0           typetiny_parameterized_Maybe(pTHX_ SV* const param, SV* const sv) {
662 0 0         if(SvOK(sv)){
    0          
    0          
663 0           return typetiny_tc_check(aTHX_ param, sv);
664             }
665 0           return TRUE;
666             }
667              
668             int
669 0           typetiny_tc_AnyOf(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv PERL_UNUSED_DECL) {
670             assert(sv);
671 0           return FALSE;
672             }
673              
674             int
675 0           typetiny_tc_AllOf(pTHX_ SV* const data PERL_UNUSED_DECL, SV* const sv PERL_UNUSED_DECL) {
676             assert(sv);
677 0           return TRUE;
678             }
679              
680             static int
681 7           typetiny_parameterized_AnyOf(pTHX_ SV* const param, SV* const sv) {
682 7           AV *types = (AV*)SvRV(param);
683 7           I32 const len = AvFILLp(types) + 1;
684             I32 i;
685              
686 16 100         for(i = 0; i < len; i++){
687 12 100         if(typetiny_tc_check(aTHX_ AvARRAY(types)[i], sv)){
688 3           return TRUE;
689             }
690             }
691              
692 4           return FALSE;
693             }
694              
695             static int
696 6           typetiny_parameterized_AllOf(pTHX_ SV* const param, SV* const sv) {
697 6           AV *types = (AV*)SvRV(param);
698 6           I32 const len = AvFILLp(types) + 1;
699             I32 i;
700              
701 6           ENTER;
702 6           SAVE_DEFSV;
703 6           DEFSV_set(sv);
704              
705 11 100         for(i = 0; i < len; i++){
706 9 100         if(!typetiny_tc_check(aTHX_ AvARRAY(types)[i], sv)){
707 4           LEAVE;
708 4           return FALSE;
709             }
710             }
711              
712 2           LEAVE;
713              
714 2           return TRUE;
715             }
716              
717             /*
718             * This class_type generator is taken from Scalar::Util::Instance
719             */
720              
721              
722             #define MG_klass_stash(mg) ((HV*)(mg)->mg_obj)
723             #define MG_klass_pv(mg) ((mg)->mg_ptr)
724             #define MG_klass_len(mg) ((mg)->mg_len)
725              
726             static const char*
727 4           typetiny_canonicalize_package_name(const char* name){
728              
729             /* "::Foo" -> "Foo" */
730 4 50         if(name[0] == ':' && name[1] == ':'){
    0          
731 0           name += 2;
732             }
733              
734             /* "main::main::main::Foo" -> "Foo" */
735 4 50         while(strnEQ(name, "main::", sizeof("main::")-1)){
736 0           name += sizeof("main::")-1;
737             }
738              
739 4           return name;
740             }
741              
742             static int
743 2           typetiny_lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
744 2           AV* const linearized_isa = mro_get_linear_isa(instance_stash);
745 2           SV** svp = AvARRAY(linearized_isa);
746 2           SV** const end = svp + AvFILLp(linearized_isa) + 1;
747              
748 4 100         while(svp != end){
749             assert(SvPVX(*svp));
750 3 100         if(strEQ(klass_pv, typetiny_canonicalize_package_name(SvPVX(*svp)))){
751 1           return TRUE;
752             }
753 2           svp++;
754             }
755 1           return FALSE;
756             }
757              
758             #define find_method_pvn(a, b, c) typetiny_stash_find_method(aTHX_ a, b, c)
759             #define find_method_pvs(a, b) typetiny_stash_find_method(aTHX_ a, STR_WITH_LEN(b))
760              
761             STATIC_INLINE GV*
762 4           typetiny_stash_find_method(pTHX_ HV* const stash, const char* const name, I32 const namelen){
763 4           GV** const gvp = (GV**)hv_fetch(stash, name, namelen, FALSE);
764 4 100         if(gvp && isGV(*gvp) && GvCV(*gvp)){ /* shortcut */
    50          
    50          
765 1           return *gvp;
766             }
767              
768 3           return gv_fetchmeth(stash, name, namelen, 0);
769             }
770              
771             int
772 4           typetiny_is_an_instance_of(pTHX_ HV* const stash, SV* const instance){
773             assert(stash);
774             assert(SvTYPE(stash) == SVt_PVHV);
775              
776 4 50         if(IsObject(instance)){
    50          
777             dMY_CXT;
778 4           HV* const instance_stash = SvSTASH(SvRV(instance));
779 4           GV* const myisa = find_method_pvs(instance_stash, "isa");
780              
781             /* the instance has no own isa method */
782 4 50         if(myisa == NULL || GvCV(myisa) == GvCV(MY_CXT.universal_isa)){
    100          
783 3           return stash == instance_stash
784 3 100         || typetiny_lookup_isa(aTHX_ instance_stash, HvNAME_get(stash));
    50          
    50          
    50          
    0          
    50          
    50          
    100          
785             }
786             /* the instance has its own isa method */
787             else {
788 1           dSP;
789 1 50         CV *isacv = isGV(myisa) ? GvCV(myisa) : (CV *)myisa;
790             SV *retsv;
791             SV *package;
792             bool ret;
793              
794 1 50         package = newSVpvn_share(HvNAME_get(stash), HvNAMELEN_get(stash), 0U);
    50          
    50          
    0          
    50          
    50          
    50          
    50          
    50          
    0          
    50          
    50          
795              
796 1           PUTBACK;
797              
798 1           ENTER;
799 1           SAVETMPS;
800              
801 1 50         EXTEND(SP, 2);
802 1 50         PUSHMARK(SP);
803 1           PUSHs(instance);
804 1           PUSHs(package);
805 1           PUTBACK;
806              
807 1           call_sv((SV *)isacv, G_SCALAR);
808              
809 1           SPAGAIN;
810 1           retsv = POPs;
811 1 50         ret = SvTRUE(retsv);
    50          
    0          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
812 1           PUTBACK;
813              
814 1 50         FREETMPS;
815 1           LEAVE;
816              
817 1           return ret;
818             }
819             }
820 0           return FALSE;
821             }
822              
823             static int
824 0           typetiny_is_an_instance_of_universal(pTHX_ SV* const data, SV* const sv){
825             PERL_UNUSED_ARG(data);
826 0 0         return SvROK(sv) && SvOBJECT(SvRV(sv));
    0          
827             }
828              
829             static int
830 0           typetiny_can_methods(pTHX_ AV* const methods, SV* const instance){
831 0 0         if(IsObject(instance)){
    0          
832             dMY_CXT;
833 0           HV* const mystash = SvSTASH(SvRV(instance));
834 0           GV* const mycan = find_method_pvs(mystash, "can");
835 0 0         bool const use_builtin = (mycan == NULL || GvCV(mycan) == GvCV(MY_CXT.universal_can)) ? TRUE : FALSE;
    0          
836 0           I32 const len = AvFILLp(methods) + 1;
837             I32 i;
838 0 0         for(i = 0; i < len; i++){
839 0 0         SV* const name = TYPETINY_av_at(methods, i);
840              
841 0 0         if(use_builtin){
842 0 0         if(!find_method_pvn(mystash, SvPVX(name), SvCUR(name))){
843 0           return FALSE;
844             }
845             }
846             else{
847             bool ok;
848              
849 0           ENTER;
850 0           SAVETMPS;
851              
852 0           ok = sv_true(mcall1s(instance, "can", sv_mortalcopy(name)));
853              
854 0 0         FREETMPS;
855 0           LEAVE;
856              
857 0 0         if(!ok){
858 0           return FALSE;
859             }
860             }
861             }
862 0           return TRUE;
863             }
864 0           return FALSE;
865             }
866              
867             static MGVTBL typetiny_util_type_constraints_vtbl; /* not used, only for identity */
868              
869             static CV*
870 561           typetiny_tc_generate(pTHX_ const char* const name, check_fptr_t const fptr, SV* const param) {
871             CV* xsub;
872              
873 561           xsub = newXS(name, XS_TypeTiny_constraint_check, __FILE__);
874 561           CvXSUBANY(xsub).any_ptr = sv_magicext(
875             (SV*)xsub,
876             param, /* mg_obj: refcnt will be increased */
877             PERL_MAGIC_ext,
878             &typetiny_util_type_constraints_vtbl,
879             (char*)fptr, /* mg_ptr */
880             0 /* mg_len: 0 for static data */
881             );
882              
883 561 100         if(!name){
884 21           sv_2mortal((SV*)xsub);
885             }
886              
887 561           return xsub;
888             }
889              
890             CV*
891 1           typetiny_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name){
892             STRLEN klass_len;
893 1 50         const char* klass_pv = SvPV_const(klass, klass_len);
894             SV* param;
895             check_fptr_t fptr;
896              
897 1           klass_pv = typetiny_canonicalize_package_name(klass_pv);
898              
899 1 50         if(strNE(klass_pv, "UNIVERSAL")){
900 1           param = (SV*)gv_stashpvn(klass_pv, klass_len, GV_ADD);
901 1           fptr = (check_fptr_t)typetiny_is_an_instance_of;
902              
903             }
904             else{
905 0           param = NULL;
906 0           fptr = (check_fptr_t)typetiny_is_an_instance_of_universal;
907             }
908              
909 1           return typetiny_tc_generate(aTHX_ predicate_name, fptr, param);
910             }
911              
912             CV*
913 0           typetiny_generate_can_predicate_for(pTHX_ SV* const methods, const char* const predicate_name){
914             AV* av;
915 0           AV* const param = newAV_mortal();
916             I32 len;
917             I32 i;
918              
919 0           must_ref(methods, "an ARRAY ref for method names", SVt_PVAV);
920 0           av = (AV*)SvRV(methods);
921              
922 0           len = av_len(av) + 1;
923 0 0         for(i = 0; i < len; i++){
924 0           SV* const name = *av_fetch(av, i, TRUE);
925             STRLEN pvlen;
926 0 0         const char* const pv = SvPV_const(name, pvlen);
927              
928 0           av_push(param, newSVpvn_share(pv, pvlen, 0U));
929             }
930              
931 0           return typetiny_tc_generate(aTHX_ predicate_name, (check_fptr_t)typetiny_can_methods, (SV*)param);
932             }
933              
934             static
935 186           XSPROTO(XS_TypeTiny_constraint_check) {
936             dVAR;
937 186           dXSARGS;
938 186           MAGIC* const mg = (MAGIC*)XSANY.any_ptr;
939             SV* sv;
940              
941 186 100         if(items < 1){
942 1           sv = &PL_sv_undef;
943             }
944             else {
945 185           sv = ST(0);
946 185 50         SvGETMAGIC(sv);
    0          
947             }
948              
949 186 100         ST(0) = boolSV( CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv) );
950 186           XSRETURN(1);
951             }
952              
953             static
954 0           XSPROTO(XS_TypeTiny_TypeConstraint_fallback) {
955 0           dXSARGS;
956             PERL_UNUSED_VAR(cv);
957             PERL_UNUSED_VAR(items);
958 0           XSRETURN_EMPTY;
959             }
960              
961             static void
962 18           setup_my_cxt(pTHX_ pMY_CXT){
963 18           MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
964 18           SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
965              
966 18           MY_CXT.universal_can = gv_fetchpvs("UNIVERSAL::can", GV_ADD, SVt_PVCV);
967 18           SvREFCNT_inc_simple_void_NN(MY_CXT.universal_can);
968              
969 18           MY_CXT.tc_extra_args = NULL;
970 18           }
971              
972             XSPROTO(boot_Type__Tiny__XS__Util);
973              
974             #define DEFINE_TC(name) typetiny_tc_generate(aTHX_ "Type::Tiny::XS::" STRINGIFY(name), CAT2(typetiny_tc_, name), NULL)
975              
976             #define MTC_CLASS "Type::Tiny::XS::TC"
977              
978             MODULE = Type::Tiny::XS PACKAGE = Type::Tiny::XS
979              
980             PROTOTYPES: DISABLE
981             VERSIONCHECK: DISABLE
982              
983             BOOT:
984             {
985             MY_CXT_INIT;
986 18 50         PUSHMARK(MARK);
987 18           boot_Type__Tiny__XS__Util(aTHX_ cv);
988 18           setup_my_cxt(aTHX_ aMY_CXT);
989            
990             /* setup built-in type constraints */
991 18           DEFINE_TC(Any);
992 18           DEFINE_TC(Undef);
993 18           DEFINE_TC(Defined);
994 18           DEFINE_TC(Bool);
995 18           DEFINE_TC(Value);
996 18           DEFINE_TC(Ref);
997 18           DEFINE_TC(Str);
998 18           DEFINE_TC(StringLike);
999 18           DEFINE_TC(NonEmptyStr);
1000 18           DEFINE_TC(Num);
1001 18           DEFINE_TC(Int);
1002 18           DEFINE_TC(PositiveInt);
1003 18           DEFINE_TC(PositiveOrZeroInt);
1004 18           DEFINE_TC(ScalarRef);
1005 18           DEFINE_TC(ArrayRef);
1006 18           DEFINE_TC(ArrayLike);
1007 18           DEFINE_TC(HashRef);
1008 18           DEFINE_TC(HashLike);
1009 18           DEFINE_TC(Map);
1010 18           DEFINE_TC(Enum);
1011 18           DEFINE_TC(Tuple);
1012 18           DEFINE_TC(CodeRef);
1013 18           DEFINE_TC(CodeLike);
1014 18           DEFINE_TC(GlobRef);
1015 18           DEFINE_TC(FileHandle);
1016 18           DEFINE_TC(RegexpRef);
1017 18           DEFINE_TC(Object);
1018 18           DEFINE_TC(ClassName);
1019 18           DEFINE_TC(AnyOf);
1020 18           DEFINE_TC(AllOf);
1021             }
1022              
1023             #ifdef USE_ITHREADS
1024              
1025             void
1026             CLONE(...)
1027             CODE:
1028             {
1029             MY_CXT_CLONE;
1030             setup_my_cxt(aTHX_ aMY_CXT);
1031             PERL_UNUSED_VAR(items);
1032             }
1033              
1034             #endif /* !USE_ITHREADS */
1035              
1036             #define TYPETINY_TC_MAYBE 0
1037             #define TYPETINY_TC_ARRAY_REF 1
1038             #define TYPETINY_TC_HASH_REF 2
1039             #define TYPETINY_TC_MAP 3
1040             #define TYPETINY_TC_TUPLE 4
1041             #define TYPETINY_TC_ENUM 5
1042             #define TYPETINY_TC_ANYOF 6
1043             #define TYPETINY_TC_ALLOF 7
1044             #define TYPETINY_TC_ARRAYLIKE 8
1045             #define TYPETINY_TC_HASHLIKE 9
1046              
1047             CV*
1048             _parameterize_ArrayRef_for(SV* param)
1049             ALIAS:
1050             _parameterize_ArrayRef_for = TYPETINY_TC_ARRAY_REF
1051             _parameterize_HashRef_for = TYPETINY_TC_HASH_REF
1052             _parameterize_Maybe_for = TYPETINY_TC_MAYBE
1053             _parameterize_Map_for = TYPETINY_TC_MAP
1054             _parameterize_Tuple_for = TYPETINY_TC_TUPLE
1055             _parameterize_Enum_for = TYPETINY_TC_ENUM
1056             _parameterize_AnyOf_for = TYPETINY_TC_ANYOF
1057             _parameterize_AllOf_for = TYPETINY_TC_ALLOF
1058             _parameterize_ArrayLike_for = TYPETINY_TC_ARRAYLIKE
1059             _parameterize_HashLike_for = TYPETINY_TC_HASHLIKE
1060             CODE:
1061             {
1062             check_fptr_t fptr;
1063 20           SV* const tc_code = param;
1064 20 100         if(ix == TYPETINY_TC_MAP
1065 18 100         || ix == TYPETINY_TC_TUPLE
1066 16 100         || ix == TYPETINY_TC_ENUM
1067 13 100         || ix == TYPETINY_TC_ANYOF
1068 12 100         || ix == TYPETINY_TC_ALLOF) {
1069 9 50         if(!IsArrayRef(tc_code)){
    50          
    50          
1070 0           croak("Didn't supply an ARRAY reference");
1071             }
1072             }
1073             else {
1074 11 50         if(!IsCodeRef(tc_code)){
    50          
    50          
1075 0           croak("Didn't supply a CODE reference");
1076             }
1077             }
1078              
1079 20           switch(ix){
1080             case TYPETINY_TC_ARRAY_REF:
1081 7           fptr = typetiny_parameterized_ArrayRef;
1082 7           break;
1083             case TYPETINY_TC_HASH_REF:
1084 2           fptr = typetiny_parameterized_HashRef;
1085 2           break;
1086             case TYPETINY_TC_MAP:
1087 2           fptr = typetiny_parameterized_Map;
1088 2           break;
1089             case TYPETINY_TC_TUPLE:
1090 2           fptr = typetiny_parameterized_Tuple;
1091 2           break;
1092             case TYPETINY_TC_ENUM:
1093 3           fptr = typetiny_parameterized_Enum;
1094 3           break;
1095             case TYPETINY_TC_ANYOF:
1096 1           fptr = typetiny_parameterized_AnyOf;
1097 1           break;
1098             case TYPETINY_TC_ALLOF:
1099 1           fptr = typetiny_parameterized_AllOf;
1100 1           break;
1101             case TYPETINY_TC_ARRAYLIKE:
1102 1           fptr = typetiny_parameterized_ArrayLike;
1103 1           break;
1104             case TYPETINY_TC_HASHLIKE:
1105 1           fptr = typetiny_parameterized_HashLike;
1106 1           break;
1107             default: /* Maybe type */
1108 0           fptr = typetiny_parameterized_Maybe;
1109             }
1110 20           RETVAL = typetiny_tc_generate(aTHX_ NULL, fptr, tc_code);
1111             }
1112             OUTPUT:
1113             RETVAL