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