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