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