xs-src/MouseTypeConstraints.xs

   1 /*
   2  *   full definition of built-in type constraints (ware in Moose::Util::TypeConstraints::OptimizedConstraints)
   3  */
   4
   5 #include "mouse.h"
   6
   7 #if PERL_BCDVERSION >= 0x5008005
   8 #define LooksLikeNumber(sv) looks_like_number(sv)
   9 #else
  10 #define LooksLikeNumber(sv) ( SvPOKp(sv) ? looks_like_number(sv) : SvNIOKp(sv) )
  11 #endif
  12
  13 #ifndef SvRXOK
  14 #define SvRXOK(sv) (SvROK(sv) && SvMAGICAL(SvRV(sv)) && mg_find(SvRV(sv), PERL_MAGIC_qr))
  15 #endif
  16
  17 typedef int (*check_fptr_t)(pTHX_ SV* const data, SV* const sv);
  18
  19 int
  20 mouse_tc_check(pTHX_ SV* const tc_code, SV* const sv) {
  21     CV* const cv = (CV*)SvRV(tc_code);
  22     assert(SvTYPE(cv) == SVt_PVCV);
  23
  24     if(CvXSUB(cv) == XS_Mouse__Util__TypeConstraints_Item){ /* built-in */
  25         assert(CvXSUBANY(cv).any_iv > 0);
  26
  27         return mouse_builtin_tc_check(aTHX_ CvXSUBANY(cv).any_iv, sv);
  28     }
  29     else if(CvXSUB(cv) == XS_Mouse_parameterized_check){ /* built-in, parameterizad */
  30         MAGIC* const mg = (MAGIC*)CvXSUBANY(cv).any_ptr;
  31
  32         assert(CvXSUBANY(cv).any_ptr != NULL);
  33
  34         /* call the check function directly, skipping call_sv() */
  35         return CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, sv);
  36     }
  37     else { /* custom */
  38         int ok;
  39         dSP;
  40
  41         ENTER;
  42         SAVETMPS;
  43
  44         PUSHMARK(SP);
  45         XPUSHs(sv);
  46         PUTBACK;
  47
  48         call_sv(tc_code, G_SCALAR);
  49
  50         SPAGAIN;
  51         ok = SvTRUEx(POPs);
  52         PUTBACK;
  53
  54         FREETMPS;
  55         LEAVE;
  56
  57         return ok;
  58     }
  59 }
  60
  61 int
  62 mouse_builtin_tc_check(pTHX_ mouse_tc const tc, SV* const sv) {
  63     switch(tc){
  64     case MOUSE_TC_ANY:        return mouse_tc_Any(aTHX_ sv);
  65     case MOUSE_TC_ITEM:       return mouse_tc_Any(aTHX_ sv);
  66     case MOUSE_TC_UNDEF:      return mouse_tc_Undef(aTHX_ sv);
  67     case MOUSE_TC_DEFINED:    return mouse_tc_Defined(aTHX_ sv);
  68     case MOUSE_TC_BOOL:       return mouse_tc_Bool(aTHX_ sv);
  69     case MOUSE_TC_VALUE:      return mouse_tc_Value(aTHX_ sv);
  70     case MOUSE_TC_REF:        return mouse_tc_Ref(aTHX_ sv);
  71     case MOUSE_TC_STR:        return mouse_tc_Str(aTHX_ sv);
  72     case MOUSE_TC_NUM:        return mouse_tc_Num(aTHX_ sv);
  73     case MOUSE_TC_INT:        return mouse_tc_Int(aTHX_ sv);
  74     case MOUSE_TC_SCALAR_REF: return mouse_tc_ScalarRef(aTHX_ sv);
  75     case MOUSE_TC_ARRAY_REF:  return mouse_tc_ArrayRef(aTHX_ sv);
  76     case MOUSE_TC_HASH_REF:   return mouse_tc_HashRef(aTHX_ sv);
  77     case MOUSE_TC_CODE_REF:   return mouse_tc_CodeRef(aTHX_ sv);
  78     case MOUSE_TC_GLOB_REF:   return mouse_tc_GlobRef(aTHX_ sv);
  79     case MOUSE_TC_FILEHANDLE: return mouse_tc_FileHandle(aTHX_ sv);
  80     case MOUSE_TC_REGEXP_REF: return mouse_tc_RegexpRef(aTHX_ sv);
  81     case MOUSE_TC_OBJECT:     return mouse_tc_Object(aTHX_ sv);
  82     case MOUSE_TC_CLASS_NAME: return mouse_tc_ClassName(aTHX_ sv);
  83     case MOUSE_TC_ROLE_NAME:  return mouse_tc_RoleName(aTHX_ sv);
  84     default:
  85         NOOP;
  86     }
  87
  88     croak("Mouse-panic: unrecognized type constraint id: %d", (int)tc);
  89     return FALSE; /* not reached */
  90 }
  91
  92
  93 /*
  94     The following type check functions return an integer, not a bool, to keep them simple,
  95     so if you assign these return value to bool variable, you must use "expr ? TRUE : FALSE".
  96 */
  97
  98 int
  99 mouse_tc_Any(pTHX_ SV* const sv PERL_UNUSED_DECL) {
 100     assert(sv);
 101     return TRUE;
 102 }
 103
 104 int
 105 mouse_tc_Bool(pTHX_ SV* const sv) {
 106     assert(sv);
 107
 108     if(SvTRUE(sv)){
 109         if(SvIOKp(sv)){
 110             return SvIVX(sv) == 1;
 111         }
 112         else if(SvNOKp(sv)){
 113             return SvNVX(sv) == 1.0;
 114         }
 115         else if(SvPOKp(sv)){ /* "1" */
 116             return SvCUR(sv) == 1 && SvPVX(sv)[0] == '1';
 117         }
 118         else{
 119             return FALSE;
 120         }
 121     }
 122     else{
 123         /* false must be boolean */
 124         return TRUE;
 125     }
 126 }
 127
 128 int
 129 mouse_tc_Undef(pTHX_ SV* const sv) {
 130     assert(sv);
 131     return !SvOK(sv);
 132 }
 133
 134 int
 135 mouse_tc_Defined(pTHX_ SV* const sv) {
 136     assert(sv);
 137     return SvOK(sv);
 138 }
 139
 140 int
 141 mouse_tc_Value(pTHX_ SV* const sv) {
 142     assert(sv);
 143     return SvOK(sv) && !SvROK(sv);
 144 }
 145
 146 int
 147 mouse_tc_Num(pTHX_ SV* const sv) {
 148     assert(sv);
 149     return LooksLikeNumber(sv);
 150 }
 151
 152 int
 153 mouse_tc_Int(pTHX_ SV* const sv) {
 154     assert(sv);
 155     if(SvIOKp(sv)){
 156         return TRUE;
 157     }
 158     else if(SvNOKp(sv)){
 159         NV const nv = SvNVX(sv);
 160         return nv > 0 ? (nv == (NV)(UV)nv) : (nv == (NV)(IV)nv);
 161     }
 162     else if(SvPOKp(sv)){
 163         int const num_type = grok_number(SvPVX(sv), SvCUR(sv), NULL);
 164         if(num_type){
 165             return !(num_type & IS_NUMBER_NOT_INT);
 166         }
 167     }
 168     return FALSE;
 169 }
 170
 171 int
 172 mouse_tc_Str(pTHX_ SV* const sv) {
 173     assert(sv);
 174     return SvOK(sv) && !SvROK(sv) && !isGV(sv);
 175 }
 176
 177 int
 178 mouse_tc_ClassName(pTHX_ SV* const sv){
 179     assert(sv);
 180     return is_class_loaded(sv);
 181 }
 182
 183 int
 184 mouse_tc_RoleName(pTHX_ SV* const sv) {
 185     assert(sv);
 186     if(is_class_loaded(sv)){
 187         int ok;
 188         SV* meta;
 189         dSP;
 190
 191         ENTER;
 192         SAVETMPS;
 193
 194         PUSHMARK(SP);
 195         XPUSHs(sv);
 196         PUTBACK;
 197         call_pv("Mouse::Util::get_metaclass_by_name", G_SCALAR);
 198         SPAGAIN;
 199         meta = POPs;
 200         PUTBACK;
 201
 202         ok =  is_an_instance_of("Mouse::Meta::Role", meta);
 203
 204         FREETMPS;
 205         LEAVE;
 206
 207         return ok;
 208     }
 209     return FALSE;
 210 }
 211
 212 int
 213 mouse_tc_Ref(pTHX_ SV* const sv) {
 214     assert(sv);
 215     return SvROK(sv);
 216 }
 217
 218 int
 219 mouse_tc_ScalarRef(pTHX_ SV* const sv) {
 220     assert(sv);
 221     return SvROK(sv) && !SvOBJECT(SvRV(sv)) && (SvTYPE(SvRV(sv)) <= SVt_PVLV && !isGV(SvRV(sv)));
 222 }
 223
 224 int
 225 mouse_tc_ArrayRef(pTHX_ SV* const sv) {
 226     assert(sv);
 227     return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV;
 228 }
 229
 230 int
 231 mouse_tc_HashRef(pTHX_ SV* const sv) {
 232     assert(sv);
 233     return SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVHV;
 234 }
 235
 236 int
 237 mouse_tc_CodeRef(pTHX_ SV* const sv) {
 238     assert(sv);
 239     return SvROK(sv)  && !SvOBJECT(SvRV(sv))&& SvTYPE(SvRV(sv)) == SVt_PVCV;
 240 }
 241
 242 int
 243 mouse_tc_RegexpRef(pTHX_ SV* const sv) {
 244     assert(sv);
 245     return SvRXOK(sv);
 246 }
 247
 248 int
 249 mouse_tc_GlobRef(pTHX_ SV* const sv) {
 250     assert(sv);
 251     return SvROK(sv) && !SvOBJECT(SvRV(sv)) && isGV(SvRV(sv));
 252 }
 253
 254 int
 255 mouse_tc_FileHandle(pTHX_ SV* const sv) {
 256     GV* gv;
 257     assert(sv);
 258
 259     /* see pp_fileno() in pp_sys.c and Scalar::Util::openhandle() */
 260
 261     gv = (GV*)(SvROK(sv) ? SvRV(sv) : sv);
 262     if(isGV(gv) || SvTYPE(gv) == SVt_PVIO){
 263         IO* const io = isGV(gv) ? GvIO(gv) : (IO*)gv;
 264
 265         if(io && ( IoIFP(io) || SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar) )){
 266             return TRUE;
 267         }
 268     }
 269
 270     return is_an_instance_of("IO::Handle", sv);
 271 }
 272
 273 int
 274 mouse_tc_Object(pTHX_ SV* const sv) {
 275     assert(sv);
 276     return SvROK(sv) && SvOBJECT(SvRV(sv)) && !SvRXOK(sv);
 277 }
 278
 279 /* Parameterized type constraints */
 280
 281 int
 282 mouse_parameterized_ArrayRef(pTHX_ SV* const param, SV* const sv) {
 283     if(mouse_tc_ArrayRef(aTHX_ sv)){
 284         AV* const av  = (AV*)SvRV(sv);
 285         I32 const len = av_len(av) + 1;
 286         I32 i;
 287         for(i = 0; i < len; i++){
 288             SV* const value = *av_fetch(av, i, TRUE);
 289             SvGETMAGIC(value);
 290             if(!mouse_tc_check(aTHX_ param, value)){
 291                 return FALSE;
 292             }
 293         }
 294         return TRUE;
 295     }
 296     return FALSE;
 297 }
 298
 299 int
 300 mouse_parameterized_HashRef(pTHX_ SV* const param, SV* const sv) {
 301     if(mouse_tc_HashRef(aTHX_ sv)){
 302         HV* const hv  = (HV*)SvRV(sv);
 303         HE* he;
 304
 305         hv_iterinit(hv);
 306         while((he = hv_iternext(hv))){
 307             SV* const value = hv_iterval(hv, he);
 308             SvGETMAGIC(value);
 309             if(!mouse_tc_check(aTHX_ param, value)){
 310                 return FALSE;
 311             }
 312         }
 313         return TRUE;
 314     }
 315     return FALSE;
 316 }
 317
 318 int
 319 mouse_parameterized_Maybe(pTHX_ SV* const param, SV* const sv) {
 320     if(SvOK(sv)){
 321         return mouse_tc_check(aTHX_ param, sv);
 322     }
 323     return TRUE;
 324 }
 325
 326 /*
 327  *  This class_type generator is taken from Scalar::Util::Instance
 328  */
 329
 330 #define MY_CXT_KEY "Mouse::Util::TypeConstraints::_guts" XS_VERSION
 331 typedef struct sui_cxt{
 332     GV* universal_isa;
 333 } my_cxt_t;
 334 START_MY_CXT
 335
 336 #define MG_klass_stash(mg) ((HV*)(mg)->mg_obj)
 337 #define MG_klass_pv(mg)    ((mg)->mg_ptr)
 338 #define MG_klass_len(mg)   ((mg)->mg_len)
 339
 340 static const char*
 341 mouse_canonicalize_package_name(const char* name){
 342
 343     /* "::Foo" -> "Foo" */
 344     if(name[0] == ':' && name[1] == ':'){
 345         name += 2;
 346     }
 347
 348     /* "main::main::main::Foo" -> "Foo" */
 349     while(strnEQ(name, "main::", sizeof("main::")-1)){
 350         name += sizeof("main::")-1;
 351     }
 352
 353     return name;
 354 }
 355
 356 static int
 357 mouse_lookup_isa(pTHX_ HV* const instance_stash, const char* const klass_pv){
 358     AV*  const linearized_isa = mro_get_linear_isa(instance_stash);
 359     SV**       svp            = AvARRAY(linearized_isa);
 360     SV** const end            = svp + AvFILLp(linearized_isa) + 1;
 361
 362     while(svp != end){
 363         assert(SvPVX(*svp));
 364         if(strEQ(klass_pv, mouse_canonicalize_package_name(SvPVX(*svp)))){
 365             return TRUE;
 366         }
 367         svp++;
 368     }
 369     return FALSE;
 370 }
 371
 372 int
 373 mouse_is_an_instance_of(pTHX_ HV* const stash, SV* const instance){
 374     assert(stash);
 375     assert(SvTYPE(stash) == SVt_PVHV);
 376
 377     if(IsObject(instance)){
 378         dMY_CXT;
 379         HV* const instance_stash = SvSTASH(SvRV(instance));
 380         GV* const instance_isa   = gv_fetchmeth_autoload(instance_stash, "isa", sizeof("isa")-1, 0);
 381
 382         /* the instance has no own isa method */
 383         if(instance_isa == NULL || GvCV(instance_isa) == GvCV(MY_CXT.universal_isa)){
 384             return stash == instance_stash
 385                 || mouse_lookup_isa(aTHX_ instance_stash, HvNAME_get(stash));
 386         }
 387         /* the instance has its own isa method */
 388         else {
 389             int retval;
 390             dSP;
 391
 392             ENTER;
 393             SAVETMPS;
 394
 395             PUSHMARK(SP);
 396             EXTEND(SP, 2);
 397             PUSHs(instance);
 398             mPUSHp(HvNAME_get(stash), HvNAMELEN_get(stash));
 399             PUTBACK;
 400
 401             call_sv((SV*)instance_isa, G_SCALAR);
 402
 403             SPAGAIN;
 404
 405             retval = SvTRUEx(POPs);
 406
 407             PUTBACK;
 408
 409             FREETMPS;
 410             LEAVE;
 411
 412             return retval;
 413         }
 414     }
 415     return FALSE;
 416 }
 417
 418 static int
 419 mouse_is_an_instance_of_universal(pTHX_ SV* const data, SV* const sv){
 420     PERL_UNUSED_ARG(data);
 421     return SvROK(sv) && SvOBJECT(SvRV(sv));
 422 }
 423
 424 static MGVTBL mouse_util_type_constraints_vtbl; /* not used, only for identity */
 425
 426 static CV*
 427 mouse_tc_parameterize(pTHX_ const char* const name, check_fptr_t const fptr, SV* const param) {
 428     CV* xsub;
 429
 430     xsub = newXS(name, XS_Mouse_parameterized_check, __FILE__);
 431     CvXSUBANY(xsub).any_ptr = sv_magicext(
 432         (SV*)xsub,
 433         param,       /* mg_obj: refcnt will be increased */
 434         PERL_MAGIC_ext,
 435         &mouse_util_type_constraints_vtbl,
 436         (void*)fptr, /* mg_ptr */
 437         0            /* mg_len: 0 for static data */
 438     );
 439
 440     if(!name){
 441         sv_2mortal((SV*)xsub);
 442     }
 443
 444     return xsub;
 445 }
 446
 447 CV*
 448 mouse_generate_isa_predicate_for(pTHX_ SV* const klass, const char* const predicate_name){
 449     STRLEN klass_len;
 450     const char* klass_pv = SvPV_const(klass, klass_len);
 451     SV*   param;
 452     void* fptr;
 453
 454     klass_pv = mouse_canonicalize_package_name(klass_pv);
 455
 456     if(strNE(klass_pv, "UNIVERSAL")){
 457         param = (SV*)gv_stashpvn(klass_pv, klass_len, GV_ADD);
 458         fptr = (void*)mouse_is_an_instance_of;
 459
 460     }
 461     else{
 462         param = NULL;
 463         fptr = (void*)mouse_is_an_instance_of_universal;
 464     }
 465
 466     return mouse_tc_parameterize(aTHX_ predicate_name, fptr, param);
 467 }
 468
 469 XS(XS_Mouse_parameterized_check) {
 470     dVAR;
 471     dXSARGS;
 472     MAGIC* const mg = (MAGIC*)XSANY.any_ptr;
 473
 474     if(items < 1){
 475         croak("Too few arguments for parameterized check functions");
 476     }
 477
 478     SvGETMAGIC( ST(0) );
 479     ST(0) = boolSV( CALL_FPTR((check_fptr_t)mg->mg_ptr)(aTHX_ mg->mg_obj, ST(0)) );
 480     XSRETURN(1);
 481 }
 482
 483 static void
 484 setup_my_cxt(pTHX_ pMY_CXT){
 485     MY_CXT.universal_isa = gv_fetchpvs("UNIVERSAL::isa", GV_ADD, SVt_PVCV);
 486     SvREFCNT_inc_simple_void_NN(MY_CXT.universal_isa);
 487 }
 488
 489 MODULE = Mouse::Util::TypeConstraints    PACKAGE = Mouse::Util::TypeConstraints
 490
 491 PROTOTYPES:   DISABLE
 492 VERSIONCHECK: DISABLE
 493
 494 BOOT:
 495 {
 496     MY_CXT_INIT;
 497     setup_my_cxt(aTHX_ aMY_CXT);
 498 }
 499
 500 #ifdef USE_ITHREADS
 501
 502 void
 503 CLONE(...)
 504 CODE:
 505 {
 506     MY_CXT_CLONE;
 507     setup_my_cxt(aTHX_ aMY_CXT);
 508     PERL_UNUSED_VAR(items);
 509 }
 510
 511 #endif /* !USE_ITHREADS */
 512
 513 void
 514 Item(SV* sv = &PL_sv_undef)
 515 ALIAS:
 516     Any        = MOUSE_TC_ANY
 517     Item       = MOUSE_TC_ITEM
 518     Undef      = MOUSE_TC_UNDEF
 519     Defined    = MOUSE_TC_DEFINED
 520     Bool       = MOUSE_TC_BOOL
 521     Value      = MOUSE_TC_VALUE
 522     Ref        = MOUSE_TC_REF
 523     Str        = MOUSE_TC_STR
 524     Num        = MOUSE_TC_NUM
 525     Int        = MOUSE_TC_INT
 526     ScalarRef  = MOUSE_TC_SCALAR_REF
 527     ArrayRef   = MOUSE_TC_ARRAY_REF
 528     HashRef    = MOUSE_TC_HASH_REF
 529     CodeRef    = MOUSE_TC_CODE_REF
 530     GlobRef    = MOUSE_TC_GLOB_REF
 531     FileHandle = MOUSE_TC_FILEHANDLE
 532     RegexpRef  = MOUSE_TC_REGEXP_REF
 533     Object     = MOUSE_TC_OBJECT
 534     ClassName  = MOUSE_TC_CLASS_NAME
 535     RoleName   = MOUSE_TC_ROLE_NAME
 536 CODE:
 537     SvGETMAGIC(sv);
 538     ST(0) = boolSV( mouse_builtin_tc_check(aTHX_ ix, sv) );
 539     XSRETURN(1);
 540
 541
 542 CV*
 543 _parameterize_ArrayRef_for(SV* param)
 544 ALIAS:
 545     _parameterize_ArrayRef_for = MOUSE_TC_ARRAY_REF
 546     _parameterize_HashRef_for  = MOUSE_TC_HASH_REF
 547     _parameterize_Maybe_for    = MOUSE_TC_MAYBE
 548 CODE:
 549 {
 550     check_fptr_t fptr;
 551     SV* const tc_code = mcall0s(param, "_compiled_type_constraint");
 552     if(!(SvROK(tc_code) && SvTYPE(SvRV(tc_code)) == SVt_PVCV)){
 553         croak("_compiled_type_constraint didn't return a CODE reference");
 554     }
 555
 556     switch(ix){
 557     case MOUSE_TC_ARRAY_REF:
 558         fptr = mouse_parameterized_ArrayRef;
 559         break;
 560     case MOUSE_TC_HASH_REF:
 561         fptr = mouse_parameterized_HashRef;
 562         break;
 563     default: /* Maybe type */
 564         fptr = mouse_parameterized_Maybe;
 565     }
 566     RETVAL = mouse_tc_parameterize(aTHX_ NULL, fptr, tc_code);
 567 }
 568 OUTPUT:
 569     RETVAL
 570