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