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
  34
  35
  36
  37
  38 /* These two functions attach magic with no behavior to an SV.
  39  *
  40  * The stashed value is reference counted, and is destroyed when it's parent
  41  * object is destroyed.
  42  *
  43  * This is used to keep a reference the the meta attribute from a generated
  44  * method, and to cache the C struct based wrapper attached to the meta
  45  * instance.
  46  */
  47
  48 STATIC MGVTBL null_mg_vtbl = {
  49     NULL, /* get */
  50     NULL, /* set */
  51     NULL, /* len */
  52     NULL, /* clear */
  53     NULL, /* free */
  54 #if MGf_COPY
  55     NULL, /* copy */
  56 #endif /* MGf_COPY */
  57 #if MGf_DUP
  58     NULL, /* dup */
  59 #endif /* MGf_DUP */
  60 #if MGf_LOCAL
  61     NULL, /* local */
  62 #endif /* MGf_LOCAL */
  63 };
  64
  65 STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) {
  66     MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 );
  67     mg->mg_flags |= MGf_REFCOUNTED;
  68
  69     return mg;
  70 }
  71
  72 STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
  73     MAGIC *mg, *moremagic;
  74
  75     if (SvTYPE(sv) >= SVt_PVMG) {
  76         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  77             if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl))
  78                 break;
  79         }
  80         if (mg)
  81             return mg->mg_obj;
  82     }
  83
  84     return NULL;
  85 }
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95 /* The folloing data structures deal with type constraints */
  96
  97 /* this is an enum of the various kinds of constraint checking an attribute can
  98  * have.
  99  *
 100  * tc_cv is the fallback behavior (simply applying the
 101  * ->_compiled_type_constraint to the value, but other more optimal checks are
 102  *  implemented too. */
 103
 104 typedef enum {
 105     tc_none = 0, /* no type checking */
 106     tc_type, /* a builtin type to be checked by check_sv_type */
 107     tc_stash, /* a stash for a class, implements TypeConstraint::Class by comparing SvSTASH and then invoking C<isa> if necessary */
 108     tc_cv, /* applies a code reference to the value and checks for truth */
 109     tc_fptr, /* apply a C function pointer */
 110     tc_enum, /* TODO check that the value is in an allowed set of values (strings) */
 111 } tc_kind;
 112
 113 /* this is a enum of builtin type check. They are handled in a switch statement
 114  * in check_sv_type */
 115 typedef enum {
 116     Any, /* or item, or bool */
 117     Undef,
 118     Defined,
 119     Str, /* or value */
 120     Num,
 121     Int,
 122     GlobRef, /* SVt_PVGV */
 123     ArrayRef, /* SVt_PVAV */
 124     HashRef, /* SVt_PVHV */
 125     CodeRef, /* SVt_PVCV */
 126     Ref,
 127     ScalarRef,
 128     FileHandle, /* TODO */
 129     RegexpRef,
 130     Object,
 131     Role, /* TODO */
 132     ClassName,
 133 } TC;
 134
 135 /* auxillary pointer/int union used for constraint checking */
 136 typedef union {
 137     TC type; /* the builtin type number for tc_type */
 138     SV *sv; /* the cv for tc_cv, or the stash for tc_stash */
 139     OP *op; /* TODO not used */
 140     bool (*fptr)(pTHX_ SV *type_constraint, SV *sv); /* the function pointer for tc_fptr  FIXME aux data? */
 141 } TC_CHECK;
 142
 143
 144
 145
 146
 147
 148 /* The folloing data structures deal with type default value generation */
 149
 150 /* This is an enum for the various types of default value behaviors an
 151  * attribute can have */
 152
 153 typedef enum {
 154     default_none = 0, /* no default value */
 155     default_normal, /* code reference or scalar */
 156     default_builder, /* builder method */
 157     default_type, /* TODO enumerated type optimization (will call newHV, newAV etc to avoid calling a code ref for these simple cases) */
 158 } default_kind;
 159
 160 typedef union {
 161     SV *sv; /* The default value, or a code ref to generate one. If builder then this sv is applied as a method (stringified) */
 162     U32 type; /* TODO for default_type, should probably be one of SVt_PVAV/SVt_PVHV */
 163 } DEFAULT;
 164
 165
 166
 167
 168
 169
 170 /* the ATTR struct contains all the meta data for a Moose::Meta::Attribute for
 171  * a given meta instance
 172  *
 173  * flags determines the various behaviors
 174  *
 175  * This supports only one slot per attribute in the current implementation, but
 176  * slot_sv could contain an array
 177  *
 178  * A list of XSUBs that rely on this attr struct are cross indexed in the cvs
 179  * array, so that when the meta instance is destroyed the XSANY field will be
 180  * cleared. This is done in delete_mi
 181  * */
 182
 183 typedef struct {
 184     /* pointer to the MI this attribute is a part of the meta instance struct */
 185     struct mi *mi;
 186
 187     U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
 188
 189     /* slot access fields */
 190     SV *slot_sv; /* value of the slot (currently always slot name) */
 191     U32 slot_u32; /* for optimized access (precomputed hash, possibly something else) */
 192
 193     DEFAULT def; /* cv, value or other, depending on flags */
 194
 195     TC_CHECK tc_check; /* see TC_CHECK*/
 196     SV *type_constraint; /* Moose::Meta::TypeConstraint object */
 197
 198     CV *initializer; /* TODO */
 199     CV *trigger; /* TODO */
 200
 201     SV *meta_attr; /* the Moose::Meta::Attribute */
 202     AV *cvs; /* an array of CVs which use this attr, see delete_mi */
 203 } ATTR;
 204
 205 /* the flags integer is mapped as follows
 206  * instance     misc  reading  writing
 207  * 00000000 00000000 00000000 00000000
 208  *                                     writing
 209  *                             ^       trigger
 210  *                              ^      weak
 211  *                               ^     tc.sv is refcounted
 212  *                                 ^^^ tc_kind
 213  *                                ^    coerce
 214  *
 215  *                                     reading
 216  *                        ^^^          default_kind
 217  *                       ^             lazy
 218  *                      ^              def.sv is refcounted
 219  *
 220  *                                     misc
 221  *                 ^                   attr is required TODO
 222  *
 223  *                                     flags having to do with the instance layout (TODO, only hash supported for now)
 224  * ^^^^^^^                             if 0 then nothing special (just hash)? FIXME TBD
 225  */
 226
 227 #define ATTR_INSTANCE_MASK 0xff000000
 228 #define ATTR_READING_MASK  0x0000ff00
 229 #define ATTR_WRITING_MASK  0x000000ff
 230
 231 #define ATTR_MASK_TYPE 0x7
 232
 233 #define ATTR_MASK_DEFAULT 0x700
 234 #define ATTR_SHIFT_DEFAULT 8
 235
 236 #define ATTR_LAZY 0x800
 237 #define ATTR_DEFREFCNT 0x1000
 238
 239 #define ATTR_COERCE 0x8
 240 #define ATTR_TCREFCNT 0x10
 241 #define ATTR_WEAK 0x20
 242 #define ATTR_TRIGGER 0x40
 243
 244 #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK )
 245 #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY )
 246 #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE )
 247
 248 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
 249 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
 250
 251 #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr)
 252 #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 )
 253 #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 )
 254
 255
 256
 257 /* This unused (TODO) vtable will implement the meta instance protocol in terms
 258  * of function pointers to allow the XS accessors to be used with custom meta
 259  * instances in the future.
 260  *
 261  * We'll need to define a default instance of this vtable that uses call_sv,
 262  * too. */
 263
 264 /* FIXME define a vtable that does call_sv for fallback meta instance protocol */
 265 typedef struct {
 266     SV * (*get)(pTHX_ SV *self, ATTR *attr);
 267     void (*set)(pTHX_ SV *self, ATTR *attr, SV *value);
 268     bool * (*has)(pTHX_ SV *self, ATTR *attr);
 269     SV * (*delete)(pTHX_ SV *self, ATTR *attr);
 270 } instance_vtbl;
 271
 272 /* TODO this table describes the instance layout of the object. Not yet
 273  * implemented */
 274 typedef enum {
 275     hash = 0,
 276
 277     /* these are not yet implemented */
 278     array,
 279     fptr,
 280     cv,
 281     judy,
 282 } instance_types;
 283
 284
 285 /* this struct models the meta instance *and* meta attributes simultaneously.
 286  * It is a cache of the meta attribute behaviors for a given class or subclass
 287  * and can be parametrized on that level
 288  *
 289  *
 290  * An object pointing to this structure is kept in a refcounted magic inside
 291  * the meta instance it corresponds to. On C<invalidate_meta_instance> the meta
 292  * instance is destroyed, causing the proxy object to be destroyed, deleting
 293  * this structure, clearing the XSANY of all dependent attribute methods.
 294  *
 295  * The next invocation of an attribute method will eventually call get_attr,
 296  * which will call C<get_meta_instance> on the metaclass (recreating it in the
 297  * Class::MOP level), and cache a new MI struct inside it. Subsequent
 298  * invocations of get_attr will then search the MI for an ATTR matching the
 299  * meta_attribute of the attribute method */
 300 typedef struct mi {
 301     HV *stash;
 302
 303     /* slot access method */
 304     instance_types type; /* TODO only hashes supported currently */
 305     instance_vtbl *vtbl; /* TODO */
 306
 307     /* attr descriptors */
 308     I32 num_attrs;
 309     ATTR *attrs;
 310 } MI;
 311
 312
 313
 314
 315
 316
 317
 318
 319 /* these functions implement type constraint checking */
 320
 321 /* checks that the SV is a scalar ref */
 322 STATIC bool check_is_scalar_ref(SV *sv) {
 323     if( SvROK(sv) ) {
 324         switch (SvTYPE(SvRV(sv))) {
 325             case SVt_IV:
 326             case SVt_NV:
 327             case SVt_PV:
 328             case SVt_NULL:
 329                 return 1;
 330                 break;
 331             default:
 332                 return 0;
 333         }
 334     }
 335     return 0;
 336 }
 337
 338 /* checks that the SV is a ref to a certain SvTYPE, where type is in the table
 339  * above */
 340 STATIC bool check_reftype(TC type, SV *sv) {
 341     int svt;
 342
 343     if ( !SvROK(sv) )
 344         return 0;
 345
 346     switch (type) {
 347         case GlobRef:
 348             svt = SVt_PVGV;
 349             break;
 350         case ArrayRef:
 351             svt = SVt_PVAV;
 352             break;
 353         case HashRef:
 354             svt = SVt_PVHV;
 355             break;
 356         case CodeRef:
 357             svt = SVt_PVCV;
 358             break;
 359     }
 360
 361     return SvTYPE(SvRV(sv)) == svt;
 362 }
 363
 364 /* checks whether an SV is of a certain class
 365  * SvSTASH is first compared by pointer for efficiency */
 366 STATIC bool check_sv_class(pTHX_ HV *stash, SV *sv) {
 367     dSP;
 368     bool ret;
 369     SV *rv;
 370
 371     if (!sv)
 372         return 0;
 373     SvGETMAGIC(sv);
 374     if (!SvROK(sv))
 375         return 0;
 376     rv = (SV*)SvRV(sv);
 377     if (!SvOBJECT(rv))
 378         return 0;
 379     if (SvSTASH(rv) == stash)
 380         return 1;
 381
 382     ENTER;
 383     SAVETMPS;
 384     PUSHMARK(SP);
 385     XPUSHs(sv);
 386     XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0)));
 387     PUTBACK;
 388
 389     call_method("isa", G_SCALAR);
 390
 391     SPAGAIN;
 392     ret = SvTRUE(TOPs);
 393
 394     FREETMPS;
 395     LEAVE;
 396
 397     return ret;
 398 }
 399
 400 /* checks whether SV of of a known simple type. Most of the non parametrized
 401  * Moose core types are implemented here */
 402 STATIC bool check_sv_type (TC type, SV *sv) {
 403     if (!sv)
 404         return 0;
 405
 406     switch (type) {
 407         case Any:
 408             return 1;
 409             break;
 410         case Undef:
 411             return !SvOK(sv);
 412             break;
 413         case Defined:
 414             return SvOK(sv);
 415             break;
 416         case Str:
 417             return (SvOK(sv) && !SvROK(sv));
 418         case Num:
 419 #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
 420             if (!SvPOK(sv) && !SvPOKp(sv))
 421                 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
 422             else
 423 #endif
 424                 return looks_like_number(sv);
 425             break;
 426         case Int:
 427             if ( SvIOK(sv) ) {
 428                 return 1;
 429             } else if ( SvPOK(sv) ) {
 430                 /* FIXME i really don't like this */
 431                 int i;
 432                 STRLEN len;
 433                 char *pv = SvPV(sv, len);
 434                 char *end = pv + len;
 435                 char *tail = end;
 436
 437                 errno = 0;
 438                 i = strtol(pv, &tail, 0);
 439
 440                 if ( errno ) return 0;
 441
 442                 while ( tail != end ) {
 443                     if ( !isspace(*tail++) ) return 0;
 444                 }
 445
 446                 return 1;
 447             }
 448             return 0;
 449             break;
 450         case Ref:
 451             return SvROK(sv);
 452             break;
 453         case ScalarRef:
 454             return check_is_scalar_ref(sv);
 455             break;
 456         case ArrayRef:
 457         case HashRef:
 458         case CodeRef:
 459         case GlobRef:
 460             return check_reftype(type, sv);
 461             break;
 462         case RegexpRef:
 463             return ( sv_isobject(sv) && ( strEQ("Regexp", HvNAME_get(SvSTASH(SvRV(sv)))) ) );
 464             break;
 465         case Object:
 466             return ( sv_isobject(sv) && ( strNE("Regexp", HvNAME_get(SvSTASH(SvRV(sv)))) ) );
 467             break;
 468         case ClassName:
 469             if ( SvOK(sv) && !SvROK(sv) ) {
 470                 STRLEN len;
 471                 char *pv;
 472                 pv = SvPV(sv, len);
 473                 return ( gv_stashpvn(pv, len, 0) != NULL );
 474             }
 475             return 0;
 476             break;
 477         case FileHandle:
 478             croak("todo");
 479             break;
 480         default:
 481             croak("todo");
 482     }
 483
 484     return 0;
 485 }
 486
 487 /* invoke a CV on an SV and return SvTRUE of the result */
 488 STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) {
 489     bool ret;
 490     dSP;
 491
 492     ENTER;
 493     SAVETMPS;
 494     PUSHMARK(SP);
 495     XPUSHs(sv);
 496     PUTBACK;
 497
 498     call_sv(cv, G_SCALAR);
 499
 500     SPAGAIN;
 501     ret = SvTRUE(POPs);
 502
 503     PUTBACK;
 504     FREETMPS;
 505     LEAVE;
 506
 507     return ret;
 508 }
 509
 510 /* checks the type constraint for an SV based on the type constraint kind */
 511 STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
 512     switch (kind) {
 513         case tc_none:
 514             return 1;
 515             break;
 516         case tc_type:
 517             return check_sv_type(tc_check.type, sv);
 518             break;
 519         case tc_stash:
 520             return check_sv_class(aTHX_ (HV *)tc_check.sv, sv);
 521             break;
 522         case tc_fptr:
 523             return tc_check.fptr(aTHX_ type_constraint, sv);
 524             break;
 525         case tc_cv:
 526             return check_sv_cv(aTHX_ tc_check.sv, sv);
 527             break;
 528     }
 529
 530     croak("todo");
 531     return 0;
 532 }
 533
 534
 535 /* end of type constraint checking functions */
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545 /* Initialize the ATTR structure using positional arguments from Perl space. */
 546
 547 STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
 548     U32 flags = 0;
 549     U32 hash;
 550     STRLEN len;
 551     char *pv;
 552     I32 ix = av_len(desc);
 553     SV **params = AvARRAY(desc);
 554     SV *tc;
 555     SV *key;
 556
 557     attr->mi = mi;
 558
 559
 560     if ( ix != 12 )
 561         croak("wrong number of args (%d != 13)", ix + 1);
 562
 563     for ( ; ix >= 0; ix-- ) {
 564         if ( !params[ix] || params[ix] == &PL_sv_undef )
 565             croak("bad params");
 566     }
 567
 568
 569
 570     /* handle attribute slot array */
 571
 572     if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV )
 573         croak("slots is not an array");
 574
 575     if ( av_len((AV *)SvRV(params[1])) != 0 )
 576         croak("Only unary slots are supported at the moment");
 577
 578     /* calculate a hash from the slot */
 579     /* FIXME arrays etc should also be supported */
 580     key = *av_fetch((AV *)SvRV(params[1]), 0, 0);
 581     pv = SvPV(key, len);
 582     PERL_HASH(hash, pv, len);
 583
 584
 585
 586
 587     /* FIXME better organize these, positionals suck */
 588     if ( SvTRUE(params[2]) )
 589         flags |= ATTR_WEAK;
 590
 591     if ( SvTRUE(params[3]) )
 592         flags |= ATTR_COERCE;
 593
 594     if ( SvTRUE(params[4]) )
 595         flags |= ATTR_LAZY;
 596
 597
 598
 599     /* type constraint data */
 600
 601     tc = params[5];
 602
 603     if ( SvOK(tc) ) {
 604         int tc_kind = SvIV(params[6]);
 605         SV *data = params[7];
 606
 607         switch (tc_kind) {
 608             case tc_type:
 609                 attr->tc_check.type = SvIV(data);
 610                 break;
 611             case tc_stash:
 612                 flags |= ATTR_TCREFCNT;
 613                 attr->tc_check.sv = (SV *)gv_stashsv(data, 0);
 614                 break;
 615             case tc_cv:
 616                 flags |= ATTR_TCREFCNT;
 617                 attr->tc_check.sv = SvRV(data);
 618                 if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV )
 619                     croak("compiled type constraint is not a coderef");
 620                 break;
 621             default:
 622                 croak("todo");
 623         }
 624
 625         flags |= tc_kind;
 626     }
 627
 628
 629
 630     /* default/builder data */
 631
 632     if ( SvTRUE(params[10]) ) { /* has default */
 633         SV *sv = params[11];
 634
 635         if ( SvROK(sv) ) {
 636             attr->def.sv = SvRV(sv);
 637             if ( SvTYPE(attr->def.sv) != SVt_PVCV )
 638                 croak("compiled type constraint is not a coderef");
 639         } else {
 640             attr->def.sv = newSVsv(sv);
 641             sv_2mortal(attr->def.sv); /* in case of error soon, we refcnt inc it later after we're done checking params */
 642         }
 643
 644         flags |= ( ATTR_DEFREFCNT | ( default_normal << ATTR_SHIFT_DEFAULT ) );
 645     } else if ( SvOK(params[12]) ) { /* builder */
 646         attr->def.sv = newSVsv(params[12]);
 647         flags |= ( ATTR_DEFREFCNT | ( default_builder << ATTR_SHIFT_DEFAULT ) );
 648     }
 649
 650
 651
 652     attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL;
 653     if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV )
 654         croak("trigger is not a coderef");
 655
 656     attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL;
 657     if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV )
 658         croak("initializer is not a coderef");
 659
 660
 661
 662     /* now that we're done preparing/checking args and shit, so we finalize the
 663      * attr, increasing refcounts for any referenced data, and creating the CV
 664      * array */
 665
 666     attr->flags = flags;
 667
 668     /* copy the outer ref SV */
 669     attr->meta_attr       = newSVsv(params[0]);
 670     attr->type_constraint = newSVsv(tc);
 671
 672     /* increase the refcount for auxillary structures */
 673     SvREFCNT_inc(attr->trigger);
 674     SvREFCNT_inc(attr->initializer);
 675     if ( flags & ATTR_TCREFCNT )  SvREFCNT_inc(attr->tc_check.sv);
 676     if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc(attr->def.sv);
 677
 678     /* create a new SV for the hash key */
 679     attr->slot_sv = newSVpvn_share(pv, len, hash);
 680     attr->slot_u32 = hash;
 681
 682     /* cross refs to CVs which use this struct */
 683     attr->cvs = newAV();
 684 }
 685
 686 STATIC SV *new_mi (pTHX_ HV *stash, AV *attrs) {
 687     HV *mi_stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
 688     SV *sv_ptr = newSViv(0);
 689     SV *obj = sv_2mortal(sv_bless(newRV_noinc(sv_ptr), mi_stash));
 690     MI *mi;
 691     const I32 num_attrs = av_len(attrs) + 1;
 692
 693     Newx(mi, 1, MI);
 694
 695     mi->attrs = NULL;
 696     mi->stash = NULL;
 697     mi->num_attrs = 0;
 698
 699     /* set the pointer now, if we have any initialization errors it'll get
 700      * cleaned up because obj is mortal */
 701     sv_setiv(sv_ptr, PTR2IV(mi));
 702
 703     Newx(mi->attrs, num_attrs, ATTR);
 704
 705     SvREFCNT_inc_simple(stash);
 706     mi->stash = stash;
 707
 708     mi->type = 0; /* nothing else implemented yet */
 709
 710     /* initialize attributes */
 711     for ( ; mi->num_attrs < num_attrs; mi->num_attrs++ ) {
 712         SV **desc = av_fetch(attrs, mi->num_attrs, 0);
 713
 714         if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
 715             croak("Attribute descriptor has to be a hash reference");
 716         }
 717
 718         init_attr(mi, &mi->attrs[mi->num_attrs], (AV *)SvRV(*desc));
 719     }
 720
 721     return obj;
 722 }
 723
 724 STATIC void delete_attr (pTHX_ ATTR *attr) {
 725     I32 i;
 726     SV **cvs = AvARRAY(attr->cvs);
 727
 728     /* remove the pointers to this ATTR struct from all the the dependent CVs */
 729     for ( i = av_len(attr->cvs); i >= 0; i-- ) {
 730         CV *cv = (CV *)cvs[i];
 731         XSANY.any_i32 = 0;
 732     }
 733
 734     SvREFCNT_dec(attr->cvs);
 735     SvREFCNT_dec(attr->slot_sv);
 736     SvREFCNT_dec(attr->type_constraint);
 737     if ( attr->flags & ATTR_TCREFCNT )  SvREFCNT_dec(attr->tc_check.sv);
 738     if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv);
 739     SvREFCNT_dec(attr->initializer);
 740     SvREFCNT_dec(attr->trigger);
 741     SvREFCNT_dec(attr->meta_attr);
 742 }
 743
 744 STATIC void delete_mi (pTHX_ MI *mi) {
 745     SvREFCNT_dec(mi->stash);
 746
 747     while ( mi->num_attrs--) {
 748         ATTR *attr = &mi->attrs[mi->num_attrs];
 749         delete_attr(aTHX_ attr);
 750     }
 751
 752     if ( mi->attrs ) Safefree(mi->attrs);
 753     Safefree(mi);
 754 }
 755
 756
 757
 758
 759 /* these functions call Perl-space for MOP methods, helpers etc */
 760
 761
 762 /* wow, so much code for the equivalent of
 763  * $attr->associated_class->get_meta_instance */
 764 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
 765     dSP;
 766     I32 count;
 767     SV *mi;
 768
 769     if ( !meta_attr )
 770         croak("No attr found in magic!");
 771
 772     ENTER;
 773     SAVETMPS;
 774     PUSHMARK(SP);
 775
 776     XPUSHs(meta_attr);
 777
 778     PUTBACK;
 779     count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
 780
 781     if ( count != 1 )
 782         croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
 783
 784     SPAGAIN;
 785     mi = POPs;
 786
 787     SvREFCNT_inc(mi);
 788
 789     PUTBACK;
 790     FREETMPS;
 791     LEAVE;
 792
 793     return sv_2mortal(mi);
 794 }
 795
 796 /* gets a class and an array of attr parameters */
 797 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
 798     dSP;
 799     I32 count;
 800     SV *mi;
 801     SV *class;
 802     SV *attrs;
 803     HV *stash;
 804
 805     ENTER;
 806     SAVETMPS;
 807     PUSHMARK(SP);
 808
 809     XPUSHs(perl_mi);
 810
 811     PUTBACK;
 812     count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
 813
 814     if ( count != 2 )
 815         croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
 816
 817     SPAGAIN;
 818     attrs = POPs;
 819     class = POPs;
 820
 821     PUTBACK;
 822
 823     stash = gv_stashsv(class, 0);
 824
 825     mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
 826     SvREFCNT_inc(mi);
 827
 828     FREETMPS;
 829     LEAVE;
 830
 831     return sv_2mortal(mi);
 832 }
 833
 834
 835
 836 /* locate an ATTR for a MOP level attribute inside an MI */
 837 STATIC ATTR *mi_find_attr(SV *mi_obj, SV *meta_attr) {
 838     I32 ix;
 839     MI *mi = INT2PTR(MI *, SvIV(SvRV(mi_obj)));
 840
 841     for ( ix = 0; ix < mi->num_attrs; ix++ ) {
 842         if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
 843             return &mi->attrs[ix];
 844         }
 845     }
 846
 847     croak("Attr %x not found in meta instance of %s", SvRV(meta_attr) /* SvPV_force_nomg(sv_2mortal(newSVsv(meta_attr))) */, HvNAME_get(mi->stash) );
 848     return NULL;
 849 }
 850
 851 /* returns the ATTR for a CV:
 852  *
 853  * 1. get the Moose::Meta::Attribute using get_stashed_in_mg from the CV itself
 854  * 2. get the meta instance by calling $attr->associated_class->get_meta_instance
 855  * 3. get the MI by using get_stashed_in_mg from the meta instance, creating it if necessary
 856  * 4. search for the appropriate ATTR in the MI using mi_find_attr
 857  */
 858 STATIC ATTR *get_attr(pTHX_ CV *cv) {
 859     SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv);
 860     SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
 861     SV *mi_obj = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
 862
 863     if (!mi_obj) {
 864         mi_obj = perl_mi_to_c_mi(aTHX_ perl_mi);
 865         stash_in_mg(aTHX_ SvRV(perl_mi), mi_obj);
 866     }
 867
 868     return mi_find_attr(mi_obj, meta_attr);
 869 }
 870
 871 /* Cache a pointer to the appropriate ATTR in the XSANY of the CV, using
 872  * get_attr */
 873 STATIC ATTR *define_attr (pTHX_ CV *cv) {
 874     ATTR *attr = get_attr(aTHX_ cv);
 875     assert(attr);
 876
 877     XSANY.any_i32 = PTR2IV(attr);
 878
 879     SvREFCNT_inc(cv);
 880     av_push( attr->cvs, (SV *)cv );
 881
 882     return attr;
 883 }
 884
 885
 886
 887
 888
 889
 890
 891 STATIC void weaken(pTHX_ SV *sv) {
 892 #ifdef SvWEAKREF
 893         sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
 894 #else
 895         croak("weak references are not implemented in this release of perl");
 896 #endif
 897 }
 898
 899
 900
 901
 902
 903
 904 /* meta instance protocol */
 905
 906 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
 907     HE *he;
 908
 909     assert(self);
 910     assert(SvROK(self));
 911     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 912
 913     assert( ATTR_DUMB_INSTANCE(attr) );
 914
 915     if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
 916         return HeVAL(he);
 917     else
 918         return NULL;
 919 }
 920
 921 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
 922     HE *he;
 923     SV *copy;
 924
 925     assert(self);
 926     assert(SvROK(self));
 927     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 928
 929     assert( ATTR_DUMB_INSTANCE(attr) );
 930
 931     copy = newSVsv(value);
 932
 933     he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
 934
 935     if (he != NULL) {
 936         if ( ATTR_ISWEAK(attr) )
 937             weaken(aTHX_ HeVAL(he));
 938     } else {
 939         SvREFCNT_dec(copy);
 940         croak("Hash store failed.");
 941     }
 942 }
 943
 944 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
 945     assert(self);
 946     assert(SvROK(self));
 947     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 948
 949     assert( ATTR_DUMB_INSTANCE(attr) );
 950
 951     return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
 952 }
 953
 954 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
 955     assert(self);
 956     assert(SvROK(self));
 957     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 958
 959     assert( ATTR_DUMB_INSTANCE(attr) );
 960
 961     return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
 962 }
 963
 964
 965
 966
 967
 968
 969 /* Shared functionality for readers/writers/accessors, this roughly corresponds
 970  * to the methods of Moose::Meta::Attribute on the instance
 971  * (get_value/set_value, default value handling, etc) */
 972
 973 STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value);
 974
 975 STATIC SV *call_builder (pTHX_ SV *self, ATTR *attr) {
 976     SV *sv;
 977     dSP;
 978
 979     ENTER;
 980     SAVETMPS;
 981     PUSHMARK(SP);
 982
 983     XPUSHs(self);
 984
 985     /* we invoke the builder as a stringified method. This will not work for
 986      * $obj->$coderef etc, for that we need to use 'default' */
 987     PUTBACK;
 988     call_method(SvPV_nolen(attr->def.sv), G_SCALAR);
 989     SPAGAIN;
 990
 991     /* the value is a mortal with a refcount of 1, so we need to keep it around */
 992     sv = POPs;
 993     SvREFCNT_inc(sv);
 994
 995     PUTBACK;
 996     FREETMPS;
 997     LEAVE;
 998
 999     return sv_2mortal(sv);
1000 }
1001
1002
1003 /* Returns an SV for the default value. Should be copied by the caller because
1004  * it's either an alias for a simple value, or a mortal from cv/builder */
1005 STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) {
1006     switch ( ATTR_DEFAULT(attr) ) {
1007         case default_none:
1008             return NULL;
1009             break;
1010         case default_builder:
1011             return call_builder(aTHX_ self, attr);
1012             break;
1013         case default_normal:
1014             if ( SvROK(attr->def.sv) ) {
1015                 printf("CV default\n");
1016                 croak("todo");
1017             } else {
1018                 printf("simple value\n");
1019                 return attr->def.sv; /* will be copied by set for lazy, and by reader for both cases */
1020             }
1021             break;
1022         case default_type:
1023             croak("todo");
1024             break;
1025     }
1026
1027     return NULL;
1028 }
1029
1030 /* $attr->get_value($self), will vivify lazy values if needed
1031  * returns an alias to the sv that is copied in the reader/writer/accessor code
1032  * */
1033 STATIC SV *attr_get_value(pTHX_ SV *self, ATTR *attr) {
1034     SV *value = get_slot_value(aTHX_ self, attr);
1035
1036     if ( value ) {
1037         return value;
1038     } else if ( ATTR_ISLAZY(attr) ) {
1039         value = get_default(aTHX_ self, attr);
1040         attr_set_value(aTHX_ self, attr, value);
1041         return value;
1042     }
1043
1044     return NULL;
1045 }
1046
1047 /* $attr->set_value($self) */
1048 STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value) {
1049     if ( ATTR_TYPE(attr) ) {
1050         if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) )
1051             croak("Bad param");
1052     }
1053
1054     set_slot_value(aTHX_ self, attr, value);
1055 }
1056
1057
1058
1059
1060
1061
1062
1063 /* Perl-space level functionality
1064  *
1065  * These subs are installed by new_sub's various aliases as the bodies of the
1066  * new XSUBs
1067  * */
1068
1069
1070
1071 /* This macro is used in the XS subs to set up the 'attr' variable.
1072  *
1073  * if XSANY is NULL then define_attr is called on the CV, to set the pointer
1074  * to the ATTR struct.
1075  * */
1076 #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv))
1077
1078
1079 STATIC XS(reader);
1080 STATIC XS(reader)
1081 {
1082 #ifdef dVAR
1083     dVAR;
1084 #endif
1085     dXSARGS;
1086     dATTR;
1087     SV *value;
1088
1089     if (items != 1)
1090         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
1091
1092     SP -= items;
1093
1094     value = attr_get_value(aTHX_ ST(0), attr);
1095
1096     if (value) {
1097         ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
1098         XSRETURN(1);
1099     } else {
1100         XSRETURN_UNDEF;
1101     }
1102 }
1103
1104 STATIC XS(writer);
1105 STATIC XS(writer)
1106 {
1107 #ifdef dVAR
1108     dVAR;
1109 #endif
1110     dXSARGS;
1111     dATTR;
1112
1113     if (items != 2)
1114         Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
1115
1116     SP -= items;
1117
1118     attr_set_value(aTHX_ ST(0), attr, ST(1));
1119
1120     ST(0) = ST(1); /* return value */
1121     XSRETURN(1);
1122 }
1123
1124 STATIC XS(accessor);
1125 STATIC XS(accessor)
1126 {
1127 #ifdef dVAR
1128     dVAR;
1129 #endif
1130     dXSARGS;
1131     dATTR;
1132
1133     if (items < 1)
1134         Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
1135
1136     SP -= items;
1137
1138     if (items > 1) {
1139         attr_set_value(aTHX_ ST(0), attr, ST(1));
1140         ST(0) = ST(1); /* return value */
1141     } else {
1142         SV *value = attr_get_value(aTHX_ ST(0), attr);
1143         if ( value ) {
1144             ST(0) = value;
1145         } else {
1146             XSRETURN_UNDEF;
1147         }
1148     }
1149
1150     XSRETURN(1);
1151 }
1152
1153 STATIC XS(predicate);
1154 STATIC XS(predicate)
1155 {
1156 #ifdef dVAR
1157     dVAR;
1158 #endif
1159     dXSARGS;
1160     dATTR;
1161
1162     if (items != 1)
1163         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
1164
1165     SP -= items;
1166
1167     if ( has_slot_value(aTHX_ ST(0), attr) )
1168         XSRETURN_YES;
1169     else
1170         XSRETURN_NO;
1171 }
1172
1173 enum xs_body {
1174     xs_body_reader = 0,
1175     xs_body_writer,
1176     xs_body_accessor,
1177     xs_body_predicate,
1178     max_xs_body
1179 };
1180
1181 STATIC XSPROTO ((*xs_bodies[])) = {
1182     reader,
1183     writer,
1184     accessor,
1185     predicate,
1186 };
1187
1188 MODULE = Moose PACKAGE = Moose::XS
1189 PROTOTYPES: ENABLE
1190
1191 CV *
1192 new_sub(attr, name)
1193     INPUT:
1194         SV *attr;
1195         SV *name;
1196     PROTOTYPE: $;$
1197     ALIAS:
1198         new_reader    = xs_body_reader
1199         new_writer    = xs_body_writer
1200         new_accessor  = xs_body_accessor
1201         new_predicate = xs_body_predicate
1202     PREINIT:
1203         CV * cv;
1204     CODE:
1205         if ( ix >= max_xs_body )
1206             croak("Unknown Moose::XS body type");
1207
1208         if ( !sv_isobject(attr) )
1209             croak("'attr' must be a Moose::Meta::Attribute");
1210
1211         cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
1212
1213         if (cv == NULL)
1214             croak("Oi vey!");
1215
1216         /* associate CV with meta attr */
1217         stash_in_mg(aTHX_ (SV *)cv, attr);
1218
1219         /* this will be set on first call */
1220         XSANY.any_i32 = 0;
1221
1222         RETVAL = cv;
1223     OUTPUT:
1224         RETVAL
1225
1226
1227 MODULE = Moose  PACKAGE = Moose::XS::Meta::Instance
1228 PROTOTYPES: DISABLE
1229
1230 void
1231 DESTROY(self)
1232     INPUT:
1233         SV *self;
1234     PREINIT:
1235         MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
1236     CODE:
1237         if ( mi )
1238             delete_mi(aTHX_ mi);
1239
1240
1241 MODULE = Moose  PACKAGE = Moose::XS::TypeConstraints
1242 PROTOTYPES: ENABLE
1243
1244 bool
1245 _check_type(sv)
1246     INPUT:
1247         SV* sv
1248     ALIAS:
1249         Any = Any
1250         Item = Any
1251         Bool = Any
1252         Undef = Undef
1253         Defined = Defined
1254         Str = Str
1255         Value = Str
1256         Num = Num
1257         Int = Int
1258         GlobRef = GlobRef
1259         ArrayRef = ArrayRef
1260         HashRef = HashRef
1261         CodeRef = CodeRef
1262         Ref = Ref
1263         ScalarRef = ScalarRef
1264         FileHandle = FileHandle
1265         RegexpRef = RegexpRef
1266         Object = Object
1267         Role = Role
1268         ClassName = ClassName
1269     CODE:
1270         RETVAL = check_sv_type(ix, sv);
1271     OUTPUT:
1272         RETVAL
1273
1274 bool
1275 ObjectOfType(sv, class)
1276     INPUT:
1277         SV* sv
1278         SV* class
1279     PREINIT:
1280         HV *stash = gv_stashsv(class, 0);
1281     CODE:
1282         RETVAL = check_sv_class(aTHX_ stash, sv);
1283     OUTPUT:
1284         RETVAL