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.
10 * Instance contains SvSTASH, and ATTR slots[]
12 * On recreation of the meta instance we refresh the ATTR value of all the CVs
15 * need a good way to handle time between invalidate and regeneration (just
16 * check XSANY and call get_meta_instance if null?)
20 * type constraints are already implemented by konobi
21 * should be trivial to do coercions for the core types, too
23 * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then*
24 * call ->isa (should handle vast majority of cases)
26 * base parametrized types are also trivial
28 * ClassName is get_stathpvn
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
38 * delegations and attribute helpers:
47 * I32 *type; // hash, array, whatever + vtable for operation
52 STATIC MGVTBL null_mg_vtbl = {
66 #endif /* MGf_LOCAL */
133 /* the meta instance struct */
136 U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
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) */
142 DEFAULT def; /* cv, value or other, depending on flags */
144 TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
145 SV *type_constraint; /* meta attr */
150 SV *attr; /* the meta attr object */
151 AV *cvs; /* CVs which use this attr */
155 * instance reading writing
156 * 00000000 00000000 00000000 00000000
164 * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD
167 #define ATTR_INSTANCE_MASK 0xff000000
168 #define ATTR_READING_MASK 0x0000ff00
169 #define ATTR_WRITING_MASK 0x000000ff
171 #define ATTR_MASK_TYPE 0x7
173 #define ATTR_MASK_DEFAULT 0x700
174 #define ATTR_SHIFT_DEAFULT 8
176 #define ATTR_LAZY 0x800
178 #define ATTR_COERCE 0x08
179 #define ATTR_WEAK 0x10
180 #define ATTR_TRIGGER 0x10
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 )
186 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
187 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
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 )
193 #define dATTR ATTR *attr = (INT2PTR(ATTR *, (XSANY.any_i32 || define_attr(aTHX_ cv))))
196 /* FIXME define a vtable that does call_sv */
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);
208 /* these are not yet implemented */
216 SV *associated_metaclass;
219 /* slot access method */
223 /* attr descriptors */
229 STATIC void init_attr (MI *mi, ATTR *attr, HV *desc) {
232 SV **key = hv_fetchs(desc, "key", 0);
233 SV **meta_attr = hv_fetchs(desc, "meta", 0);
236 if ( !meta_attr ) croak("'meta' is required");
238 attr->attr = *meta_attr;
245 /* if type == hash */
246 /* prehash the key */
247 if ( !key ) croak("'key' is required");
249 pv = SvPV(*key, len);
251 PERL_HASH(hash, pv, len);
253 attr->slot_sv = newSVpvn_share(pv, len, hash);
254 attr->slot_u32 = hash;
258 attr->tc_check.type = 0;
259 attr->type_constraint = NULL;
262 attr->initializer = NULL;
263 attr->trigger = NULL;
265 /* cross refs to CVs which use this struct */
269 STATIC MI *new_mi (pTHX_ HV *stash, SV *meta, AV *attrs) {
272 const I32 num = av_len(attrs) + 1;
276 SvREFCNT_inc_simple(stash);
279 SvREFCNT_inc_simple(meta);
280 mi->associated_metaclass = meta;
282 mi->type = 0; /* nothing else implemented yet */
284 /* initialize attributes */
286 Newx(mi->attrs, num, ATTR);
287 for ( ix = 0; ix < mi->num_attrs; ix++ ) {
288 SV **desc = av_fetch(attrs, ix, 0);
290 if ( !desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVHV) )
291 croak("Attribute descriptor has to be a hash reference");
293 init_attr(mi, &mi->attrs[ix], (HV *)SvRV(*desc));
299 STATIC SV *get_meta_attr_from_mg(pTHX_ CV *cv) {
300 MAGIC *mg, *moremagic;
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))
311 croak("No attr found in magic!");
315 STATIC ATTR *get_attr(pTHX_ CV *cv) {
316 SV *meta_attr = get_meta_attr_from_mg(aTHX_ cv);
319 my $mi = $meta_attr->associated_metaclass->get_meta_instance;
323 key => ($_->slots)[0],
325 } @{ $mi->attributes };
333 STATIC ATTR *define_attr (pTHX_ CV *cv) {
334 ATTR *attr = get_attr(aTHX_ cv);
337 XSANY.any_i32 = PTR2IV(attr);
338 av_push( attr->cvs, cv );
343 STATIC void weaken(pTHX_ SV *sv) {
345 sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
347 croak("weak references are not implemented in this release of perl");
352 /* meta instance protocol */
354 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
359 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
361 assert( ATTR_DUMB_INSTANCE(attr) );
363 if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
369 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
374 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
376 assert( ATTR_DUMB_INSTANCE(attr) );
380 he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32);
382 if ( ATTR_ISWEAK(attr) )
383 weaken(aTHX_ HeVAL(he)); /* actually only needed once at HE creation time */
385 croak("Hash store failed.");
389 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
392 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
394 assert( ATTR_DUMB_INSTANCE(attr) );
396 return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
399 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
402 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
404 assert( ATTR_DUMB_INSTANCE(attr) );
406 return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
410 /* simple high level api */
423 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
427 assert( ATTR_DUMB_READER(attr) );
429 value = get_slot_value(aTHX_ ST(0), attr);
432 ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
449 Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
453 assert( ATTR_DUMB_WRITER(attr) );
455 set_slot_value(aTHX_ ST(0), attr, ST(1));
457 ST(0) = ST(1); /* return value */
471 Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
476 assert( ATTR_DUMB_READER(attr) );
477 set_slot_value(aTHX_ ST(0), attr, ST(1));
478 ST(0) = ST(1); /* return value */
480 assert( ATTR_DUMB_WRITER(attr) );
481 SV *value = get_slot_value(aTHX_ ST(0), attr);
492 STATIC XS(predicate);
502 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
506 if ( has_slot_value(aTHX_ ST(0), attr) )
520 STATIC XSPROTO ((*xs_bodies[])) = {
527 MODULE = Moose PACKAGE = Moose::XS
535 new_getter = xs_body_getter
536 new_setter = xs_body_setter
537 new_accessor = xs_body_accessor
538 new_predicate = xs_body_predicate
542 if ( ix >= max_xs_body )
543 croak("Unknown Moose::XS body type");
545 if ( !sv_isobject(attr) )
546 croak("'attr' must be a Moose::Meta::Attribute");
548 cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
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") );
556 /* this will be set on first call */