5 #define NEED_newRV_noinc
6 #define NEED_newSVpvn_share
7 #define NEED_sv_2pv_flags
11 #define XSPROTO(name) void name(pTHX_ CV* cv)
15 #define gv_stashpvs(x, y) gv_stashpvn(STR_WITH_LEN(x), y)
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.
23 * Instance contains SvSTASH, and ATTR slots[]
25 * On recreation of the meta instance we refresh the ATTR value of all the CVs
28 * need a good way to handle time between invalidate and regeneration (just
29 * check XSANY and call get_meta_instance if null?)
33 * type constraints are already implemented by konobi
34 * should be trivial to do coercions for the core types, too
36 * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then*
37 * call ->isa (should handle vast majority of cases)
39 * base parametrized types are also trivial
41 * ClassName is get_stathpvn
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
51 * delegations and attribute helpers:
60 * I32 *type; // hash, array, whatever + vtable for operation
65 STATIC MGVTBL null_mg_vtbl = {
79 #endif /* MGf_LOCAL */
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;
89 STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
90 MAGIC *mg, *moremagic;
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))
167 /* the meta instance struct */
170 U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
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) */
176 DEFAULT def; /* cv, value or other, depending on flags */
178 TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
179 SV *type_constraint; /* meta attr */
184 SV *meta_attr; /* the meta attr object */
185 AV *cvs; /* CVs which use this attr */
189 * instance reading writing
190 * 00000000 00000000 00000000 00000000
198 * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD
201 #define ATTR_INSTANCE_MASK 0xff000000
202 #define ATTR_READING_MASK 0x0000ff00
203 #define ATTR_WRITING_MASK 0x000000ff
205 #define ATTR_MASK_TYPE 0x7
207 #define ATTR_MASK_DEFAULT 0x700
208 #define ATTR_SHIFT_DEAFULT 8
210 #define ATTR_LAZY 0x800
212 #define ATTR_COERCE 0x08
213 #define ATTR_WEAK 0x10
214 #define ATTR_TRIGGER 0x10
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 )
220 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
221 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
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 )
227 #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv))
230 /* FIXME define a vtable that does call_sv */
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);
242 /* these are not yet implemented */
252 /* slot access method */
256 /* attr descriptors */
262 STATIC void init_attr (MI *mi, ATTR *attr, HV *desc) {
265 SV **key = hv_fetchs(desc, "key", 0);
266 SV **meta_attr = hv_fetchs(desc, "meta", 0);
269 if ( !meta_attr ) croak("'meta' is required");
271 attr->meta_attr = newSVsv(*meta_attr);
278 /* if type == hash */
279 /* prehash the key */
280 if ( !key ) croak("'key' is required");
282 pv = SvPV(*key, len);
284 PERL_HASH(hash, pv, len);
286 attr->slot_sv = newSVpvn_share(pv, len, hash);
287 attr->slot_u32 = hash;
291 attr->tc_check.type = 0;
292 attr->type_constraint = NULL;
295 attr->initializer = NULL;
296 attr->trigger = NULL;
298 /* cross refs to CVs which use this struct */
302 STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) {
305 const I32 num = av_len(attrs) + 1;
309 SvREFCNT_inc_simple(stash);
312 mi->type = 0; /* nothing else implemented yet */
314 /* initialize attributes */
316 Newx(mi->attrs, num, ATTR);
317 for ( ix = 0; ix < num; ix++ ) {
318 SV **desc = av_fetch(attrs, ix, 0);
320 if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVHV) ) {
321 croak("Attribute descriptor has to be a hash reference");
324 init_attr(mi, &mi->attrs[ix], (HV *)SvRV(*desc));
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 );
337 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
343 croak("No attr found in magic!");
350 count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
353 croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
367 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
380 count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
383 croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
391 stash = gv_stashsv(class, 0);
393 mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
398 return new_mi_obj(aTHX_ mi);
401 STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
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];
411 croak("Attr not found");
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));
422 c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
423 stash_in_mg(aTHX_ perl_mi, c_mi);
428 mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
430 return mi_find_attr(mi, meta_attr);
433 STATIC ATTR *define_attr (pTHX_ CV *cv) {
434 ATTR *attr = get_attr(aTHX_ cv);
437 XSANY.any_i32 = PTR2IV(attr);
439 av_push( attr->cvs, (SV *)cv );
444 STATIC void weaken(pTHX_ SV *sv) {
446 sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
448 croak("weak references are not implemented in this release of perl");
453 /* meta instance protocol */
455 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
460 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
462 assert( ATTR_DUMB_INSTANCE(attr) );
464 if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
470 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
475 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
477 assert( ATTR_DUMB_INSTANCE(attr) );
481 he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32);
483 if ( ATTR_ISWEAK(attr) )
484 weaken(aTHX_ HeVAL(he)); /* actually only needed once at HE creation time */
486 croak("Hash store failed.");
490 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
493 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
495 assert( ATTR_DUMB_INSTANCE(attr) );
497 return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
500 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
503 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
505 assert( ATTR_DUMB_INSTANCE(attr) );
507 return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
511 /* simple high level api */
524 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
528 assert( ATTR_DUMB_READER(attr) );
530 value = get_slot_value(aTHX_ ST(0), attr);
533 ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
550 Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
554 assert( ATTR_DUMB_WRITER(attr) );
556 set_slot_value(aTHX_ ST(0), attr, ST(1));
558 ST(0) = ST(1); /* return value */
572 Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
577 assert( ATTR_DUMB_READER(attr) );
578 set_slot_value(aTHX_ ST(0), attr, ST(1));
579 ST(0) = ST(1); /* return value */
582 assert( ATTR_DUMB_WRITER(attr) );
583 value = get_slot_value(aTHX_ ST(0), attr);
594 STATIC XS(predicate);
604 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
608 if ( has_slot_value(aTHX_ ST(0), attr) )
622 STATIC XSPROTO ((*xs_bodies[])) = {
629 MODULE = Moose PACKAGE = Moose::XS
637 new_getter = xs_body_getter
638 new_setter = xs_body_setter
639 new_accessor = xs_body_accessor
640 new_predicate = xs_body_predicate
644 if ( ix >= max_xs_body )
645 croak("Unknown Moose::XS body type");
647 if ( !sv_isobject(attr) )
648 croak("'attr' must be a Moose::Meta::Attribute");
650 cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
655 /* associate CV with meta attr */
656 stash_in_mg(aTHX_ (SV *)cv, attr);
658 /* this will be set on first call */
666 MODULE = Moose PACKAGE = Moose::XS::Meta::Instance
673 MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
675 /* foreach attr ( delete cvs XSANY ), free attrs free mi */