Moose.xs

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