Moose.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 /* FIXME
   6  * needs to be made into Moose::XS::Meta::Instance and Meta::Slot for the
   7  * metadata, with a proper destructor. XSANY still points to this struct, but
   8  * it is shared by all functions of the same type.
   9  *
  10  * Instance contains SvSTASH, and ATTR slots[]
  11  *
  12  * On recreation of the meta instance we refresh the ATTR value of all the CVs
  13  * we installed
  14  *
  15  * need a good way to handle time between invalidate and regeneration (just
  16  * check XSANY and call get_meta_instance if null?)
  17  */
  18
  19 /* FIXME
  20  * type constraints are already implemented by konobi
  21  * should be trivial to do coercions for the core types, too
  22  *
  23  * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then*
  24  * call ->isa (should handle vast majority of cases)
  25  *
  26  * base parametrized types are also trivial
  27  *
  28  * ClassName is get_stathpvn
  29  */
  30
  31 /* FIXME
  32  * for a constructor we have ATTR *attrs, and iterate that, removing init_arg
  33  * we can preallocate the structure to the right size (maybe even with the
  34  * right HEs?), and do various other prehashing hacks to gain speed
  35  * */
  36
  37 /* FIXME
  38  * delegations and attribute helpers:
  39  *
  40  * typedef struct {
  41  *      ATTR *attr;
  42  *      pv *method;
  43  * } delegation;
  44  *
  45  * typedef struct {
  46  *      ATTR *attr;
  47  *      I32 *type; // hash, array, whatever + vtable for operation
  48  * } attributehelper;
  49  */
  50
  51
  52 STATIC MGVTBL null_mg_vtbl = {
  53     NULL, /* get */
  54     NULL, /* set */
  55     NULL, /* len */
  56     NULL, /* clear */
  57     NULL, /* free */
  58 #if MGf_COPY
  59     NULL, /* copy */
  60 #endif /* MGf_COPY */
  61 #if MGf_DUP
  62     NULL, /* dup */
  63 #endif /* MGf_DUP */
  64 #if MGf_LOCAL
  65     NULL, /* local */
  66 #endif /* MGf_LOCAL */
  67 };
  68
  69 STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) {
  70     MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 );
  71     mg->mg_flags |= MGf_REFCOUNTED;
  72
  73     return mg;
  74 }
  75
  76 STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
  77     MAGIC *mg, *moremagic;
  78
  79     if (SvTYPE(sv) >= SVt_PVMG) {
  80         for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
  81             if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl))
  82                 break;
  83         }
  84         if (mg)
  85             return mg->mg_obj;
  86     }
  87
  88     return NULL;
  89 }
  90
  91
  92 typedef enum {
  93     Any = 0,
  94     Item,
  95         Bool,
  96         Maybe, /* [`a] */
  97         Undef,
  98         Defined,
  99             Value,
 100                 Num,
 101                     Int,
 102                 Str,
 103                     ClassName,
 104             Ref,
 105                 ScalarRef,
 106                 ArrayRef, /* [`a] */
 107                 HashRef, /* [`a] */
 108                 CodeRef,
 109                 RegexpRef,
 110                 GlobRef,
 111                     FileHandle,
 112                 Object,
 113                     Role,
 114
 115     /* XS only types */
 116     Class,
 117
 118     max_TC
 119 } TC;
 120
 121 typedef union {
 122     TC type;
 123     CV *cv;
 124     HV *stash;
 125     OP *op;
 126 } TC_CHECK;
 127
 128 typedef enum {
 129     tc_none = 0,
 130     tc_type,
 131     tc_cv,
 132     tc_stash,
 133     tc_op,
 134 } tc_kind;
 135
 136 typedef union {
 137     char *builder;
 138     SV *value;
 139     CV *sub;
 140     OP *op;
 141     U32 type;
 142 } DEFAULT;
 143
 144 typedef enum {
 145     default_none = 0,
 146     default_type,
 147     default_builder,
 148     default_value,
 149     default_sub,
 150     default_op,
 151 } default_kind;
 152
 153 typedef struct {
 154     /* the meta instance struct */
 155     struct mi *mi;
 156
 157     U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
 158
 159     /* slot access fields */
 160     SV *slot_sv; /* value of the slot (slot name presumably) */
 161     U32 slot_u32; /* for optimized access (precomputed hash or otherr) */
 162
 163     DEFAULT def; /* cv, value or other, depending on flags */
 164
 165     TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
 166     SV *type_constraint; /* meta attr */
 167
 168     CV *initializer;
 169     CV *trigger;
 170
 171     SV *meta_attr; /* the meta attr object */
 172     AV *cvs; /* CVs which use this attr */
 173 } ATTR;
 174
 175 /* slot flags:
 176  * instance           reading  writing
 177  * 00000000 00000000 00000000 00000000
 178  *                              ^      trigger
 179  *                               ^     weak
 180  *                                 ^^^ tc_kind
 181  *                                ^    coerce
 182  *                        ^^^          default_kind
 183  *                       ^             lazy
 184  *                 ^                   required
 185  * ^^^^^^^                             if 0 then nothing special (just hash)? FIXME TBD
 186  */
 187
 188 #define ATTR_INSTANCE_MASK 0xff000000
 189 #define ATTR_READING_MASK  0x0000ff00
 190 #define ATTR_WRITING_MASK  0x000000ff
 191
 192 #define ATTR_MASK_TYPE 0x7
 193
 194 #define ATTR_MASK_DEFAULT 0x700
 195 #define ATTR_SHIFT_DEAFULT 8
 196
 197 #define ATTR_LAZY 0x800
 198
 199 #define ATTR_COERCE 0x08
 200 #define ATTR_WEAK 0x10
 201 #define ATTR_TRIGGER 0x10
 202
 203 #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK )
 204 #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY )
 205 #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE )
 206
 207 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
 208 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
 209
 210 #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr)
 211 #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 )
 212 #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 )
 213
 214 #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv))
 215
 216
 217 /* FIXME define a vtable that does call_sv */
 218 typedef struct {
 219     SV * (*get)(pTHX_ SV *self, ATTR *attr);
 220     void (*set)(pTHX_ SV *self, ATTR *attr, SV *value);
 221     bool * (*has)(pTHX_ SV *self, ATTR *attr);
 222     SV * (*delete)(pTHX_ SV *self, ATTR *attr);
 223 } instance_vtbl;
 224
 225
 226 typedef enum {
 227     hash = 0,
 228
 229     /* these are not yet implemented */
 230     array,
 231     fptr,
 232     cv,
 233     judy,
 234 } instance_types;
 235
 236 typedef struct mi {
 237     HV *stash;
 238
 239     /* slot access method */
 240     instance_types type;
 241     instance_vtbl *vtbl;
 242
 243     /* attr descriptors */
 244     I32 num_attrs;
 245     ATTR *attrs;
 246 } MI;
 247
 248
 249 STATIC void init_attr (MI *mi, ATTR *attr, HV *desc) {
 250     U32 hash;
 251     STRLEN len;
 252     SV **key = hv_fetchs(desc, "key", 0);
 253     SV **meta_attr = hv_fetchs(desc, "meta", 0);
 254     char *pv;
 255
 256     if ( !meta_attr ) croak("'meta' is required");
 257
 258     attr->meta_attr = *meta_attr;
 259
 260     attr->mi = mi;
 261
 262     attr->flags = 0;
 263
 264
 265     /* if type == hash */
 266     /* prehash the key */
 267     if ( !key ) croak("'key' is required");
 268
 269     pv = SvPV(*key, len);
 270
 271     PERL_HASH(hash, pv, len);
 272
 273     attr->slot_sv = newSVpvn_share(pv, len, hash);
 274     attr->slot_u32 = hash;
 275
 276     attr->def.type = 0;
 277
 278     attr->tc_check.type = 0;
 279     attr->type_constraint = NULL;
 280
 281
 282     attr->initializer = NULL;
 283     attr->trigger = NULL;
 284
 285     /* cross refs to CVs which use this struct */
 286     attr->cvs = newAV();
 287 }
 288
 289 STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) {
 290     MI *mi;
 291     I32 ix;
 292     const I32 num = av_len(attrs) + 1;
 293
 294     Newx(mi, 1, MI);
 295
 296     SvREFCNT_inc_simple(stash);
 297     mi->stash = stash;
 298
 299     mi->type = 0; /* nothing else implemented yet */
 300
 301     /* initialize attributes */
 302     mi->num_attrs = num;
 303     Newx(mi->attrs, num, ATTR);
 304     for ( ix = 0; ix < num; ix++ ) {
 305         SV **desc = av_fetch(attrs, ix, 0);
 306
 307         if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVHV) ) {
 308             croak("Attribute descriptor has to be a hash reference");
 309         }
 310
 311         init_attr(mi, &mi->attrs[ix], (HV *)SvRV(*desc));
 312     }
 313
 314     return mi;
 315 }
 316
 317 STATIC SV *new_mi_obj (pTHX_ MI *mi) {
 318     return sv_bless( newRV_noinc(newSViv(PTR2IV(mi))), gv_stashpvs("Moose::XS::Meta::Instance", 0) );
 319 }
 320
 321 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
 322     dSP;
 323     I32 count;
 324     SV *mi;
 325
 326     if ( !meta_attr )
 327         croak("No attr found in magic!");
 328
 329     ENTER;
 330     SAVETMPS;
 331     PUSHMARK(SP);
 332     XPUSHs(meta_attr);
 333     PUTBACK;
 334     count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
 335
 336     if ( count != 1 )
 337         croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
 338
 339     SPAGAIN;
 340     mi = POPs;
 341
 342     SvREFCNT_inc(mi);
 343
 344     PUTBACK;
 345     FREETMPS;
 346     LEAVE;
 347
 348     return mi;
 349 }
 350
 351 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
 352     dSP;
 353     I32 count;
 354     MI *mi = NULL;
 355     SV *class;
 356     SV *attrs;
 357     HV *stash;
 358
 359     ENTER;
 360     SAVETMPS;
 361     PUSHMARK(SP);
 362     XPUSHs(perl_mi);
 363     PUTBACK;
 364     count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
 365
 366     if ( count != 2 )
 367         croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
 368
 369     SPAGAIN;
 370     attrs = POPs;
 371     class = POPs;
 372
 373     PUTBACK;
 374
 375     stash = gv_stashsv(class, 0);
 376
 377     mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
 378
 379     FREETMPS;
 380     LEAVE;
 381
 382     return new_mi_obj(aTHX_ mi);
 383 }
 384
 385 STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
 386     I32 ix;
 387
 388     for ( ix = 0; ix <= mi->num_attrs; ix++ ) {
 389         if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
 390             return &mi->attrs[ix];
 391         }
 392     }
 393
 394     sv_dump(meta_attr);
 395     croak("Attr not found");
 396     return NULL;
 397 }
 398
 399 STATIC ATTR *get_attr(pTHX_ CV *cv) {
 400     SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv);
 401     SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
 402     SV *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
 403     MI *mi;
 404
 405     if (!c_mi) {
 406         c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
 407         stash_in_mg(aTHX_ perl_mi, c_mi);
 408     }
 409
 410     sv_2mortal(perl_mi);
 411
 412     mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
 413
 414     return mi_find_attr(mi, meta_attr);
 415 }
 416
 417 STATIC ATTR *define_attr (pTHX_ CV *cv) {
 418     ATTR *attr = get_attr(aTHX_ cv);
 419     assert(attr);
 420
 421     XSANY.any_i32 = PTR2IV(attr);
 422
 423     av_push( attr->cvs, (SV *)cv );
 424
 425     return attr;
 426 }
 427
 428 STATIC void weaken(pTHX_ SV *sv) {
 429 #ifdef SvWEAKREF
 430         sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
 431 #else
 432         croak("weak references are not implemented in this release of perl");
 433 #endif
 434 }
 435
 436
 437 /* meta instance protocol */
 438
 439 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
 440     HE *he;
 441
 442     assert(self);
 443     assert(SvROK(self));
 444     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 445
 446     assert( ATTR_DUMB_INSTANCE(attr) );
 447
 448     if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
 449         return HeVAL(he);
 450     else
 451         return NULL;
 452 }
 453
 454 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
 455     HE *he;
 456
 457     assert(self);
 458     assert(SvROK(self));
 459     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 460
 461     assert( ATTR_DUMB_INSTANCE(attr) );
 462
 463     SvREFCNT_inc(value);
 464
 465     he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32);
 466     if (he != NULL) {
 467         if ( ATTR_ISWEAK(attr) )
 468             weaken(aTHX_ HeVAL(he)); /* actually only needed once at HE creation time */
 469     } else {
 470         croak("Hash store failed.");
 471     }
 472 }
 473
 474 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
 475     assert(self);
 476     assert(SvROK(self));
 477     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 478
 479     assert( ATTR_DUMB_INSTANCE(attr) );
 480
 481     return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
 482 }
 483
 484 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
 485     assert(self);
 486     assert(SvROK(self));
 487     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 488
 489     assert( ATTR_DUMB_INSTANCE(attr) );
 490
 491     return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
 492 }
 493
 494
 495 /* simple high level api */
 496
 497 STATIC XS(getter);
 498 STATIC XS(getter)
 499 {
 500 #ifdef dVAR
 501     dVAR;
 502 #endif
 503     dXSARGS;
 504     dATTR;
 505     SV *value;
 506
 507     if (items != 1)
 508         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 509
 510     SP -= items;
 511
 512     assert( ATTR_DUMB_READER(attr) );
 513
 514     value = get_slot_value(aTHX_ ST(0), attr);
 515
 516     if (value) {
 517         ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
 518         XSRETURN(1);
 519     } else {
 520         XSRETURN_UNDEF;
 521     }
 522 }
 523
 524 STATIC XS(setter);
 525 STATIC XS(setter)
 526 {
 527 #ifdef dVAR
 528     dVAR;
 529 #endif
 530     dXSARGS;
 531     dATTR;
 532
 533     if (items != 2)
 534         Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
 535
 536     SP -= items;
 537
 538     assert( ATTR_DUMB_WRITER(attr) );
 539
 540     set_slot_value(aTHX_ ST(0), attr, ST(1));
 541
 542     ST(0) = ST(1); /* return value */
 543     XSRETURN(1);
 544 }
 545
 546 STATIC XS(accessor);
 547 STATIC XS(accessor)
 548 {
 549 #ifdef dVAR
 550     dVAR;
 551 #endif
 552     dXSARGS;
 553     dATTR;
 554
 555     if (items < 1)
 556         Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
 557
 558     SP -= items;
 559
 560     if (items > 1) {
 561         assert( ATTR_DUMB_READER(attr) );
 562         set_slot_value(aTHX_ ST(0), attr, ST(1));
 563         ST(0) = ST(1); /* return value */
 564     } else {
 565         assert( ATTR_DUMB_WRITER(attr) );
 566         SV *value = get_slot_value(aTHX_ ST(0), attr);
 567         if ( value ) {
 568             ST(0) = value;
 569         } else {
 570             XSRETURN_UNDEF;
 571         }
 572     }
 573
 574     XSRETURN(1);
 575 }
 576
 577 STATIC XS(predicate);
 578 STATIC XS(predicate)
 579 {
 580 #ifdef dVAR
 581     dVAR;
 582 #endif
 583     dXSARGS;
 584     dATTR;
 585
 586     if (items != 1)
 587         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 588
 589     SP -= items;
 590
 591     if ( has_slot_value(aTHX_ ST(0), attr) )
 592         XSRETURN_YES;
 593     else
 594         XSRETURN_NO;
 595 }
 596
 597 enum xs_body {
 598     xs_body_getter = 0,
 599     xs_body_setter,
 600     xs_body_accessor,
 601     xs_body_predicate,
 602     max_xs_body
 603 };
 604
 605 STATIC XSPROTO ((*xs_bodies[])) = {
 606     getter,
 607     setter,
 608     accessor,
 609     predicate,
 610 };
 611
 612 MODULE = Moose PACKAGE = Moose::XS
 613
 614 CV *
 615 new_sub(attr, name)
 616     INPUT:
 617         SV *attr;
 618         SV *name;
 619     ALIAS:
 620         new_getter    = xs_body_getter
 621         new_setter    = xs_body_setter
 622         new_accessor  = xs_body_accessor
 623         new_predicate = xs_body_predicate
 624     PREINIT:
 625         CV * cv;
 626     CODE:
 627         if ( ix >= max_xs_body )
 628             croak("Unknown Moose::XS body type");
 629
 630         if ( !sv_isobject(attr) )
 631             croak("'attr' must be a Moose::Meta::Attribute");
 632
 633         cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
 634
 635         if (cv == NULL)
 636             croak("Oi vey!");
 637
 638         /* associate CV with meta attr */
 639         stash_in_mg(aTHX_ (SV *)cv, attr);
 640
 641         /* this will be set on first call */
 642         XSANY.any_i32 = 0;
 643
 644         RETVAL = cv;
 645     OUTPUT:
 646         RETVAL
 647
 648
 649 MODULE = Moose  PACKAGE = Moose::XS::Meta::Instance
 650
 651 void
 652 DESTROY(self)
 653     INPUT:
 654         SV *self;
 655     PREINIT:
 656         MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
 657     CODE:
 658         /* foreach attr ( delete cvs XSANY ), free attrs free mi */