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