Moose.xs

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