Moose.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 #define SLOT_WEAKEN 0x01
   6
   7 /* FIXME
   8  * needs to be made into Moose::XS::Meta::Instance and Meta::Slot for the
   9  * metadata, with a proper destructor. XSANY still points to this struct, but
  10  * it is shared by all functions of the same type.
  11  *
  12  * Instance contains SvSTASH, and SLOT slots[]
  13  *
  14  * On recreation of the meta instance we refresh the SLOT value of all the CVs
  15  * we installed
  16  *
  17  * need a good way to handle time between invalidate and regeneration (just
  18  * check XSANY and call get_meta_instance if null?)
  19  */
  20
  21
  22 /* FIXME
  23  * slot access is one of 4 values in flags:
  24  * 0 == hash
  25  * 1 == array
  26  * 3 == fptr (allows access into C structs, etc)
  27  * 4 == callsv (really a special case of fptr)
  28  *
  29  * for fptr case we have a pointer to a vtable for get/set/has/delete, all of which take the same args as set_slot_value
  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 SLOT *slots, 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  *      SLOT *slot;
  55  *      pv *method;
  56  * } delegation;
  57  *
  58  * typedef struct {
  59  *      SLOT *slot;
  60  *      I32 *type; // hash, array, whatever + vtable for operation
  61  * } attributehelper;
  62  */
  63
  64 typedef struct {
  65     U32 hash;
  66     SV *sv;
  67     U32 flags /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
  68     /* FIXME
  69      * type constraint (pointer or enum union)
  70      * default / builder ptr (or SV *)
  71      * initializer
  72      */
  73 } SLOT;
  74
  75 #define dSLOT SLOT *slot = INT2PTR(SLOT *, XSANY.any_i32)
  76
  77 /* utility functions */
  78
  79 STATIC SLOT *new_slot_from_key (SV *key, U32 flags) {
  80     SLOT *slot = (SLOT *)malloc(sizeof(SLOT));
  81     U32 hash;
  82     STRLEN len;
  83     char *pv = SvPV(key, len);
  84
  85     PERL_HASH(hash, pv, len);
  86     slot->sv = newSVpvn_share(pv, len, hash);
  87     slot->hash = hash;
  88     slot->flags = flags;
  89
  90     return slot;
  91 }
  92
  93 STATIC void weaken(SV *sv) {
  94 #ifdef SvWEAKREF
  95         sv_rvweaken(sv);
  96 #else
  97         croak("weak references are not implemented in this release of perl");
  98 #endif
  99 }
 100
 101
 102 /* meta instance protocol */
 103
 104 STATIC SV *get_slot_value(SV *self, SLOT *slot) {
 105     HE *he;
 106
 107     assert(self);
 108     assert(SvROK(self));
 109     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 110
 111     if (he = hv_fetch_ent((HV *)SvRV(self), slot->sv, 0, slot->hash))
 112         return HeVAL(he);
 113     else
 114         return NULL;
 115 }
 116
 117 STATIC void set_slot_value(SV *self, SLOT *slot, SV *value) {
 118     HE *he;
 119
 120     assert(self);
 121     assert(SvROK(self));
 122     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 123
 124     SvREFCNT_inc(value);
 125
 126     he = hv_store_ent((HV*)SvRV(self), slot->sv, value, slot->hash);
 127     if (he != NULL) {
 128         if ( slot->flags & SLOT_WEAKEN )
 129             weaken(HeVAL(he));
 130     } else {
 131         croak("Hash store failed.");
 132     }
 133 }
 134
 135 STATIC bool has_slot_value(SV *self, SLOT *slot) {
 136     assert(self);
 137     assert(SvROK(self));
 138     assert(SvTYPE(SvRV(self)) == SVt_PVHV);
 139
 140     return hv_exists_ent((HV *)SvRV(self), slot->sv, slot->hash);
 141 }
 142
 143
 144 /* simple high level api */
 145
 146 STATIC XS(simple_getter);
 147 STATIC XS(simple_getter)
 148 {
 149 #ifdef dVAR
 150     dVAR;
 151 #endif
 152     dXSARGS;
 153     dSLOT;
 154     SV *value;
 155
 156     if (items != 1)
 157         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 158
 159     SP -= items;
 160
 161     value = get_slot_value(ST(0), slot);
 162
 163     if (value) {
 164         ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
 165         XSRETURN(1);
 166     } else {
 167         XSRETURN_UNDEF;
 168     }
 169 }
 170
 171 STATIC XS(simple_setter);
 172 STATIC XS(simple_setter)
 173 {
 174 #ifdef dVAR
 175     dVAR;
 176 #endif
 177     dXSARGS;
 178     dSLOT;
 179
 180     if (items != 2)
 181         Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
 182
 183     SP -= items;
 184
 185     set_slot_value(ST(0), slot, ST(1));
 186
 187     ST(0) = ST(1); /* return value */
 188     XSRETURN(1);
 189 }
 190
 191 STATIC XS(simple_accessor);
 192 STATIC XS(simple_accessor)
 193 {
 194 #ifdef dVAR
 195     dVAR;
 196 #endif
 197     dXSARGS;
 198     dSLOT;
 199
 200     if (items < 1)
 201         Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
 202
 203     SP -= items;
 204
 205     if (items > 1) {
 206         set_slot_value(ST(0), slot, ST(1));
 207         ST(0) = ST(1); /* return value */
 208     } else {
 209         SV *value = get_slot_value(ST(0), slot);
 210         if ( value ) {
 211             ST(0) = value;
 212         } else {
 213             XSRETURN_UNDEF;
 214         }
 215     }
 216
 217     XSRETURN(1);
 218 }
 219
 220 STATIC XS(predicate);
 221 STATIC XS(predicate)
 222 {
 223 #ifdef dVAR
 224     dVAR;
 225 #endif
 226     dXSARGS;
 227     dSLOT;
 228
 229     if (items != 1)
 230         Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
 231
 232     SP -= items;
 233
 234     if ( has_slot_value(ST(0), slot) )
 235         XSRETURN_YES;
 236     else
 237         XSRETURN_NO;
 238 }
 239
 240 enum xs_body {
 241     xs_body_simple_getter = 0,
 242     xs_body_simple_setter,
 243     xs_body_simple_accessor,
 244     xs_body_predicate,
 245     max_xs_body
 246 };
 247
 248 STATIC XSPROTO ((*xs_bodies[])) = {
 249     simple_getter,
 250     simple_setter,
 251     simple_accessor,
 252     predicate,
 253 };
 254
 255 MODULE = Moose PACKAGE = Moose::XS
 256
 257 CV *
 258 install_sub(name, key)
 259     INPUT:
 260         char *name;
 261         SV *key;
 262     ALIAS:
 263         install_simple_getter   = xs_body_simple_getter
 264         install_simple_setter   = xs_body_simple_setter
 265         install_simple_accessor = xs_body_simple_accessor
 266         install_predicate       = xs_body_predicate
 267     PREINIT:
 268         CV * cv;
 269     CODE:
 270         if ( ix >= max_xs_body )
 271             croak("Unknown Moose::XS body type");
 272
 273         cv = newXS(name, xs_bodies[ix], __FILE__);
 274
 275         if (cv == NULL)
 276             croak("Oi vey!");
 277
 278         /* FIXME leaks, fail for anon classes */
 279         XSANY.any_i32 = PTR2IV(new_slot_from_key(key, 0));
 280
 281         RETVAL = cv;
 282     OUTPUT:
 283         RETVAL
 284
 285