From: Yuval Kogman Date: Tue, 19 Aug 2008 13:18:54 +0000 (+0000) Subject: lots more stuff X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de2f2e9743bab831a9ffe63c6ed1bc4a084adb13;p=gitmo%2FMoose.git lots more stuff --- diff --git a/Moose.xs b/Moose.xs index 3089492..6e23f9f 100644 --- a/Moose.xs +++ b/Moose.xs @@ -2,33 +2,20 @@ #include "perl.h" #include "XSUB.h" -#define SLOT_WEAKEN 0x01 - /* FIXME * needs to be made into Moose::XS::Meta::Instance and Meta::Slot for the * metadata, with a proper destructor. XSANY still points to this struct, but * it is shared by all functions of the same type. * - * Instance contains SvSTASH, and SLOT slots[] + * Instance contains SvSTASH, and ATTR slots[] * - * On recreation of the meta instance we refresh the SLOT value of all the CVs + * On recreation of the meta instance we refresh the ATTR value of all the CVs * we installed * * need a good way to handle time between invalidate and regeneration (just * check XSANY and call get_meta_instance if null?) */ - -/* FIXME - * slot access is one of 4 values in flags: - * 0 == hash - * 1 == array - * 3 == fptr (allows access into C structs, etc) - * 4 == callsv (really a special case of fptr) - * - * 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 - */ - /* FIXME * type constraints are already implemented by konobi * should be trivial to do coercions for the core types, too @@ -42,7 +29,7 @@ */ /* FIXME - * for a constructor we have SLOT *slots, and iterate that, removing init_arg + * for a constructor we have ATTR *attrs, and iterate that, removing init_arg * we can preallocate the structure to the right size (maybe even with the * right HEs?), and do various other prehashing hacks to gain speed * */ @@ -51,48 +38,311 @@ * delegations and attribute helpers: * * typedef struct { - * SLOT *slot; + * ATTR *attr; * pv *method; * } delegation; * * typedef struct { - * SLOT *slot; + * ATTR *attr; * I32 *type; // hash, array, whatever + vtable for operation * } attributehelper; */ + +STATIC MGVTBL null_mg_vtbl = { + NULL, /* get */ + NULL, /* set */ + NULL, /* len */ + NULL, /* clear */ + NULL, /* free */ +#if MGf_COPY + NULL, /* copy */ +#endif /* MGf_COPY */ +#if MGf_DUP + NULL, /* dup */ +#endif /* MGf_DUP */ +#if MGf_LOCAL + NULL, /* local */ +#endif /* MGf_LOCAL */ +}; + + + +typedef enum { + Any = 0, + Item, + Bool, + Maybe, /* [`a] */ + Undef, + Defined, + Value, + Num, + Int, + Str, + ClassName, + Ref, + ScalarRef, + ArrayRef, /* [`a] */ + HashRef, /* [`a] */ + CodeRef, + RegexpRef, + GlobRef, + FileHandle, + Object, + Role, + + /* XS only types */ + Class, + + max_TC +} TC; + +typedef union { + TC type; + CV *cv; + HV *stash; + OP *op; +} TC_CHECK; + +typedef enum { + tc_none = 0, + tc_type, + tc_cv, + tc_stash, + tc_op, +} tc_kind; + +typedef union { + char *builder; + SV *value; + CV *sub; + OP *op; + U32 type; +} DEFAULT; + +typedef enum { + default_none = 0, + default_type, + default_builder, + default_value, + default_sub, + default_op, +} default_kind; + typedef struct { - U32 hash; - SV *sv; - U32 flags /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */ - /* FIXME - * type constraint (pointer or enum union) - * default / builder ptr (or SV *) - * initializer - */ -} SLOT; + /* the meta instance struct */ + struct mi *mi; + + U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */ + + /* slot access fields */ + SV *slot_sv; /* value of the slot (slot name presumably) */ + U32 slot_u32; /* for optimized access (precomputed hash or otherr) */ + + DEFAULT def; /* cv, value or other, depending on flags */ + + TC_CHECK tc_check; /* cv, value or other, dependidng on flags */ + SV *type_constraint; /* meta attr */ + + CV *initializer; + CV *trigger; + + SV *attr; /* the meta attr object */ + AV *cvs; /* CVs which use this attr */ +} ATTR; + +/* slot flags: + * instance reading writing + * 00000000 00000000 00000000 00000000 + * ^ trigger + * ^ weak + * ^^^ tc_kind + * ^ coerce + * ^^^ default_kind + * ^ lazy + * ^ required + * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD + */ + +#define ATTR_INSTANCE_MASK 0xff000000 +#define ATTR_READING_MASK 0x0000ff00 +#define ATTR_WRITING_MASK 0x000000ff + +#define ATTR_MASK_TYPE 0x7 + +#define ATTR_MASK_DEFAULT 0x700 +#define ATTR_SHIFT_DEAFULT 8 + +#define ATTR_LAZY 0x800 + +#define ATTR_COERCE 0x08 +#define ATTR_WEAK 0x10 +#define ATTR_TRIGGER 0x10 + +#define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK ) +#define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY ) +#define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE ) -#define dSLOT SLOT *slot = INT2PTR(SLOT *, XSANY.any_i32) +#define ATTR_TYPE(f) ( attr->flags & 0x7 ) +#define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT ) -/* utility functions */ +#define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr) +#define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 ) +#define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 ) -STATIC SLOT *new_slot_from_key (SV *key, U32 flags) { - SLOT *slot = (SLOT *)malloc(sizeof(SLOT)); +#define dATTR ATTR *attr = (INT2PTR(ATTR *, (XSANY.any_i32 || define_attr(aTHX_ cv)))) + + +/* FIXME define a vtable that does call_sv */ +typedef struct { + SV * (*get)(pTHX_ SV *self, ATTR *attr); + void (*set)(pTHX_ SV *self, ATTR *attr, SV *value); + bool * (*has)(pTHX_ SV *self, ATTR *attr); + SV * (*delete)(pTHX_ SV *self, ATTR *attr); +} instance_vtbl; + + +typedef enum { + hash = 0, + + /* these are not yet implemented */ + array, + fptr, + cv, + judy, +} instance_types; + +typedef struct mi { + SV *associated_metaclass; + HV *stash; + + /* slot access method */ + instance_types type; + instance_vtbl *vtbl; + + /* attr descriptors */ + I32 num_attrs; + ATTR *attrs; +} MI; + + +STATIC void init_attr (MI *mi, ATTR *attr, HV *desc) { U32 hash; STRLEN len; - char *pv = SvPV(key, len); + SV **key = hv_fetchs(desc, "key", 0); + SV **meta_attr = hv_fetchs(desc, "meta", 0); + char *pv; + + if ( !meta_attr ) croak("'meta' is required"); + + attr->attr = *meta_attr; + + attr->mi = mi; + + attr->flags = 0; + + + /* if type == hash */ + /* prehash the key */ + if ( !key ) croak("'key' is required"); + + pv = SvPV(*key, len); PERL_HASH(hash, pv, len); - slot->sv = newSVpvn_share(pv, len, hash); - slot->hash = hash; - slot->flags = flags; - return slot; + attr->slot_sv = newSVpvn_share(pv, len, hash); + attr->slot_u32 = hash; + + attr->def.type = 0; + + attr->tc_check.type = 0; + attr->type_constraint = NULL; + + + attr->initializer = NULL; + attr->trigger = NULL; + + /* cross refs to CVs which use this struct */ + attr->cvs = newAV(); +} + +STATIC MI *new_mi (pTHX_ HV *stash, SV *meta, AV *attrs) { + MI *mi; + I32 ix; + const I32 num = av_len(attrs) + 1; + + Newx(mi, 1, MI); + + SvREFCNT_inc_simple(stash); + mi->stash = stash; + + SvREFCNT_inc_simple(meta); + mi->associated_metaclass = meta; + + mi->type = 0; /* nothing else implemented yet */ + + /* initialize attributes */ + mi->num_attrs = num; + Newx(mi->attrs, num, ATTR); + for ( ix = 0; ix < mi->num_attrs; ix++ ) { + SV **desc = av_fetch(attrs, ix, 0); + + if ( !desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVHV) ) + croak("Attribute descriptor has to be a hash reference"); + + init_attr(mi, &mi->attrs[ix], (HV *)SvRV(*desc)); + } + + return mi; +} + +STATIC SV *get_meta_attr_from_mg(pTHX_ CV *cv) { + MAGIC *mg, *moremagic; + + if (SvTYPE(cv) >= SVt_PVMG) { + for (mg = SvMAGIC(cv); mg; mg = mg->mg_moremagic) { + if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl)) + break; + } + if (mg) + return mg->mg_obj; + } + + croak("No attr found in magic!"); + return NULL; +} + +STATIC ATTR *get_attr(pTHX_ CV *cv) { + SV *meta_attr = get_meta_attr_from_mg(aTHX_ cv); + +#if 0 + my $mi = $meta_attr->associated_metaclass->get_meta_instance; + my @attrs = map { + { + meta => $_, + key => ($_->slots)[0], + }, + } @{ $mi->attributes }; +#else + croak("todo"); +#endif + + return NULL; } -STATIC void weaken(SV *sv) { +STATIC ATTR *define_attr (pTHX_ CV *cv) { + ATTR *attr = get_attr(aTHX_ cv); + assert(attr); + + XSANY.any_i32 = PTR2IV(attr); + av_push( attr->cvs, cv ); + + return attr; +} + +STATIC void weaken(pTHX_ SV *sv) { #ifdef SvWEAKREF - sv_rvweaken(sv); + sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */ #else croak("weak references are not implemented in this release of perl"); #endif @@ -101,56 +351,72 @@ STATIC void weaken(SV *sv) { /* meta instance protocol */ -STATIC SV *get_slot_value(SV *self, SLOT *slot) { +STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) { HE *he; assert(self); assert(SvROK(self)); assert(SvTYPE(SvRV(self)) == SVt_PVHV); - if (he = hv_fetch_ent((HV *)SvRV(self), slot->sv, 0, slot->hash)) + assert( ATTR_DUMB_INSTANCE(attr) ); + + if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32))) return HeVAL(he); else return NULL; } -STATIC void set_slot_value(SV *self, SLOT *slot, SV *value) { +STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) { HE *he; assert(self); assert(SvROK(self)); assert(SvTYPE(SvRV(self)) == SVt_PVHV); + assert( ATTR_DUMB_INSTANCE(attr) ); + SvREFCNT_inc(value); - he = hv_store_ent((HV*)SvRV(self), slot->sv, value, slot->hash); + he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32); if (he != NULL) { - if ( slot->flags & SLOT_WEAKEN ) - weaken(HeVAL(he)); + if ( ATTR_ISWEAK(attr) ) + weaken(aTHX_ HeVAL(he)); /* actually only needed once at HE creation time */ } else { croak("Hash store failed."); } } -STATIC bool has_slot_value(SV *self, SLOT *slot) { +STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) { assert(self); assert(SvROK(self)); assert(SvTYPE(SvRV(self)) == SVt_PVHV); - return hv_exists_ent((HV *)SvRV(self), slot->sv, slot->hash); + assert( ATTR_DUMB_INSTANCE(attr) ); + + return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32); +} + +STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) { + assert(self); + assert(SvROK(self)); + assert(SvTYPE(SvRV(self)) == SVt_PVHV); + + assert( ATTR_DUMB_INSTANCE(attr) ); + + return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32); } /* simple high level api */ -STATIC XS(simple_getter); -STATIC XS(simple_getter) +STATIC XS(getter); +STATIC XS(getter) { #ifdef dVAR dVAR; #endif dXSARGS; - dSLOT; + dATTR; SV *value; if (items != 1) @@ -158,7 +424,9 @@ STATIC XS(simple_getter) SP -= items; - value = get_slot_value(ST(0), slot); + assert( ATTR_DUMB_READER(attr) ); + + value = get_slot_value(aTHX_ ST(0), attr); if (value) { ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */ @@ -168,34 +436,36 @@ STATIC XS(simple_getter) } } -STATIC XS(simple_setter); -STATIC XS(simple_setter) +STATIC XS(setter); +STATIC XS(setter) { #ifdef dVAR dVAR; #endif dXSARGS; - dSLOT; + dATTR; if (items != 2) Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value"); SP -= items; - set_slot_value(ST(0), slot, ST(1)); + assert( ATTR_DUMB_WRITER(attr) ); + + set_slot_value(aTHX_ ST(0), attr, ST(1)); ST(0) = ST(1); /* return value */ XSRETURN(1); } -STATIC XS(simple_accessor); -STATIC XS(simple_accessor) +STATIC XS(accessor); +STATIC XS(accessor) { #ifdef dVAR dVAR; #endif dXSARGS; - dSLOT; + dATTR; if (items < 1) Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value"); @@ -203,10 +473,12 @@ STATIC XS(simple_accessor) SP -= items; if (items > 1) { - set_slot_value(ST(0), slot, ST(1)); + assert( ATTR_DUMB_READER(attr) ); + set_slot_value(aTHX_ ST(0), attr, ST(1)); ST(0) = ST(1); /* return value */ } else { - SV *value = get_slot_value(ST(0), slot); + assert( ATTR_DUMB_WRITER(attr) ); + SV *value = get_slot_value(aTHX_ ST(0), attr); if ( value ) { ST(0) = value; } else { @@ -224,59 +496,65 @@ STATIC XS(predicate) dVAR; #endif dXSARGS; - dSLOT; + dATTR; if (items != 1) Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); SP -= items; - if ( has_slot_value(ST(0), slot) ) + if ( has_slot_value(aTHX_ ST(0), attr) ) XSRETURN_YES; else XSRETURN_NO; } enum xs_body { - xs_body_simple_getter = 0, - xs_body_simple_setter, - xs_body_simple_accessor, + xs_body_getter = 0, + xs_body_setter, + xs_body_accessor, xs_body_predicate, max_xs_body }; STATIC XSPROTO ((*xs_bodies[])) = { - simple_getter, - simple_setter, - simple_accessor, + getter, + setter, + accessor, predicate, }; MODULE = Moose PACKAGE = Moose::XS CV * -install_sub(name, key) +new_sub(attr, name) INPUT: - char *name; - SV *key; + SV *attr; + SV *name; ALIAS: - install_simple_getter = xs_body_simple_getter - install_simple_setter = xs_body_simple_setter - install_simple_accessor = xs_body_simple_accessor - install_predicate = xs_body_predicate + new_getter = xs_body_getter + new_setter = xs_body_setter + new_accessor = xs_body_accessor + new_predicate = xs_body_predicate PREINIT: CV * cv; CODE: if ( ix >= max_xs_body ) croak("Unknown Moose::XS body type"); - cv = newXS(name, xs_bodies[ix], __FILE__); + if ( !sv_isobject(attr) ) + croak("'attr' must be a Moose::Meta::Attribute"); + + cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__); if (cv == NULL) croak("Oi vey!"); - /* FIXME leaks, fail for anon classes */ - XSANY.any_i32 = PTR2IV(new_slot_from_key(key, 0)); + /* associate CV with meta attr */ + (void)Perl_sv_magicext(aTHX_ (SV *)cv, attr, PERL_MAGIC_ext, &null_mg_vtbl, STR_WITH_LEN("Moose::Meta::Attribute") ); + + /* this will be set on first call */ + XSANY.any_i32 = 0; RETVAL = cv; OUTPUT: diff --git a/t/700_xs/001_basic.t b/t/700_xs/001_basic.t index 66498f8..0828a74 100644 --- a/t/700_xs/001_basic.t +++ b/t/700_xs/001_basic.t @@ -18,10 +18,10 @@ BEGIN { plan 'no_plan'; } -ok( defined &Moose::XS::install_simple_getter ); -ok( defined &Moose::XS::install_simple_setter ); -ok( defined &Moose::XS::install_simple_accessor ); -ok( defined &Moose::XS::install_predicate ); +ok( defined &Moose::XS::new_getter ); +ok( defined &Moose::XS::new_setter ); +ok( defined &Moose::XS::new_accessor ); +ok( defined &Moose::XS::new_predicate ); { package Foo; @@ -30,19 +30,28 @@ ok( defined &Moose::XS::install_predicate ); has x => ( is => "rw", predicate => "has_x" ); has y => ( is => "ro" ); has z => ( reader => "z", setter => "set_z" ); + has ref => ( is => "rw", weak_ref => 1 ); +} + +{ + my ( $x, $y, $z, $ref ) = map { Foo->meta->get_attribute($_) } qw(x y z ref); + $x->Moose::XS::new_accessor("Foo::x"); + $x->Moose::XS::new_predicate("Foo::has_x"); + $y->Moose::XS::new_getter("Foo::y"); + $z->Moose::XS::new_getter("Foo::z"); + $z->Moose::XS::new_setter("Foo::set_z"); + $ref->Moose::XS::new_accessor("Foo::ref"); } -Moose::XS::install_simple_accessor("Foo::x", "x"); -Moose::XS::install_predicate("Foo::has_x", "x"); -Moose::XS::install_simple_getter("Foo::y", "y"); -Moose::XS::install_simple_getter("Foo::z", "z"); -Moose::XS::install_simple_setter("Foo::set_z", "z"); -my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE" ); +my $ref = [ ]; + +my $foo = Foo->new( x => "ICKS", y => "WHY", z => "ZEE", ref => $ref ); is( $foo->x, "ICKS" ); is( $foo->y, "WHY" ); is( $foo->z, "ZEE" ); +is( $foo->ref, $ref, ); lives_ok { $foo->x("YASE") }; @@ -64,3 +73,19 @@ ok( $foo->has_x ); ok( !Foo->new->has_x ); +undef $ref; + +is( $foo->ref(), undef ); + +$ref = { }; + +$foo->ref($ref); + +is( $foo->ref, $ref, ); + +undef $ref; + +is( $foo->ref(), undef ); + +use Data::Dumper; +warn Dumper($foo);