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
  70
  71 typedef enum {
  72     Any = 0,
  73     Item,
  74         Bool,
  75         Maybe, /* [`a] */
  76         Undef,
  77         Defined,
  78             Value,
  79                 Num,
  80                     Int,
  81                 Str,
  82                     ClassName,
  83             Ref,
  84                 ScalarRef,
  85                 ArrayRef, /* [`a] */
  86                 HashRef, /* [`a] */
  87                 CodeRef,
  88                 RegexpRef,
  89                 GlobRef,
  90                     FileHandle,
  91                 Object,
  92                     Role,
  93
  94     /* XS only types */
  95     Class,
  96
  97     max_TC
  98 } TC;
  99
 100 typedef union {
 101     TC type;
 102     CV *cv;
 103     HV *stash;
 104     OP *op;
 105 } TC_CHECK;
 106
 107 typedef enum {
 108     tc_none = 0,
 109     tc_type,
 110     tc_cv,
 111     tc_stash,
 112     tc_op,
 113 } tc_kind;
 114
 115 typedef union {
 116     char *builder;
 117     SV *value;
 118     CV *sub;
 119     OP *op;
 120     U32 type;
 121 } DEFAULT;
 122
 123 typedef enum {
 124     default_none = 0,
 125     default_type,
 126     default_builder,
 127     default_value,
 128     default_sub,
 129     default_op,
 130 } default_kind;
 131
 132 typedef struct {
 133     /* the meta instance struct */
 134     struct mi *mi;
 135
 136     U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
 137
 138     /* slot access fields */
 139     SV *slot_sv; /* value of the slot (slot name presumably) */
 140     U32 slot_u32; /* for optimized access (precomputed hash or otherr) */
 141
 142     DEFAULT def; /* cv, value or other, depending on flags */
 143
 144     TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
 145     SV *type_constraint; /* meta attr */
 146
 147     CV *initializer;
 148     CV *trigger;
 149
 150     SV *attr; /* the meta attr object */
 151     AV *cvs; /* CVs which use this attr */
 152 } ATTR;
 153
 154 /* slot flags:
 155  * instance           reading  writing
 156  * 00000000 00000000 00000000 00000000
 157  *                              ^      trigger
 158  *                               ^     weak
 159  *                                 ^^^ tc_kind
 160  *                                ^    coerce
 161  *                        ^^^          default_kind
 162  *                       ^             lazy
 163  *                 ^                   required
 164  * ^^^^^^^                             if 0 then nothing special (just hash)? FIXME TBD
 165  */
 166
 167 #define ATTR_INSTANCE_MASK 0xff000000
 168 #define ATTR_READING_MASK  0x0000ff00
 169 #define ATTR_WRITING_MASK  0x000000ff
 170
 171 #define ATTR_MASK_TYPE 0x7
 172
 173 #define ATTR_MASK_DEFAULT 0x700
 174 #define ATTR_SHIFT_DEAFULT 8
 175
 176 #define ATTR_LAZY 0x800
 177
 178 #define ATTR_COERCE 0x08
 179 #define ATTR_WEAK 0x10
 180 #define ATTR_TRIGGER 0x10
 181
 182 #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK )
 183 #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY )
 184 #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE )
 185
 186 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
 187 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
 188
 189 #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr)
 190 #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 )
 191 #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 )
 192
 193 #define dATTR ATTR *attr = (INT2PTR(ATTR *, (XSANY.any_i32 || define_attr(aTHX_ cv))))
 194
 195
 196 /* FIXME define a vtable that does call_sv */
 197 typedef struct {
 198     SV * (*get)(pTHX_ SV *self, ATTR *attr);
 199     void (*set)(pTHX_ SV *self, ATTR *attr, SV *value);
 200     bool * (*has)(pTHX_ SV *self, ATTR *attr);
 201     SV * (*delete)(pTHX_ SV *self, ATTR *attr);
 202 } instance_vtbl;
 203
 204
 205 typedef enum {
 206     hash = 0,
 207
 208     /* these are not yet implemented */
 209     array,
 210     fptr,
 211     cv,
 212     judy,
 213 } instance_types;
 214
 215 typedef struct mi {
 216     SV *associated_metaclass;
 217     HV *stash;
 218
 219     /* slot access method */
 220     instance_types type;
 221     instance_vtbl *vtbl;
 222
 223     /* attr descriptors */
 224     I32 num_attrs;
 225     ATTR *attrs;
 226 } MI;
 227
 228
 229 STATIC void init_attr (MI *mi, ATTR *attr, HV *desc) {
 230     U32 hash;
 231     STRLEN len;
 232     SV **key = hv_fetchs(desc, "key", 0);
 233     SV **meta_attr = hv_fetchs(desc, "meta", 0);
 234     char *pv;
 235
 236     if ( !meta_attr ) croak("'meta' is required");
 237
 238     attr->attr = *meta_attr;
 239
 240     attr->mi = mi;
 241
 242     attr->flags = 0;
 243
 244
 245     /* if type == hash */
 246     /* prehash the key */
 247     if ( !key ) croak("'key' is required");
 248
 249     pv = SvPV(*key, len);
 250
 251     PERL_HASH(hash, pv, len);
 252
 253     attr->slot_sv = newSVpvn_share(pv, len, hash);
 254     attr->slot_u32 = hash;
 255
 256     attr->def.type = 0;
 257
 258     attr->tc_check.type = 0;
 259     attr->type_constraint = NULL;
 260
 261
 262     attr->initializer = NULL;
 263     attr->trigger = NULL;
 264
 265     /* cross refs to CVs which use this struct */
 266     attr->cvs = newAV();
 267 }
 268
 269 STATIC MI *new_mi (pTHX_ HV *stash, SV *meta, AV *attrs) {
 270     MI *mi;
 271     I32 ix;
 272     const I32 num = av_len(attrs) + 1;
 273
 274     Newx(mi, 1, MI);
 275
 276     SvREFCNT_inc_simple(stash);
 277     mi->stash = stash;
 278
 279     SvREFCNT_inc_simple(meta);
 280     mi->associated_metaclass = meta;
 281
 282     mi->type = 0; /* nothing else implemented yet */
 283
 284     /* initialize attributes */
 285     mi->num_attrs = num;
 286     Newx(mi->attrs, num, ATTR);
 287     for ( ix = 0; ix < mi->num_attrs; ix++ ) {
 288         SV **desc = av_fetch(attrs, ix, 0);
 289
 290         if ( !desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVHV) )
 291             croak("Attribute descriptor has to be a hash reference");
 292
 293         init_attr(mi, &mi->attrs[ix], (HV *)SvRV(*desc));
 294     }
 295
 296     return mi;
 297 }
 298
 299 STATIC SV *get_meta_attr_from_mg(pTHX_ CV *cv) {
 300     MAGIC *mg, *moremagic;
 301
 302     if (SvTYPE(cv) >= SVt_PVMG) {
 303         for (mg = SvMAGIC(cv); mg; mg = mg->mg_moremagic) {
 304             if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl))
 305                 break;
 306         }
 307         if (mg)
 308             return mg->mg_obj;
 309     }
 310
 311     croak("No attr found in magic!");
 312     return NULL;
 313 }
 314
 315 STATIC ATTR *get_attr(pTHX_ CV *cv) {
 316     SV *meta_attr = get_meta_attr_from_mg(aTHX_ cv);
 317
 318 #if 0
 319     my $mi = $meta_attr->associated_metaclass->get_meta_instance;
 320     my @attrs = map {
 321         {
 322             meta => $_,
 323             key =>  ($_->slots)[0],
 324         },
 325     } @{ $mi->attributes };
 326 #else
 327     croak("todo");
 328 #endif
 329
 330     return NULL;
 331 }
 332
 333 STATIC ATTR *define_attr (pTHX_ CV *cv) {
 334     ATTR *attr = get_attr(aTHX_ cv);
 335     assert(attr);
 336
 337     XSANY.any_i32 = PTR2IV(attr);
 338     av_push( attr->cvs, cv );
 339
 340     return attr;
 341 }
 342
 343 STATIC void weaken(pTHX_ SV *sv) {
 344 #ifdef SvWEAKREF
 345         sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
 346 #else
 347         croak("weak references are not implemented in this release of perl");
 348 #endif
 349 }
 350
 351
 352 /* meta instance protocol */
 353
 354 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
 355     HE *he;
 356
 357     assert(self);
 358     assert(SvROK(self));
 359     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 360
 361     assert( ATTR_DUMB_INSTANCE(attr) );
 362
 363     if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
 364         return HeVAL(he);
 365     else
 366         return NULL;
 367 }
 368
 369 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
 370     HE *he;
 371
 372     assert(self);
 373     assert(SvROK(self));
 374     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 375
 376     assert( ATTR_DUMB_INSTANCE(attr) );
 377
 378     SvREFCNT_inc(value);
 379
 380     he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32);
 381     if (he != NULL) {
 382         if ( ATTR_ISWEAK(attr) )
 383             weaken(aTHX_ HeVAL(he)); /* actually only needed once at HE creation time */
 384     } else {
 385         croak("Hash store failed.");
 386     }
 387 }
 388
 389 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
 390     assert(self);
 391     assert(SvROK(self));
 392     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 393
 394     assert( ATTR_DUMB_INSTANCE(attr) );
 395
 396     return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
 397 }
 398
 399 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
 400     assert(self);
 401     assert(SvROK(self));
 402     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 403
 404     assert( ATTR_DUMB_INSTANCE(attr) );
 405
 406     return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
 407 }
 408
 409
 410 /* simple high level api */
 411
 412 STATIC XS(getter);
 413 STATIC XS(getter)
 414 {
 415 #ifdef dVAR
 416     dVAR;
 417 #endif
 418     dXSARGS;
 419     dATTR;
 420     SV *value;
 421
 422     if (items != 1)
 423         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 424
 425     SP -= items;
 426
 427     assert( ATTR_DUMB_READER(attr) );
 428
 429     value = get_slot_value(aTHX_ ST(0), attr);
 430
 431     if (value) {
 432         ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
 433         XSRETURN(1);
 434     } else {
 435         XSRETURN_UNDEF;
 436     }
 437 }
 438
 439 STATIC XS(setter);
 440 STATIC XS(setter)
 441 {
 442 #ifdef dVAR
 443     dVAR;
 444 #endif
 445     dXSARGS;
 446     dATTR;
 447
 448     if (items != 2)
 449         Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
 450
 451     SP -= items;
 452
 453     assert( ATTR_DUMB_WRITER(attr) );
 454
 455     set_slot_value(aTHX_ ST(0), attr, ST(1));
 456
 457     ST(0) = ST(1); /* return value */
 458     XSRETURN(1);
 459 }
 460
 461 STATIC XS(accessor);
 462 STATIC XS(accessor)
 463 {
 464 #ifdef dVAR
 465     dVAR;
 466 #endif
 467     dXSARGS;
 468     dATTR;
 469
 470     if (items < 1)
 471         Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
 472
 473     SP -= items;
 474
 475     if (items > 1) {
 476         assert( ATTR_DUMB_READER(attr) );
 477         set_slot_value(aTHX_ ST(0), attr, ST(1));
 478         ST(0) = ST(1); /* return value */
 479     } else {
 480         assert( ATTR_DUMB_WRITER(attr) );
 481         SV *value = get_slot_value(aTHX_ ST(0), attr);
 482         if ( value ) {
 483             ST(0) = value;
 484         } else {
 485             XSRETURN_UNDEF;
 486         }
 487     }
 488
 489     XSRETURN(1);
 490 }
 491
 492 STATIC XS(predicate);
 493 STATIC XS(predicate)
 494 {
 495 #ifdef dVAR
 496     dVAR;
 497 #endif
 498     dXSARGS;
 499     dATTR;
 500
 501     if (items != 1)
 502         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 503
 504     SP -= items;
 505
 506     if ( has_slot_value(aTHX_ ST(0), attr) )
 507         XSRETURN_YES;
 508     else
 509         XSRETURN_NO;
 510 }
 511
 512 enum xs_body {
 513     xs_body_getter = 0,
 514     xs_body_setter,
 515     xs_body_accessor,
 516     xs_body_predicate,
 517     max_xs_body
 518 };
 519
 520 STATIC XSPROTO ((*xs_bodies[])) = {
 521     getter,
 522     setter,
 523     accessor,
 524     predicate,
 525 };
 526
 527 MODULE = Moose PACKAGE = Moose::XS
 528
 529 CV *
 530 new_sub(attr, name)
 531     INPUT:
 532         SV *attr;
 533         SV *name;
 534     ALIAS:
 535         new_getter    = xs_body_getter
 536         new_setter    = xs_body_setter
 537         new_accessor  = xs_body_accessor
 538         new_predicate = xs_body_predicate
 539     PREINIT:
 540         CV * cv;
 541     CODE:
 542         if ( ix >= max_xs_body )
 543             croak("Unknown Moose::XS body type");
 544
 545         if ( !sv_isobject(attr) )
 546             croak("'attr' must be a Moose::Meta::Attribute");
 547
 548         cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
 549
 550         if (cv == NULL)
 551             croak("Oi vey!");
 552
 553         /* associate CV with meta attr */
 554         (void)Perl_sv_magicext(aTHX_ (SV *)cv, attr, PERL_MAGIC_ext, &null_mg_vtbl, STR_WITH_LEN("Moose::Meta::Attribute") );
 555
 556         /* this will be set on first call */
 557         XSANY.any_i32 = 0;
 558
 559         RETVAL = cv;
 560     OUTPUT:
 561         RETVAL
 562
 563