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