Moose.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 #define NEED_newRV_noinc
   6 #define NEED_newSVpvn_share
   7 #define NEED_sv_2pv_flags
   8 #include "ppport.h"
   9
  10 #ifndef XSPROTO
  11 #define XSPROTO(name) void name(pTHX_ CV* cv)
  12 #endif
  13
  14 #ifndef gv_stashpvs
  15 #define gv_stashpvs(x, y) gv_stashpvn(STR_WITH_LEN(x), y)
  16 #endif
  17
  18 /* FIXME
  19  * type constraints are already implemented by konobi
  20  * should be trivial to do coercions for the core types, too
  21  *
  22  * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then*
  23  * call ->isa (should handle vast majority of cases)
  24  *
  25  * base parametrized types are also trivial
  26  *
  27  * ClassName is get_stathpvn
  28  */
  29
  30 /* FIXME
  31  * for a constructor we have ATTR *attrs, and iterate that, removing init_arg
  32  * we can preallocate the structure to the right size (maybe even with the
  33  * right HEs?), and do various other prehashing hacks to gain speed
  34  * */
  35
  36 /* FIXME
  37  * delegations and attribute helpers:
  38  *
  39  * typedef struct {
  40  *      ATTR *attr;
  41  *      pv *method;
  42  * } delegation;
  43  *
  44  * typedef struct {
  45  *      ATTR *attr;
  46  *      I32 *type; // hash, array, whatever + vtable for operation
  47  * } attributehelper;
  48  */
  49
  50
  51 STATIC MGVTBL null_mg_vtbl = {
  52     NULL, /* get */
  53     NULL, /* set */
  54     NULL, /* len */
  55     NULL, /* clear */
  56     NULL, /* free */
  57 #if MGf_COPY
  58     NULL, /* copy */
  59 #endif /* MGf_COPY */
  60 #if MGf_DUP
  61     NULL, /* dup */
  62 #endif /* MGf_DUP */
  63 #if MGf_LOCAL
  64     NULL, /* local */
  65 #endif /* MGf_LOCAL */
  66 };
  67
  68 STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) {
  69     MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 );
  70     mg->mg_flags |= MGf_REFCOUNTED;
  71
  72     return mg;
  73 }
  74
  75 STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
  76     MAGIC *mg, *moremagic;
  77
  78     if (SvTYPE(sv) >= SVt_PVMG) {
  79         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  80             if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl))
  81                 break;
  82         }
  83         if (mg)
  84             return mg->mg_obj;
  85     }
  86
  87     return NULL;
  88 }
  89
  90 /* this is a enum of checks */
  91 typedef enum {
  92     Any, /* or item, or bool */
  93     Undef,
  94     Defined,
  95     Str, /* or value */
  96     Num,
  97     Int,
  98     GlobRef, /* SVt_PVGV */
  99     ArrayRef, /* SVt_PVAV */
 100     HashRef, /* SVt_PVHV */
 101     CodeRef, /* SVt_PVCV */
 102     Ref,
 103     ScalarRef,
 104     FileHandle,
 105     RegexpRef,
 106     Object,
 107     ClassName,
 108     /* complex checks */
 109     Role,
 110     Enum,
 111 } TC;
 112
 113 typedef enum {
 114     tc_none = 0,
 115     tc_type,
 116     tc_stash,
 117     tc_cv,
 118     tc_op,
 119     tc_fptr,
 120 } tc_kind;
 121
 122 typedef union {
 123     TC type;
 124     SV *sv;
 125     OP *op;
 126     bool (*fptr)(pTHX_ SV *type_constraint, SV *sv);
 127 } TC_CHECK;
 128
 129 typedef union {
 130     char *builder;
 131     SV *value;
 132     CV *sub;
 133     OP *op;
 134     U32 type;
 135 } DEFAULT;
 136
 137 typedef enum {
 138     default_none = 0,
 139     default_type,
 140     default_builder,
 141     default_value,
 142     default_sub,
 143     default_op,
 144 } default_kind;
 145
 146 typedef struct {
 147     /* the meta instance struct */
 148     struct mi *mi;
 149
 150     U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
 151
 152     /* slot access fields */
 153     SV *slot_sv; /* value of the slot (slot name presumably) */
 154     U32 slot_u32; /* for optimized access (precomputed hash or otherr) */
 155
 156     DEFAULT def; /* cv, value or other, depending on flags */
 157
 158     TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
 159     SV *type_constraint; /* meta attr */
 160
 161     CV *initializer;
 162     CV *trigger;
 163
 164     SV *meta_attr; /* the meta attr object */
 165     AV *cvs; /* CVs which use this attr */
 166 } ATTR;
 167
 168 /* slot flags:
 169  * instance           reading  writing
 170  * 00000000 00000000 00000000 00000000
 171  *                             ^       trigger
 172  *                              ^      weak
 173  *                               ^     tc refcnt
 174  *                                 ^^^ tc_kind
 175  *                                ^    coerce
 176  *                        ^^^          default_kind
 177  *                       ^             lazy
 178  *                 ^                   required
 179  * ^^^^^^^                             if 0 then nothing special (just hash)? FIXME TBD
 180  */
 181
 182 #define ATTR_INSTANCE_MASK 0xff000000
 183 #define ATTR_READING_MASK  0x0000ff00
 184 #define ATTR_WRITING_MASK  0x000000ff
 185
 186 #define ATTR_MASK_TYPE 0x7
 187
 188 #define ATTR_MASK_DEFAULT 0x700
 189 #define ATTR_SHIFT_DEAFULT 8
 190
 191 #define ATTR_LAZY 0x800
 192
 193 #define ATTR_COERCE 0x8
 194 #define ATTR_TCREFCNT 0x10
 195 #define ATTR_WEAK 0x20
 196 #define ATTR_TRIGGER 0x40
 197
 198 #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK )
 199 #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY )
 200 #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE )
 201
 202 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
 203 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
 204
 205 #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr)
 206 #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 )
 207 #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 )
 208
 209 #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv))
 210
 211
 212 /* FIXME define a vtable that does call_sv */
 213 typedef struct {
 214     SV * (*get)(pTHX_ SV *self, ATTR *attr);
 215     void (*set)(pTHX_ SV *self, ATTR *attr, SV *value);
 216     bool * (*has)(pTHX_ SV *self, ATTR *attr);
 217     SV * (*delete)(pTHX_ SV *self, ATTR *attr);
 218 } instance_vtbl;
 219
 220
 221 typedef enum {
 222     hash = 0,
 223
 224     /* these are not yet implemented */
 225     array,
 226     fptr,
 227     cv,
 228     judy,
 229 } instance_types;
 230
 231 typedef struct mi {
 232     HV *stash;
 233
 234     /* slot access method */
 235     instance_types type;
 236     instance_vtbl *vtbl;
 237
 238     /* attr descriptors */
 239     I32 num_attrs;
 240     ATTR *attrs;
 241 } MI;
 242
 243
 244
 245
 246 STATIC bool check_is_scalar_ref(SV *sv) {
 247     if( SvROK(sv) ) {
 248         switch (SvTYPE(SvRV(sv))) {
 249             case SVt_IV:
 250             case SVt_NV:
 251             case SVt_PV:
 252             case SVt_NULL:
 253                 return 1;
 254                 break;
 255             default:
 256                 return 0;
 257         }
 258     }
 259     return 0;
 260 }
 261
 262 STATIC bool check_reftype(TC type, SV *sv) {
 263     int svt;
 264
 265     if ( !SvROK(sv) )
 266         return 0;
 267
 268     switch (type) {
 269         case GlobRef:
 270             svt = SVt_PVGV;
 271             break;
 272         case ArrayRef:
 273             svt = SVt_PVAV;
 274             break;
 275         case HashRef:
 276             svt = SVt_PVHV;
 277             break;
 278         case CodeRef:
 279             svt = SVt_PVCV;
 280             break;
 281     }
 282
 283     return SvTYPE(SvRV(sv)) == svt;
 284 }
 285
 286 STATIC bool check_sv_class(pTHX_ HV *stash, SV *sv) {
 287     dSP;
 288     bool ret;
 289     SV *rv;
 290
 291     if (!sv)
 292         return 0;
 293     SvGETMAGIC(sv);
 294     if (!SvROK(sv))
 295         return 0;
 296     rv = (SV*)SvRV(sv);
 297     if (!SvOBJECT(rv))
 298         return 0;
 299     if (SvSTASH(rv) == stash)
 300         return 1;
 301
 302     ENTER;
 303     SAVETMPS;
 304     PUSHMARK(SP);
 305     XPUSHs(sv);
 306     XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0)));
 307     PUTBACK;
 308
 309     call_method("isa", G_SCALAR);
 310
 311     SPAGAIN;
 312     ret = SvTRUE(TOPs);
 313
 314     FREETMPS;
 315     LEAVE;
 316
 317     return ret;
 318 }
 319
 320 STATIC bool check_sv_type (TC type, SV *sv) {
 321     if (!sv)
 322         return 0;
 323
 324     switch (type) {
 325         case Any:
 326             return 1;
 327             break;
 328         case Undef:
 329             return !SvOK(sv);
 330             break;
 331         case Defined:
 332             return SvOK(sv);
 333             break;
 334         case Str:
 335             return (SvOK(sv) && !SvROK(sv));
 336         case Num:
 337 #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
 338             if (!SvPOK(sv) && !SvPOKp(sv))
 339                 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
 340             else
 341 #endif
 342                 return looks_like_number(sv);
 343             break;
 344         case Int:
 345             if ( SvIOK(sv) ) {
 346                 return 1;
 347             } else if ( SvPOK(sv) ) {
 348                 /* FIXME i really don't like this */
 349                 int i;
 350                 STRLEN len;
 351                 char *pv = SvPV(sv, len);
 352                 char *end = pv + len;
 353                 char *tail = end;
 354
 355                 errno = 0;
 356                 i = strtol(pv, &tail, 0);
 357
 358                 if ( errno ) return 0;
 359
 360                 while ( tail != end ) {
 361                     if ( !isspace(*tail++) ) return 0;
 362                 }
 363
 364                 return 1;
 365             }
 366             return 0;
 367             break;
 368         case Ref:
 369             return SvROK(sv);
 370             break;
 371         case ScalarRef:
 372             return check_is_scalar_ref(sv);
 373             break;
 374         case ArrayRef:
 375         case HashRef:
 376         case CodeRef:
 377         case GlobRef:
 378             return check_reftype(type, sv);
 379             break;
 380         case Object:
 381             return sv_isobject(sv);
 382             break;
 383         case ClassName:
 384             if ( SvOK(sv) && !SvROK(sv) ) {
 385                 STRLEN len;
 386                 char *pv;
 387                 pv = SvPV(sv, len);
 388                 return ( gv_stashpvn(pv, len, 0) != NULL );
 389             }
 390             return 0;
 391             break;
 392         case RegexpRef:
 393             return sv_isa(sv, "Regexp");
 394             break;
 395         case FileHandle:
 396             croak("todo");
 397             break;
 398         default:
 399             croak("todo");
 400     }
 401
 402     return 0;
 403 }
 404
 405 STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
 406     switch (kind) {
 407         case tc_none:
 408             return 1;
 409             break;
 410         case tc_type:
 411             return check_sv_type(tc_check.type, sv);
 412             break;
 413         case tc_stash:
 414             return check_sv_class(aTHX_ (HV *)tc_check.sv, sv);
 415             break;
 416         case tc_fptr:
 417             return tc_check.fptr(aTHX_ type_constraint, sv);
 418             break;
 419         case tc_cv:
 420         case tc_op:
 421             croak("todo");
 422             break;
 423     }
 424
 425     croak("todo");
 426     return 0;
 427 }
 428
 429
 430 STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
 431     U32 flags = 0;
 432     U32 hash;
 433     STRLEN len;
 434     char *pv;
 435     I32 ix = av_len(desc);
 436     SV **params = AvARRAY(desc);
 437     SV *tc;
 438     SV *key;
 439
 440     attr->mi = mi;
 441
 442
 443     if ( ix != 12 )
 444         croak("wrong number of args (%d != 13)", ix + 1);
 445
 446     for ( ; ix >= 0; ix-- ) {
 447         if ( !params[ix] || params[ix] == &PL_sv_undef )
 448             croak("bad params");
 449     }
 450
 451     if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV )
 452         croak("slots is not an array");
 453
 454     if ( av_len((AV *)SvRV(params[1])) != 0 )
 455         croak("Only unary slots are supported at the moment");
 456
 457     /* calculate a hash from the slot */
 458     /* FIXME arrays etc should also be supported */
 459     key = *av_fetch((AV *)SvRV(params[1]), 0, 0);
 460     pv = SvPV(key, len);
 461     PERL_HASH(hash, pv, len);
 462
 463
 464     /* FIXME better organize these */
 465     if ( SvTRUE(params[2]) )
 466         flags |= ATTR_WEAK;
 467
 468     if ( SvTRUE(params[3]) )
 469         flags |= ATTR_COERCE;
 470
 471     if ( SvTRUE(params[4]) )
 472         flags |= ATTR_LAZY;
 473
 474     tc = params[5];
 475
 476     if ( SvOK(tc) ) {
 477         int tc_kind = SvIV(params[6]);
 478         SV *data = params[7];
 479
 480         switch (tc_kind) {
 481             case tc_type:
 482                 attr->tc_check.type = SvIV(data);
 483                 break;
 484             case tc_stash:
 485                 flags |= ATTR_TCREFCNT;
 486                 attr->tc_check.sv = (SV *)gv_stashsv(data, 0);
 487                 break;
 488             case tc_cv:
 489                 flags |= ATTR_TCREFCNT;
 490                 attr->tc_check.sv = SvRV(data);
 491                 if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV )
 492                     croak("compiled type constraint is not a coderef");
 493                 break;
 494             default:
 495                 croak("todo");
 496         }
 497
 498         flags |= tc_kind;
 499     }
 500
 501     attr->flags = flags; /* FIXME default_kind */
 502
 503     attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL;
 504     if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV )
 505         croak("trigger is not a coderef");
 506
 507     attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL;
 508     if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV )
 509         croak("initializer is not a coderef");
 510
 511     /* copy refs */
 512     attr->meta_attr       = newSVsv(params[0]);
 513     attr->type_constraint = newSVsv(tc);
 514     SvREFCNT_inc(attr->trigger);
 515     SvREFCNT_inc(attr->initializer);
 516     if ( flags & ATTR_TCREFCNT ) SvREFCNT_inc(attr->tc_check.sv);
 517
 518     attr->slot_sv = newSVpvn_share(pv, len, hash);
 519     attr->slot_u32 = hash;
 520
 521     attr->def.type = 0;
 522
 523     /* cross refs to CVs which use this struct */
 524     attr->cvs = newAV();
 525 }
 526
 527 STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) {
 528     MI *mi;
 529     I32 ix;
 530     const I32 num = av_len(attrs) + 1;
 531
 532     Newx(mi, 1, MI);
 533
 534     SvREFCNT_inc_simple(stash);
 535     mi->stash = stash;
 536
 537     mi->type = 0; /* nothing else implemented yet */
 538
 539     /* initialize attributes */
 540     mi->num_attrs = num;
 541     Newx(mi->attrs, num, ATTR);
 542     for ( ix = 0; ix < num; ix++ ) {
 543         SV **desc = av_fetch(attrs, ix, 0);
 544
 545         if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
 546             croak("Attribute descriptor has to be a hash reference");
 547         }
 548
 549         init_attr(mi, &mi->attrs[ix], (AV *)SvRV(*desc));
 550     }
 551
 552     return mi;
 553 }
 554
 555 STATIC void delete_mi (pTHX_ MI *mi) {
 556     I32 i, j;
 557
 558     for ( i = 0; i < mi->num_attrs; i++ ) {
 559         ATTR *attr = &mi->attrs[i];
 560         /* clear the pointers to this meta attr from all the CVs */
 561         SV **cvs = AvARRAY(attr->cvs);
 562         for ( j = av_len(attr->cvs); j >= 0; j-- ) {
 563             CV *cv = cvs[j];
 564             XSANY.any_i32 = 0;
 565         }
 566
 567         SvREFCNT_dec(attr->cvs);
 568         SvREFCNT_dec(attr->slot_sv);
 569         SvREFCNT_dec(attr->type_constraint);
 570         if ( attr->flags & ATTR_TCREFCNT ) SvREFCNT_dec(attr->tc_check.sv);
 571         SvREFCNT_dec(attr->initializer);
 572         SvREFCNT_dec(attr->trigger);
 573         SvREFCNT_dec(attr->meta_attr);
 574     }
 575
 576     Safefree(mi->attrs);
 577     Safefree(mi);
 578 }
 579
 580 STATIC SV *new_mi_obj (pTHX_ MI *mi) {
 581     HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
 582     SV *obj = newRV_noinc(newSViv(PTR2IV(mi)));
 583     sv_bless( obj, stash );
 584     return obj;
 585 }
 586
 587 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
 588     dSP;
 589     I32 count;
 590     SV *mi;
 591
 592     if ( !meta_attr )
 593         croak("No attr found in magic!");
 594
 595     ENTER;
 596     SAVETMPS;
 597     PUSHMARK(SP);
 598     XPUSHs(meta_attr);
 599     PUTBACK;
 600     count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
 601
 602     if ( count != 1 )
 603         croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
 604
 605     SPAGAIN;
 606     mi = POPs;
 607
 608     SvREFCNT_inc(mi);
 609
 610     PUTBACK;
 611     FREETMPS;
 612     LEAVE;
 613
 614     return mi;
 615 }
 616
 617 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
 618     dSP;
 619     I32 count;
 620     MI *mi = NULL;
 621     SV *class;
 622     SV *attrs;
 623     HV *stash;
 624
 625     ENTER;
 626     SAVETMPS;
 627     PUSHMARK(SP);
 628     XPUSHs(perl_mi);
 629     PUTBACK;
 630     count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
 631
 632     if ( count != 2 )
 633         croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
 634
 635     SPAGAIN;
 636     attrs = POPs;
 637     class = POPs;
 638
 639     PUTBACK;
 640
 641     stash = gv_stashsv(class, 0);
 642
 643     mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
 644
 645     FREETMPS;
 646     LEAVE;
 647
 648     return new_mi_obj(aTHX_ mi);
 649 }
 650
 651 STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
 652     I32 ix;
 653
 654     for ( ix = 0; ix < mi->num_attrs; ix++ ) {
 655         if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
 656             return &mi->attrs[ix];
 657         }
 658     }
 659
 660     sv_dump(meta_attr);
 661     croak("Attr not found");
 662     return NULL;
 663 }
 664
 665 STATIC ATTR *get_attr(pTHX_ CV *cv) {
 666     SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv);
 667     SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
 668     SV *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
 669     MI *mi;
 670
 671     if (!c_mi) {
 672         c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
 673         stash_in_mg(aTHX_ SvRV(perl_mi), c_mi);
 674         SvREFCNT_dec(c_mi);
 675     }
 676
 677     sv_2mortal(perl_mi);
 678
 679     mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
 680
 681     return mi_find_attr(mi, meta_attr);
 682 }
 683
 684 STATIC ATTR *define_attr (pTHX_ CV *cv) {
 685     ATTR *attr = get_attr(aTHX_ cv);
 686     assert(attr);
 687
 688     XSANY.any_i32 = PTR2IV(attr);
 689
 690     SvREFCNT_inc(cv);
 691     av_push( attr->cvs, (SV *)cv );
 692
 693     return attr;
 694 }
 695
 696 STATIC void weaken(pTHX_ SV *sv) {
 697 #ifdef SvWEAKREF
 698         sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
 699 #else
 700         croak("weak references are not implemented in this release of perl");
 701 #endif
 702 }
 703
 704
 705 /* meta instance protocol */
 706
 707 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
 708     HE *he;
 709
 710     assert(self);
 711     assert(SvROK(self));
 712     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 713
 714     assert( ATTR_DUMB_INSTANCE(attr) );
 715
 716     if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
 717         return HeVAL(he);
 718     else
 719         return NULL;
 720 }
 721
 722 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
 723     HE *he;
 724     SV *copy;
 725
 726     assert(self);
 727     assert(SvROK(self));
 728     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 729
 730     assert( ATTR_DUMB_INSTANCE(attr) );
 731
 732     copy = newSVsv(value);
 733
 734     he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
 735
 736     if (he != NULL) {
 737         if ( ATTR_ISWEAK(attr) )
 738             weaken(aTHX_ HeVAL(he));
 739     } else {
 740         SvREFCNT_dec(copy);
 741         croak("Hash store failed.");
 742     }
 743 }
 744
 745 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
 746     assert(self);
 747     assert(SvROK(self));
 748     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 749
 750     assert( ATTR_DUMB_INSTANCE(attr) );
 751
 752     return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
 753 }
 754
 755 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
 756     assert(self);
 757     assert(SvROK(self));
 758     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 759
 760     assert( ATTR_DUMB_INSTANCE(attr) );
 761
 762     return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
 763 }
 764
 765 STATIC SV *getter_common(pTHX_ SV *self, ATTR *attr) {
 766     assert( ATTR_DUMB_READER(attr) );
 767     return get_slot_value(aTHX_ self, attr);
 768 }
 769
 770 STATIC void setter_common(pTHX_ SV *self, ATTR *attr, SV *value) {
 771     if ( attr->flags & ATTR_MASK_TYPE ) {
 772         if ( !check_type_constraint(aTHX_ attr->flags & ATTR_MASK_TYPE, attr->tc_check, attr->type_constraint, value) )
 773             croak("Bad param");
 774     }
 775
 776     set_slot_value(aTHX_ self, attr, value);
 777 }
 778
 779 /* simple high level api */
 780
 781 STATIC XS(getter);
 782 STATIC XS(getter)
 783 {
 784 #ifdef dVAR
 785     dVAR;
 786 #endif
 787     dXSARGS;
 788     dATTR;
 789     SV *value;
 790
 791     if (items != 1)
 792         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 793
 794     SP -= items;
 795
 796     value = getter_common(aTHX_ ST(0), attr);
 797
 798     if (value) {
 799         ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
 800         XSRETURN(1);
 801     } else {
 802         XSRETURN_UNDEF;
 803     }
 804 }
 805
 806 STATIC XS(setter);
 807 STATIC XS(setter)
 808 {
 809 #ifdef dVAR
 810     dVAR;
 811 #endif
 812     dXSARGS;
 813     dATTR;
 814
 815     if (items != 2)
 816         Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
 817
 818     SP -= items;
 819
 820     setter_common(aTHX_ ST(0), attr, ST(1));
 821
 822     ST(0) = ST(1); /* return value */
 823     XSRETURN(1);
 824 }
 825
 826 STATIC XS(accessor);
 827 STATIC XS(accessor)
 828 {
 829 #ifdef dVAR
 830     dVAR;
 831 #endif
 832     dXSARGS;
 833     dATTR;
 834
 835     if (items < 1)
 836         Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
 837
 838     SP -= items;
 839
 840     if (items > 1) {
 841         setter_common(aTHX_ ST(0), attr, ST(1));
 842         ST(0) = ST(1); /* return value */
 843     } else {
 844         SV *value = getter_common(aTHX_ ST(0), attr);
 845         if ( value ) {
 846             ST(0) = value;
 847         } else {
 848             XSRETURN_UNDEF;
 849         }
 850     }
 851
 852     XSRETURN(1);
 853 }
 854
 855 STATIC XS(predicate);
 856 STATIC XS(predicate)
 857 {
 858 #ifdef dVAR
 859     dVAR;
 860 #endif
 861     dXSARGS;
 862     dATTR;
 863
 864     if (items != 1)
 865         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 866
 867     SP -= items;
 868
 869     if ( has_slot_value(aTHX_ ST(0), attr) )
 870         XSRETURN_YES;
 871     else
 872         XSRETURN_NO;
 873 }
 874
 875 enum xs_body {
 876     xs_body_getter = 0,
 877     xs_body_setter,
 878     xs_body_accessor,
 879     xs_body_predicate,
 880     max_xs_body
 881 };
 882
 883 STATIC XSPROTO ((*xs_bodies[])) = {
 884     getter,
 885     setter,
 886     accessor,
 887     predicate,
 888 };
 889
 890 MODULE = Moose PACKAGE = Moose::XS
 891
 892 CV *
 893 new_sub(attr, name)
 894     INPUT:
 895         SV *attr;
 896         SV *name;
 897     ALIAS:
 898         new_getter    = xs_body_getter
 899         new_setter    = xs_body_setter
 900         new_accessor  = xs_body_accessor
 901         new_predicate = xs_body_predicate
 902     PREINIT:
 903         CV * cv;
 904     CODE:
 905         if ( ix >= max_xs_body )
 906             croak("Unknown Moose::XS body type");
 907
 908         if ( !sv_isobject(attr) )
 909             croak("'attr' must be a Moose::Meta::Attribute");
 910
 911         cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
 912
 913         if (cv == NULL)
 914             croak("Oi vey!");
 915
 916         /* associate CV with meta attr */
 917         stash_in_mg(aTHX_ (SV *)cv, attr);
 918
 919         /* this will be set on first call */
 920         XSANY.any_i32 = 0;
 921
 922         RETVAL = cv;
 923     OUTPUT:
 924         RETVAL
 925
 926
 927 MODULE = Moose  PACKAGE = Moose::XS::Meta::Instance
 928
 929 void
 930 DESTROY(self)
 931     INPUT:
 932         SV *self;
 933     PREINIT:
 934         MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
 935     CODE:
 936         delete_mi(aTHX_ mi);