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