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 *sv;
 114     OP *op;
 115     U32 type;
 116 } DEFAULT;
 117
 118 typedef enum {
 119     default_none = 0,
 120     default_normal,
 121     default_builder,
 122     default_type,
 123     default_op,
 124 } default_kind;
 125
 126 typedef struct {
 127     /* the meta instance struct */
 128     struct mi *mi;
 129
 130     U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
 131
 132     /* slot access fields */
 133     SV *slot_sv; /* value of the slot (slot name presumably) */
 134     U32 slot_u32; /* for optimized access (precomputed hash or otherr) */
 135
 136     DEFAULT def; /* cv, value or other, depending on flags */
 137
 138     TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
 139     SV *type_constraint; /* meta attr */
 140
 141     CV *initializer;
 142     CV *trigger;
 143
 144     SV *meta_attr; /* the meta attr object */
 145     AV *cvs; /* CVs which use this attr */
 146 } ATTR;
 147
 148 /* slot flags:
 149  * instance           reading  writing
 150  * 00000000 00000000 00000000 00000000
 151  *                             ^       trigger
 152  *                              ^      weak
 153  *                               ^     tc.sv is refcounted
 154  *                                 ^^^ tc_kind
 155  *                                ^    coerce
 156  *                        ^^^          default_kind
 157  *                       ^             lazy
 158  *                      ^              def.sv is refcounted
 159  *                 ^                   required
 160  * ^^^^^^^                             if 0 then nothing special (just hash)? FIXME TBD
 161  */
 162
 163 #define ATTR_INSTANCE_MASK 0xff000000
 164 #define ATTR_READING_MASK  0x0000ff00
 165 #define ATTR_WRITING_MASK  0x000000ff
 166
 167 #define ATTR_MASK_TYPE 0x7
 168
 169 #define ATTR_MASK_DEFAULT 0x700
 170 #define ATTR_SHIFT_DEFAULT 8
 171
 172 #define ATTR_LAZY 0x800
 173 #define ATTR_DEFREFCNT 0x1000
 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_sv_cv (pTHX_ SV *cv, SV *sv) {
 388     bool ret;
 389     dSP;
 390
 391     ENTER;
 392     SAVETMPS;
 393     PUSHMARK(SP);
 394     XPUSHs(sv);
 395     PUTBACK;
 396
 397     call_sv(cv, G_SCALAR);
 398
 399     SPAGAIN;
 400     ret = SvTRUE(POPs);
 401
 402     PUTBACK;
 403     FREETMPS;
 404     LEAVE;
 405
 406     return ret;
 407 }
 408
 409 STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
 410     switch (kind) {
 411         case tc_none:
 412             return 1;
 413             break;
 414         case tc_type:
 415             return check_sv_type(tc_check.type, sv);
 416             break;
 417         case tc_stash:
 418             return check_sv_class(aTHX_ (HV *)tc_check.sv, sv);
 419             break;
 420         case tc_fptr:
 421             return tc_check.fptr(aTHX_ type_constraint, sv);
 422             break;
 423         case tc_cv:
 424             return check_sv_cv(aTHX_ tc_check.sv, sv);
 425             break;
 426         case tc_op:
 427             croak("todo");
 428             break;
 429     }
 430
 431     croak("todo");
 432     return 0;
 433 }
 434
 435
 436 STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
 437     U32 flags = 0;
 438     U32 hash;
 439     STRLEN len;
 440     char *pv;
 441     I32 ix = av_len(desc);
 442     SV **params = AvARRAY(desc);
 443     SV *tc;
 444     SV *key;
 445
 446     attr->mi = mi;
 447
 448
 449     if ( ix != 12 )
 450         croak("wrong number of args (%d != 13)", ix + 1);
 451
 452     for ( ; ix >= 0; ix-- ) {
 453         if ( !params[ix] || params[ix] == &PL_sv_undef )
 454             croak("bad params");
 455     }
 456
 457     if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV )
 458         croak("slots is not an array");
 459
 460     if ( av_len((AV *)SvRV(params[1])) != 0 )
 461         croak("Only unary slots are supported at the moment");
 462
 463     /* calculate a hash from the slot */
 464     /* FIXME arrays etc should also be supported */
 465     key = *av_fetch((AV *)SvRV(params[1]), 0, 0);
 466     pv = SvPV(key, len);
 467     PERL_HASH(hash, pv, len);
 468
 469
 470     /* FIXME better organize these */
 471     if ( SvTRUE(params[2]) )
 472         flags |= ATTR_WEAK;
 473
 474     if ( SvTRUE(params[3]) )
 475         flags |= ATTR_COERCE;
 476
 477     if ( SvTRUE(params[4]) )
 478         flags |= ATTR_LAZY;
 479
 480     tc = params[5];
 481
 482     if ( SvOK(tc) ) {
 483         int tc_kind = SvIV(params[6]);
 484         SV *data = params[7];
 485
 486         switch (tc_kind) {
 487             case tc_type:
 488                 attr->tc_check.type = SvIV(data);
 489                 break;
 490             case tc_stash:
 491                 flags |= ATTR_TCREFCNT;
 492                 attr->tc_check.sv = (SV *)gv_stashsv(data, 0);
 493                 break;
 494             case tc_cv:
 495                 flags |= ATTR_TCREFCNT;
 496                 attr->tc_check.sv = SvRV(data);
 497                 if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV )
 498                     croak("compiled type constraint is not a coderef");
 499                 break;
 500             default:
 501                 croak("todo");
 502         }
 503
 504         flags |= tc_kind;
 505     }
 506
 507
 508     if ( SvTRUE(params[10]) ) { /* has default */
 509         SV *sv = params[11];
 510
 511         if ( SvROK(sv) ) {
 512             attr->def.sv = SvRV(sv);
 513             if ( SvTYPE(attr->def.sv) != SVt_PVCV )
 514                 croak("compiled type constraint is not a coderef");
 515         } else {
 516             attr->def.sv = newSVsv(sv);
 517             sv_2mortal(attr->def.sv); /* in case of error soon, we refcnt inc it later after we're done checking params */
 518         }
 519
 520         flags |= ( ATTR_DEFREFCNT | ( default_normal << ATTR_SHIFT_DEFAULT ) );
 521     } else if ( SvOK(params[12]) ) { /* builder */
 522         attr->def.sv = newSVsv(params[12]);
 523         flags |= ( ATTR_DEFREFCNT | ( default_builder << ATTR_SHIFT_DEFAULT ) );
 524     }
 525
 526     attr->flags = flags; /* FIXME default_kind */
 527
 528     attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL;
 529     if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV )
 530         croak("trigger is not a coderef");
 531
 532     attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL;
 533     if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV )
 534         croak("initializer is not a coderef");
 535
 536     /* copy refs */
 537     attr->meta_attr       = newSVsv(params[0]);
 538     attr->type_constraint = newSVsv(tc);
 539     SvREFCNT_inc(attr->trigger);
 540     SvREFCNT_inc(attr->initializer);
 541     if ( flags & ATTR_TCREFCNT )  SvREFCNT_inc(attr->tc_check.sv);
 542     if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc(attr->def.sv);
 543
 544     attr->slot_sv = newSVpvn_share(pv, len, hash);
 545     attr->slot_u32 = hash;
 546
 547     /* cross refs to CVs which use this struct */
 548     attr->cvs = newAV();
 549 }
 550
 551 STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) {
 552     MI *mi;
 553     I32 ix;
 554     const I32 num = av_len(attrs) + 1;
 555
 556     Newx(mi, 1, MI);
 557
 558     SvREFCNT_inc_simple(stash);
 559     mi->stash = stash;
 560
 561     mi->type = 0; /* nothing else implemented yet */
 562
 563     /* initialize attributes */
 564     mi->num_attrs = num;
 565     Newx(mi->attrs, num, ATTR);
 566     for ( ix = 0; ix < num; ix++ ) {
 567         SV **desc = av_fetch(attrs, ix, 0);
 568
 569         if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
 570             croak("Attribute descriptor has to be a hash reference");
 571         }
 572
 573         init_attr(mi, &mi->attrs[ix], (AV *)SvRV(*desc));
 574     }
 575
 576     return mi;
 577 }
 578
 579 STATIC void delete_mi (pTHX_ MI *mi) {
 580     I32 i, j;
 581
 582     for ( i = 0; i < mi->num_attrs; i++ ) {
 583         ATTR *attr = &mi->attrs[i];
 584         /* clear the pointers to this meta attr from all the CVs */
 585         SV **cvs = AvARRAY(attr->cvs);
 586         for ( j = av_len(attr->cvs); j >= 0; j-- ) {
 587             CV *cv = (CV *)cvs[j];
 588             XSANY.any_i32 = 0;
 589         }
 590
 591         SvREFCNT_dec(attr->cvs);
 592         SvREFCNT_dec(attr->slot_sv);
 593         SvREFCNT_dec(attr->type_constraint);
 594         if ( attr->flags & ATTR_TCREFCNT )  SvREFCNT_dec(attr->tc_check.sv);
 595         if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv);
 596         SvREFCNT_dec(attr->initializer);
 597         SvREFCNT_dec(attr->trigger);
 598         SvREFCNT_dec(attr->meta_attr);
 599     }
 600
 601     Safefree(mi->attrs);
 602     Safefree(mi);
 603 }
 604
 605 STATIC SV *new_mi_obj (pTHX_ MI *mi) {
 606     HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
 607     SV *obj = newRV_noinc(newSViv(PTR2IV(mi)));
 608     sv_bless( obj, stash );
 609     return obj;
 610 }
 611
 612 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
 613     dSP;
 614     I32 count;
 615     SV *mi;
 616
 617     if ( !meta_attr )
 618         croak("No attr found in magic!");
 619
 620     ENTER;
 621     SAVETMPS;
 622     PUSHMARK(SP);
 623     XPUSHs(meta_attr);
 624     PUTBACK;
 625     count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
 626
 627     if ( count != 1 )
 628         croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
 629
 630     SPAGAIN;
 631     mi = POPs;
 632
 633     SvREFCNT_inc(mi);
 634
 635     PUTBACK;
 636     FREETMPS;
 637     LEAVE;
 638
 639     return sv_2mortal(mi);
 640 }
 641
 642 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
 643     dSP;
 644     I32 count;
 645     MI *mi = NULL;
 646     SV *class;
 647     SV *attrs;
 648     HV *stash;
 649
 650     ENTER;
 651     SAVETMPS;
 652     PUSHMARK(SP);
 653     XPUSHs(perl_mi);
 654     PUTBACK;
 655     count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
 656
 657     if ( count != 2 )
 658         croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
 659
 660     SPAGAIN;
 661     attrs = POPs;
 662     class = POPs;
 663
 664     PUTBACK;
 665
 666     stash = gv_stashsv(class, 0);
 667
 668     mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
 669
 670     FREETMPS;
 671     LEAVE;
 672
 673     return new_mi_obj(aTHX_ mi);
 674 }
 675
 676 STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
 677     I32 ix;
 678
 679     for ( ix = 0; ix < mi->num_attrs; ix++ ) {
 680         if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
 681             return &mi->attrs[ix];
 682         }
 683     }
 684
 685     sv_dump(meta_attr);
 686     croak("Attr not found");
 687     return NULL;
 688 }
 689
 690 STATIC ATTR *get_attr(pTHX_ CV *cv) {
 691     SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv);
 692     SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
 693     SV *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
 694     MI *mi;
 695
 696     if (!c_mi) {
 697         c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
 698         stash_in_mg(aTHX_ SvRV(perl_mi), c_mi);
 699         SvREFCNT_dec(c_mi);
 700     }
 701
 702     mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
 703
 704     return mi_find_attr(mi, meta_attr);
 705 }
 706
 707 STATIC ATTR *define_attr (pTHX_ CV *cv) {
 708     ATTR *attr = get_attr(aTHX_ cv);
 709     assert(attr);
 710
 711     XSANY.any_i32 = PTR2IV(attr);
 712
 713     SvREFCNT_inc(cv);
 714     av_push( attr->cvs, (SV *)cv );
 715
 716     return attr;
 717 }
 718
 719 STATIC void weaken(pTHX_ SV *sv) {
 720 #ifdef SvWEAKREF
 721         sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
 722 #else
 723         croak("weak references are not implemented in this release of perl");
 724 #endif
 725 }
 726
 727
 728 /* meta instance protocol */
 729
 730 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
 731     HE *he;
 732
 733     assert(self);
 734     assert(SvROK(self));
 735     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 736
 737     assert( ATTR_DUMB_INSTANCE(attr) );
 738
 739     if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
 740         return HeVAL(he);
 741     else
 742         return NULL;
 743 }
 744
 745 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
 746     HE *he;
 747     SV *copy;
 748
 749     assert(self);
 750     assert(SvROK(self));
 751     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 752
 753     assert( ATTR_DUMB_INSTANCE(attr) );
 754
 755     copy = newSVsv(value);
 756
 757     he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
 758
 759     if (he != NULL) {
 760         if ( ATTR_ISWEAK(attr) )
 761             weaken(aTHX_ HeVAL(he));
 762     } else {
 763         SvREFCNT_dec(copy);
 764         croak("Hash store failed.");
 765     }
 766 }
 767
 768 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
 769     assert(self);
 770     assert(SvROK(self));
 771     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 772
 773     assert( ATTR_DUMB_INSTANCE(attr) );
 774
 775     return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
 776 }
 777
 778 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
 779     assert(self);
 780     assert(SvROK(self));
 781     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 782
 783     assert( ATTR_DUMB_INSTANCE(attr) );
 784
 785     return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
 786 }
 787
 788 STATIC void setter_common(pTHX_ SV *self, ATTR *attr, SV *value);
 789
 790
 791 STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) {
 792     switch ( ATTR_DEFAULT(attr) ) {
 793         case default_none:
 794             return NULL;
 795             break;
 796         case default_builder:
 797             {
 798                 SV *sv;
 799                 dSP;
 800
 801                 ENTER;
 802                 SAVETMPS;
 803                 PUSHMARK(SP);
 804                 XPUSHs(self);
 805                 PUTBACK;
 806
 807                 call_method(SvPV_nolen(attr->def.sv), G_SCALAR);
 808
 809                 SPAGAIN;
 810                 sv = POPs;
 811
 812                 SvREFCNT_inc(sv);
 813
 814                 PUTBACK;
 815                 FREETMPS;
 816                 LEAVE;
 817
 818                 return sv_2mortal(sv);
 819             }
 820             break;
 821         case default_normal:
 822             if ( SvROK(attr->def.sv) ) {
 823                 printf("CV default\n");
 824             } else {
 825                 printf("simple value\n");
 826                 return attr->def.sv; /* will be copied by set for lazy, and by reader for both cases */
 827             }
 828             break;
 829         case default_op:
 830         case default_type:
 831             croak("todo");
 832             break;
 833     }
 834
 835     return NULL;
 836 }
 837
 838 STATIC SV *getter_common(pTHX_ SV *self, ATTR *attr) {
 839     SV *value = get_slot_value(aTHX_ self, attr);
 840
 841     if ( value ) {
 842         return value;
 843     } else if ( ATTR_ISLAZY(attr) ) {
 844         value = get_default(aTHX_ self, attr);
 845         setter_common(aTHX_ self, attr, value);
 846         return value;
 847     }
 848
 849     return NULL;
 850 }
 851
 852 STATIC void setter_common(pTHX_ SV *self, ATTR *attr, SV *value) {
 853     if ( ATTR_TYPE(attr) ) {
 854         if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) )
 855             croak("Bad param");
 856     }
 857
 858     set_slot_value(aTHX_ self, attr, value);
 859 }
 860
 861 /* simple high level api */
 862
 863 STATIC XS(getter);
 864 STATIC XS(getter)
 865 {
 866 #ifdef dVAR
 867     dVAR;
 868 #endif
 869     dXSARGS;
 870     dATTR;
 871     SV *value;
 872
 873     if (items != 1)
 874         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 875
 876     SP -= items;
 877
 878     value = getter_common(aTHX_ ST(0), attr);
 879
 880     if (value) {
 881         ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
 882         XSRETURN(1);
 883     } else {
 884         XSRETURN_UNDEF;
 885     }
 886 }
 887
 888 STATIC XS(setter);
 889 STATIC XS(setter)
 890 {
 891 #ifdef dVAR
 892     dVAR;
 893 #endif
 894     dXSARGS;
 895     dATTR;
 896
 897     if (items != 2)
 898         Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
 899
 900     SP -= items;
 901
 902     setter_common(aTHX_ ST(0), attr, ST(1));
 903
 904     ST(0) = ST(1); /* return value */
 905     XSRETURN(1);
 906 }
 907
 908 STATIC XS(accessor);
 909 STATIC XS(accessor)
 910 {
 911 #ifdef dVAR
 912     dVAR;
 913 #endif
 914     dXSARGS;
 915     dATTR;
 916
 917     if (items < 1)
 918         Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
 919
 920     SP -= items;
 921
 922     if (items > 1) {
 923         setter_common(aTHX_ ST(0), attr, ST(1));
 924         ST(0) = ST(1); /* return value */
 925     } else {
 926         SV *value = getter_common(aTHX_ ST(0), attr);
 927         if ( value ) {
 928             ST(0) = value;
 929         } else {
 930             XSRETURN_UNDEF;
 931         }
 932     }
 933
 934     XSRETURN(1);
 935 }
 936
 937 STATIC XS(predicate);
 938 STATIC XS(predicate)
 939 {
 940 #ifdef dVAR
 941     dVAR;
 942 #endif
 943     dXSARGS;
 944     dATTR;
 945
 946     if (items != 1)
 947         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 948
 949     SP -= items;
 950
 951     if ( has_slot_value(aTHX_ ST(0), attr) )
 952         XSRETURN_YES;
 953     else
 954         XSRETURN_NO;
 955 }
 956
 957 enum xs_body {
 958     xs_body_getter = 0,
 959     xs_body_setter,
 960     xs_body_accessor,
 961     xs_body_predicate,
 962     max_xs_body
 963 };
 964
 965 STATIC XSPROTO ((*xs_bodies[])) = {
 966     getter,
 967     setter,
 968     accessor,
 969     predicate,
 970 };
 971
 972 MODULE = Moose PACKAGE = Moose::XS
 973
 974 CV *
 975 new_sub(attr, name)
 976     INPUT:
 977         SV *attr;
 978         SV *name;
 979     ALIAS:
 980         new_getter    = xs_body_getter
 981         new_setter    = xs_body_setter
 982         new_accessor  = xs_body_accessor
 983         new_predicate = xs_body_predicate
 984     PREINIT:
 985         CV * cv;
 986     CODE:
 987         if ( ix >= max_xs_body )
 988             croak("Unknown Moose::XS body type");
 989
 990         if ( !sv_isobject(attr) )
 991             croak("'attr' must be a Moose::Meta::Attribute");
 992
 993         cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
 994
 995         if (cv == NULL)
 996             croak("Oi vey!");
 997
 998         /* associate CV with meta attr */
 999         stash_in_mg(aTHX_ (SV *)cv, attr);
1000
1001         /* this will be set on first call */
1002         XSANY.any_i32 = 0;
1003
1004         RETVAL = cv;
1005     OUTPUT:
1006         RETVAL
1007
1008
1009 MODULE = Moose  PACKAGE = Moose::XS::Meta::Instance
1010
1011 void
1012 DESTROY(self)
1013     INPUT:
1014         SV *self;
1015     PREINIT:
1016         MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
1017     CODE:
1018         delete_mi(aTHX_ mi);