X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=Moose.xs;h=6241b9d6a3f334d43aaab7b8e66949f1359fb812;hb=7bc5b9a9b9c535b0e0c92049e7d19dd681d3759e;hp=ef7a8d9ea3d5862eefb92f1cb66aec65707da314;hpb=677672703eb7e1721010ecbe6f1dd22a2775a9d4;p=gitmo%2FMoose.git diff --git a/Moose.xs b/Moose.xs index ef7a8d9..6241b9d 100644 --- a/Moose.xs +++ b/Moose.xs @@ -1,160 +1,1348 @@ - #include "EXTERN.h" #include "perl.h" #include "XSUB.h" + +#define NEED_grok_number +#define NEED_grok_numeric_radix +#define NEED_newRV_noinc +#define NEED_newSVpvn_share +#define NEED_sv_2pv_flags #include "ppport.h" -static bool ck_sv_defined(SV*); -static bool ck_sv_is_ref(SV*); -static bool ck_sv_ref_type(SV*, int); +#ifndef XSPROTO +#define XSPROTO(name) void name(pTHX_ CV* cv) +#endif + +#ifndef gv_stashpvs +#define gv_stashpvs(x, y) Perl_gv_stashpvn(aTHX_ STR_WITH_LEN(x), y) +#endif + +/* FIXME + * delegations and attribute helpers: + * + * typedef struct { + * ATTR *attr; + * pv *method; + * } delegation; + * + * typedef struct { + * ATTR *attr; + * I32 *type; // hash, array, whatever + vtable for operation + * } attributehelper; + */ + + + + + + + +/* These two functions attach magic with no behavior to an SV. + * + * The stashed value is reference counted, and is destroyed when it's parent + * object is destroyed. + * + * This is used to keep a reference the the meta attribute from a generated + * method, and to cache the C struct based wrapper attached to the meta + * instance. + */ + +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 */ +}; -static bool -ck_sv_defined(SV* value){ - return SvOK(value) ? 1 : 0; +STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) { + MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 ); + mg->mg_flags |= MGf_REFCOUNTED; + + return mg; } -static bool -ck_sv_is_ref(SV* value){ - bool retval = 0; - if( ck_sv_defined(value) && SvROK(value) ){ - retval = 1; - } - return retval; +STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) { + MAGIC *mg; + + if (SvTYPE(sv) >= SVt_PVMG) { + for (mg = SvMAGIC(sv); 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; + } + + return NULL; } -static bool -ck_sv_ref_type(SV* value, int sv_type){ - bool retval = 0; - if( ck_sv_is_ref(value) && SvTYPE( SvRV(value) ) == sv_type){ - retval = 1; - } - return retval; + + + + + + + + +/* The folloing data structures deal with type constraints */ + +/* this is an enum of the various kinds of constraint checking an attribute can + * have. + * + * tc_cv is the fallback behavior (simply applying the + * ->_compiled_type_constraint to the value, but other more optimal checks are + * implemented too. */ + +typedef enum { + tc_none = 0, /* no type checking */ + tc_type, /* a builtin type to be checked by check_sv_type */ + tc_stash, /* a stash for a class, implements TypeConstraint::Class by comparing SvSTASH and then invoking C if necessary */ + tc_cv, /* applies a code reference to the value and checks for truth */ + tc_fptr, /* apply a C function pointer */ + tc_enum /* TODO check that the value is in an allowed set of values (strings) */ +} tc_kind; + +/* this is a enum of builtin type check. They are handled in a switch statement + * in check_sv_type */ +typedef enum { + Any, /* or item, or bool */ + Undef, + Defined, + Str, /* or value */ + Num, + Int, + GlobRef, /* SVt_PVGV */ + ArrayRef, /* SVt_PVAV */ + HashRef, /* SVt_PVHV */ + CodeRef, /* SVt_PVCV */ + Ref, + ScalarRef, + FileHandle, /* TODO */ + RegexpRef, + Object, + Role, /* TODO */ + ClassName +} TC; + +/* auxillary pointer/int union used for constraint checking */ +typedef union { + TC type; /* the builtin type number for tc_type */ + SV *sv; /* the cv for tc_cv, or the stash for tc_stash */ + OP *op; /* TODO not used */ + bool (*fptr)(pTHX_ SV *type_constraint, SV *sv); /* the function pointer for tc_fptr FIXME aux data? */ +} TC_CHECK; + + + + + + +/* The folloing data structures deal with type default value generation */ + +/* This is an enum for the various types of default value behaviors an + * attribute can have */ + +typedef enum { + default_none = 0, /* no default value */ + default_normal, /* code reference or scalar */ + default_builder, /* builder method */ + default_type /* TODO enumerated type optimization (will call newHV, newAV etc to avoid calling a code ref for these simple cases) */ +} default_kind; + +typedef union { + SV *sv; /* The default value, or a code ref to generate one. If builder then this sv is applied as a method (stringified) */ + U32 type; /* TODO for default_type, should probably be one of SVt_PVAV/SVt_PVHV */ +} DEFAULT; + + + + + + +/* the ATTR struct contains all the meta data for a Moose::Meta::Attribute for + * a given meta instance + * + * flags determines the various behaviors + * + * This supports only one slot per attribute in the current implementation, but + * slot_sv could contain an array + * + * A list of XSUBs that rely on this attr struct are cross indexed in the cvs + * array, so that when the meta instance is destroyed the XSANY field will be + * cleared. This is done in delete_mi + * */ + +typedef struct { + /* pointer to the MI this attribute is a part of 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 (currently always slot name) */ + U32 slot_u32; /* for optimized access (precomputed hash, possibly something else) */ + + SV *init_arg_sv; + U32 init_arg_u32; + + DEFAULT def; /* cv, value or other, depending on flags */ + + TC_CHECK tc_check; /* see TC_CHECK*/ + SV *type_constraint; /* Moose::Meta::TypeConstraint object */ + + CV *trigger; + CV *initializer; + CV *writer; /* used by the initializer */ + + SV *meta_attr; /* the Moose::Meta::Attribute */ + AV *cvs; /* an array of CVs which use this attr, see delete_mi */ +} ATTR; + +/* the flags integer is mapped as follows + * instance misc reading writing + * 00000000 00000000 00000000 00000000 + * writing + * ^ trigger + * ^ weak + * ^ tc.sv is refcounted + * ^^^ tc_kind + * ^ coerce + * + * reading + * ^^^ default_kind + * ^ lazy + * ^ def.sv is refcounted + * + * misc + * ^ attr is required TODO + * + * flags having to do with the instance layout (TODO, only hash supported for now) + * ^^^^^^^ 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_DEFAULT 8 + +#define ATTR_LAZY 0x800 +#define ATTR_DEFREFCNT 0x1000 + +#define ATTR_COERCE 0x8 +#define ATTR_TCREFCNT 0x10 +#define ATTR_WEAK 0x20 +#define ATTR_TRIGGER 0x40 + +#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 ATTR_TYPE(f) ( attr->flags & 0x7 ) +#define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT ) + +#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 ) + + + +/* This unused (TODO) vtable will implement the meta instance protocol in terms + * of function pointers to allow the XS accessors to be used with custom meta + * instances in the future. + * + * We'll need to define a default instance of this vtable that uses call_sv, + * too. */ + +/* FIXME define a vtable that does call_sv for fallback meta instance protocol */ +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; + +/* TODO this table describes the instance layout of the object. Not yet + * implemented */ +typedef enum { + hash = 0, + + /* these are not yet implemented */ + array, + fptr, + cv, + judy +} instance_types; + + +/* this struct models the meta instance *and* meta attributes simultaneously. + * It is a cache of the meta attribute behaviors for a given class or subclass + * and can be parametrized on that level + * + * + * An object pointing to this structure is kept in a refcounted magic inside + * the meta instance it corresponds to. On C the meta + * instance is destroyed, causing the proxy object to be destroyed, deleting + * this structure, clearing the XSANY of all dependent attribute methods. + * + * The next invocation of an attribute method will eventually call get_attr, + * which will call C on the metaclass (recreating it in the + * Class::MOP level), and cache a new MI struct inside it. Subsequent + * invocations of get_attr will then search the MI for an ATTR matching the + * meta_attribute of the attribute method */ +typedef struct mi { + HV *stash; + + /* slot access method */ + instance_types type; /* TODO only hashes supported currently */ + instance_vtbl *vtbl; /* TODO */ + + /* attr descriptors */ + I32 num_attrs; + ATTR *attrs; +} MI; + + + + + + + + +/* these functions implement type constraint checking */ + +/* checks that the SV is a scalar ref */ +STATIC bool check_is_scalar_ref(SV *sv) { + if( SvROK(sv) ) { + switch (SvTYPE(SvRV(sv))) { + case SVt_IV: + case SVt_NV: + case SVt_PV: + case SVt_NULL: + return 1; + break; + default: + return 0; + } + } + return 0; } -static const char *regclass = "Regexp"; +/* checks that the SV is a ref to a certain SvTYPE, where type is in the table + * above */ +STATIC bool check_reftype(TC type, SV *sv) { + int svt; -MODULE = Moose PACKAGE = Moose::Util::TypeConstraints::OptimizedConstraints -PROTOTYPES: ENABLE + if ( !SvROK(sv) ) + return 0; -bool -Undef(value) - SV* value - CODE: - RETVAL = !ck_sv_defined(value); - OUTPUT: - RETVAL + switch (type) { + case GlobRef: + svt = SVt_PVGV; + break; + case ArrayRef: + svt = SVt_PVAV; + break; + case HashRef: + svt = SVt_PVHV; + break; + case CodeRef: + svt = SVt_PVCV; + break; + default: + croak("not a reftype %d\n", type); + } -bool -Defined(value) - SV* value - CODE: - RETVAL = ck_sv_defined(value); - OUTPUT: - RETVAL + return SvTYPE(SvRV(sv)) == svt; +} -bool -Value(value) - SV* value - CODE: - RETVAL = (ck_sv_defined(value) && !ck_sv_is_ref(value)) ? 1 : 0; - OUTPUT: - RETVAL +/* checks whether an SV is of a certain class + * SvSTASH is first compared by pointer for efficiency */ +STATIC bool check_sv_class(pTHX_ HV *stash, SV *sv) { + dSP; + bool ret; + SV *rv; -bool -Str(value) - SV* value - CODE: - RETVAL = (ck_sv_defined(value) && !ck_sv_is_ref(value)) ? 1 : 0; - OUTPUT: - RETVAL + if (!sv) + return 0; + SvGETMAGIC(sv); + if (!SvROK(sv)) + return 0; + rv = (SV*)SvRV(sv); + if (!SvOBJECT(rv)) + return 0; + if (SvSTASH(rv) == stash) + return 1; -bool -Ref(value) - SV* value - CODE: - RETVAL = ck_sv_is_ref(value); - OUTPUT: - RETVAL + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv); + XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0))); + PUTBACK; -bool -ScalarRef(value) - SV* value - CODE: - RETVAL = 0; - if( - SvOK(value) && SvROK(value) - ){ - int type = SvTYPE(SvRV(value)); - if( - type == SVt_IV || - type == SVt_NV || - type == SVt_PV || - type == SVt_NULL - ){ - RETVAL = 1; - } - } - OUTPUT: - RETVAL + call_method("isa", G_SCALAR); -bool -ArrayRef(value) - SV* value - CODE: - RETVAL = ck_sv_ref_type(value, SVt_PVAV); - OUTPUT: - RETVAL + SPAGAIN; + ret = SvTRUE(TOPs); -bool -HashRef(value) - SV* value - CODE: - RETVAL = (ck_sv_ref_type(value, SVt_PVHV) && !sv_isobject(value)) ? 1 : 0; - OUTPUT: - RETVAL + FREETMPS; + LEAVE; -bool -CodeRef(value) - SV* value - CODE: - RETVAL = ck_sv_ref_type(value, SVt_PVCV); - OUTPUT: - RETVAL + return ret; +} -bool -GlobRef(value) - SV* value - CODE: - RETVAL = ck_sv_ref_type(value, SVt_PVGV); - OUTPUT: - RETVAL +/* checks whether SV of of a known simple type. Most of the non parametrized + * Moose core types are implemented here */ +STATIC bool check_sv_type (TC type, SV *sv) { + if (!sv) + return 0; -bool -Object(value) - SV* value - CODE: - RETVAL = 0; - if( ck_sv_is_ref(value) - && sv_isobject(value) - && !sv_isa(value, regclass) - ){ - RETVAL = 1; - } - OUTPUT: - RETVAL + SvGETMAGIC(sv); -bool -RegexpRef(value) - SV* value - CODE: - RETVAL = 0; - if( ck_sv_is_ref(value) - && sv_isobject(value) - && sv_isa(value, regclass) - ){ - RETVAL = 1; + switch (type) { + case Any: + return 1; + break; + case Undef: + return !SvOK(sv); + break; + case Defined: + return SvOK(sv); + break; + case Str: + return (SvOK(sv) && !SvROK(sv)); + case Num: +#if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5) + if (!SvPOK(sv) && !SvPOKp(sv)) + return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); + else +#endif + return looks_like_number(sv); + break; + case Int: + if ( SvIOK(sv) ) { + return 1; + } else if ( SvPOK(sv) ) { + STRLEN len; + char *pv = SvPV(sv, len); + int flags = grok_number(pv, len, NULL); + return ( flags && !(flags & IS_NUMBER_NOT_INT) ); + } + return 0; + break; + case Ref: + return SvROK(sv); + break; + case ScalarRef: + return check_is_scalar_ref(sv); + break; + case ArrayRef: + case HashRef: + case CodeRef: + case GlobRef: + return check_reftype(type, sv); + break; + case RegexpRef: + case Object: + /* not using sv_isobject to avoid repeated get magic */ + if ( SvROK(sv) ) { + SV *rv = SvRV(sv); + if ( SvOBJECT(rv) ) { + char *name = HvNAME_get(SvSTASH(SvRV(sv))); + if ( name ) { + bool is_regexp = strEQ("Regexp", name); + return ( (type == RegexpRef) ^ !is_regexp ); + } + } + } + return 0; + break; + case ClassName: + if ( SvOK(sv) && !SvROK(sv) ) { + STRLEN len; + char *pv; + pv = SvPV(sv, len); + return ( gv_stashpvn(pv, len, 0) != NULL ); + } + return 0; + break; + case FileHandle: + croak("todo"); + break; + default: + croak("todo"); + } + + return 0; +} + +/* invoke a CV on an SV and return SvTRUE of the result */ +STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) { + SV *ret_sv; + bool ret; + dSP; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + XPUSHs(sv); + PUTBACK; + + call_sv(cv, G_SCALAR); + + SPAGAIN; + ret_sv = POPs; + ret = SvTRUE(ret_sv); + + PUTBACK; + FREETMPS; + LEAVE; + + return ret; +} + +/* checks the type constraint for an SV based on the type constraint kind */ +STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) { + switch (kind) { + case tc_none: + return 1; + break; + case tc_type: + return check_sv_type(tc_check.type, sv); + break; + case tc_stash: + return check_sv_class(aTHX_ (HV *)tc_check.sv, sv); + break; + case tc_fptr: + return tc_check.fptr(aTHX_ type_constraint, sv); + break; + case tc_cv: + return check_sv_cv(aTHX_ tc_check.sv, sv); + break; + case tc_enum: + croak("todo\n"); + break; } - OUTPUT: - RETVAL + + croak("todo"); + return 0; +} + + +/* end of type constraint checking functions */ + + + + + + + + + +/* Initialize the ATTR structure using positional arguments from Perl space. */ + +STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) { + U32 flags = 0; + U32 slot_hash, init_arg_hash; + STRLEN slot_len, init_arg_len; + char *slot_pv, *init_arg_pv; + I32 ix = av_len(desc); + SV **params = AvARRAY(desc); + SV *tc; + SV *slot_sv; + SV *init_arg_sv; + + attr->mi = mi; + + if ( ix != 13 ) + croak("wrong number of args (%d != 14)", (int)ix + 1); + + for ( ; ix >= 0; ix-- ) { + if ( !params[ix] || params[ix] == &PL_sv_undef ) + croak("bad params"); + } + + + + /* handle attribute slot array */ + + if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV ) + croak("slots is not an array"); + + if ( av_len((AV *)SvRV(params[1])) != 0 ) + croak("Only unary slots are supported at the moment"); + + /* calculate a hash from the slot */ + /* FIXME arrays etc should also be supported */ + slot_sv = *av_fetch((AV *)SvRV(params[1]), 0, 0); + slot_pv = SvPV(slot_sv, slot_len); + PERL_HASH(slot_hash, slot_pv, slot_len); + + + init_arg_sv = params[13]; + init_arg_pv = SvPV(init_arg_sv, init_arg_len); + PERL_HASH(init_arg_hash, init_arg_pv, init_arg_len); + + + /* FIXME better organize these, positionals suck */ + if ( SvTRUE(params[2]) ) + flags |= ATTR_WEAK; + + if ( SvTRUE(params[3]) ) + flags |= ATTR_COERCE; + + if ( SvTRUE(params[4]) ) + flags |= ATTR_LAZY; + + + + /* type constraint data */ + + tc = params[5]; + + if ( SvOK(tc) ) { + int tc_kind = SvIV(params[6]); + SV *data = params[7]; + + switch (tc_kind) { + case tc_type: + attr->tc_check.type = SvIV(data); + break; + case tc_stash: + flags |= ATTR_TCREFCNT; + attr->tc_check.sv = (SV *)gv_stashsv(data, 0); + break; + case tc_cv: + flags |= ATTR_TCREFCNT; + attr->tc_check.sv = SvRV(data); + if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV ) + croak("compiled type constraint is not a coderef"); + break; + default: + croak("todo"); + } + + flags |= tc_kind; + } + + + + /* default/builder data */ + + if ( SvTRUE(params[10]) ) { /* has default */ + SV *sv = params[11]; + + if ( SvROK(sv) ) { + attr->def.sv = SvRV(sv); + if ( SvTYPE(attr->def.sv) != SVt_PVCV ) + croak("compiled type constraint is not a coderef"); + } else { + attr->def.sv = newSVsv(sv); + sv_2mortal(attr->def.sv); /* in case of error soon, we refcnt inc it later after we're done checking params */ + } + + flags |= ( ATTR_DEFREFCNT | ( default_normal << ATTR_SHIFT_DEFAULT ) ); + } else if ( SvOK(params[12]) ) { /* builder */ + attr->def.sv = newSVsv(params[12]); + flags |= ( ATTR_DEFREFCNT | ( default_builder << ATTR_SHIFT_DEFAULT ) ); + } + + + + attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL; + if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV ) + croak("trigger is not a coderef"); + + attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL; + if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV ) + croak("initializer is not a coderef"); + + /* now that we're done preparing/checking args and shit, so we finalize the + * attr, increasing refcounts for any referenced data, and creating the CV + * array */ + + attr->flags = flags; + + /* copy the outer ref SV */ + attr->meta_attr = newSVsv(params[0]); + attr->type_constraint = newSVsv(tc); + + /* increase the refcount for auxillary structures */ + SvREFCNT_inc_simple_void(attr->trigger); + SvREFCNT_inc_simple_void(attr->initializer); + if ( flags & ATTR_TCREFCNT ) SvREFCNT_inc_simple_void_NN(attr->tc_check.sv); + if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc_simple_void_NN(attr->def.sv); + + attr->slot_sv = newSVpvn_share(slot_pv, slot_len, slot_hash); + attr->slot_u32 = slot_hash; + + attr->init_arg_sv = newSVpvn_share(init_arg_pv, init_arg_len, init_arg_hash); + attr->init_arg_u32 = init_arg_hash; + + /* cross refs to CVs which use this struct */ + attr->cvs = newAV(); +} + +STATIC SV *new_mi (pTHX_ HV *stash, AV *attrs) { + HV *mi_stash = gv_stashpvs("Moose::XS::Meta::Instance",0); + SV *sv_ptr = newSViv(0); + SV *obj = sv_2mortal(sv_bless(newRV_noinc(sv_ptr), mi_stash)); + MI *mi; + const I32 num_attrs = av_len(attrs) + 1; + + Newxz(mi, 1, MI); + + /* set the pointer now, if we have any initialization errors it'll get + * cleaned up because obj is mortal */ + sv_setiv(sv_ptr, PTR2IV(mi)); + + Newxz(mi->attrs, num_attrs, ATTR); + + SvREFCNT_inc_simple_void_NN(stash); + mi->stash = stash; + + mi->type = 0; /* nothing else implemented yet */ + + /* initialize attributes */ + for ( mi->num_attrs = 0; mi->num_attrs < num_attrs; mi->num_attrs++ ) { + SV **desc = av_fetch(attrs, mi->num_attrs, 0); + + if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) { + croak("Attribute descriptor has to be a hash reference"); + } + + init_attr(mi, &mi->attrs[mi->num_attrs], (AV *)SvRV(*desc)); + } + + return obj; +} + +STATIC void delete_attr (pTHX_ ATTR *attr) { + I32 i; + SV **cvs = AvARRAY(attr->cvs); + + /* remove the pointers to this ATTR struct from all the the dependent CVs */ + for ( i = av_len(attr->cvs); i >= 0; i-- ) { + CV *cv = (CV *)cvs[i]; + XSANY.any_i32 = 0; + } + + SvREFCNT_dec(attr->cvs); + SvREFCNT_dec(attr->slot_sv); + SvREFCNT_dec(attr->type_constraint); + if ( attr->flags & ATTR_TCREFCNT ) SvREFCNT_dec(attr->tc_check.sv); + if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv); + SvREFCNT_dec(attr->trigger); + SvREFCNT_dec(attr->initializer); + SvREFCNT_dec(attr->writer); + SvREFCNT_dec(attr->meta_attr); +} + +STATIC void delete_mi (pTHX_ MI *mi) { + SvREFCNT_dec(mi->stash); + + while ( mi->num_attrs--) { + ATTR *attr = &mi->attrs[mi->num_attrs]; + delete_attr(aTHX_ attr); + } + + if ( mi->attrs ) Safefree(mi->attrs); + Safefree(mi); +} + + +/* these functions call Perl-space for MOP methods, helpers etc */ + + +/* wow, so much code for the equivalent of + * $attr->associated_class->get_meta_instance */ +STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) { + dSP; + SV *mi; + + if ( !meta_attr ) + croak("No attr found in magic!"); + + ENTER; + SAVETMPS; + PUSHMARK(SP); + + XPUSHs(meta_attr); + + PUTBACK; + call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR); + + SPAGAIN; + mi = POPs; + + SvREFCNT_inc_simple_void(mi); + + PUTBACK; + FREETMPS; + LEAVE; + + return sv_2mortal(mi); +} + +/* gets a class and an array of attr parameters */ +STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) { + dSP; + I32 count; + SV *mi; + SV *class; + SV *attrs; + HV *stash; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + + XPUSHs(perl_mi); + + PUTBACK; + count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY); + + if ( count != 2 ) + croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", (int)count); + + SPAGAIN; + attrs = POPs; + class = POPs; + + PUTBACK; + + stash = gv_stashsv(class, 0); + + mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs)); + SvREFCNT_inc_simple_void_NN(mi); + + FREETMPS; + LEAVE; + + return sv_2mortal(mi); +} + + + +/* locate an ATTR for a MOP level attribute inside an MI */ +STATIC ATTR *mi_find_attr(SV *mi_obj, SV *meta_attr) { + I32 ix; + MI *mi = INT2PTR(MI *, SvIV(SvRV(mi_obj))); + + for ( ix = 0; ix < mi->num_attrs; ix++ ) { + if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) { + return &mi->attrs[ix]; + } + } + + croak("Attr %x not found in meta instance of %s", (unsigned int)PTR2UV(SvRV(meta_attr)) /* SvPV_force_nomg(sv_2mortal(newSVsv(meta_attr))) */, HvNAME_get(mi->stash) ); + return NULL; +} + +/* returns the ATTR for a CV: + * + * 1. get the Moose::Meta::Attribute using get_stashed_in_mg from the CV itself + * 2. get the meta instance by calling $attr->associated_class->get_meta_instance + * 3. get the MI by using get_stashed_in_mg from the meta instance, creating it if necessary + * 4. search for the appropriate ATTR in the MI using mi_find_attr + */ +STATIC ATTR *get_attr(pTHX_ CV *cv) { + SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv); + SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr); + SV *mi_obj = get_stashed_in_mg(aTHX_ SvRV(perl_mi)); + + if (!mi_obj) { + mi_obj = perl_mi_to_c_mi(aTHX_ perl_mi); + stash_in_mg(aTHX_ SvRV(perl_mi), mi_obj); + } + + return mi_find_attr(mi_obj, meta_attr); +} + +/* Cache a pointer to the appropriate ATTR in the XSANY of the CV, using + * get_attr */ +STATIC ATTR *define_attr (pTHX_ CV *cv) { + ATTR *attr = get_attr(aTHX_ cv); + assert(attr); + + XSANY.any_i32 = PTR2IV(attr); + + SvREFCNT_inc_simple_void(cv); + av_push( attr->cvs, (SV *)cv ); + + return attr; +} + + + + + + + +STATIC void weaken(pTHX_ SV *sv) { +#ifdef SvWEAKREF + 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 +} + + + + + + +/* meta instance protocol + * + * The slot functions don't change the refcount or copy (aliasing semantics) + * + * create_instance returns a new mortal */ + +STATIC SV *get_slot_lvalue(pTHX_ SV *self, ATTR *attr) { + HE *he; + + assert(self); + assert(SvROK(self)); + assert(SvTYPE(SvRV(self)) == SVt_PVHV); + + 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 bool 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) ); + + he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32); + + return he != NULL; +} + +STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) { + assert(self); + assert(SvROK(self)); + assert(SvTYPE(SvRV(self)) == SVt_PVHV); + + 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); +} + +STATIC SV *create_instance(pTHX_ MI *mi) { + return sv_bless(sv_2mortal(newRV_noinc((SV *)newHV())), mi->stash); +} + + + + +/* Shared functionality for readers/writers/accessors, this roughly corresponds + * to the methods of Moose::Meta::Attribute on the instance + * (get_value/set_value, default value handling, etc) + * + * These functions return mortal copiess and save copies (handling refcounting). */ + +STATIC void attr_set_common(pTHX_ SV *self, ATTR *attr, SV *value) { + SV *copy; + + if ( !value ) { + /* FIXME croak if required ? */ + return; + } + + if ( ATTR_TYPE(attr) ) { + if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) ) + croak("Bad param"); + } + + copy = newSVsv(value); + + if ( ATTR_ISWEAK(attr) && SvROK(copy) ) + weaken(aTHX_ copy); + + if ( !set_slot_value(aTHX_ self, attr, copy) ) { + SvREFCNT_dec(copy); + croak("Hash store failed."); + } +} + +STATIC void attr_set_initial_value(pTHX_ SV *self, ATTR *attr, SV *value) { + if ( attr->initializer ) { + croak("todo"); + } else { + attr_set_common(aTHX_ self, attr, value); + } +} + +STATIC SV *call_builder (pTHX_ SV *self, ATTR *attr) { + SV *sv; + dSP; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + + XPUSHs(self); + + /* we invoke the builder as a stringified method. This will not work for + * $obj->$coderef etc, for that we need to use 'default' */ + PUTBACK; + call_method(SvPV_nolen(attr->def.sv), G_SCALAR); + + /* the value is a mortal with a refcount of 1, so we need to keep it around */ + SPAGAIN; + sv = POPs; + SvREFCNT_inc_simple_void(sv); + + PUTBACK; + FREETMPS; + LEAVE; + + return sv_2mortal(sv); +} + + +STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) { + switch ( ATTR_DEFAULT(attr) ) { + case default_none: + return NULL; + break; + case default_builder: + return call_builder(aTHX_ self, attr); + break; + case default_normal: + if ( SvROK(attr->def.sv) ) { + printf("CV default\n"); + croak("todo"); + } else { + printf("simple value\n"); + return sv_mortalcopy(attr->def.sv); /* will be copied by set for lazy, and by reader for both cases */ + } + break; + case default_type: + croak("todo"); + break; + } + + return NULL; +} + +/* $attr->get_value($self), will vivify lazy values if needed + * returns an alias to the sv that is copied in the reader/writer/accessor code + * */ +STATIC SV *attr_get_value(pTHX_ SV *self, ATTR *attr) { + SV *value = get_slot_lvalue(aTHX_ self, attr); + + if ( value ) { + return sv_mortalcopy(value); + } else if ( ATTR_ISLAZY(attr) ) { + value = get_default(aTHX_ self, attr); + attr_set_initial_value(aTHX_ self, attr, value); + return value; + } + + return NULL; +} + +/* $attr->set_value($self) */ +STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value) { + attr_set_common(aTHX_ self, attr, value); + + if ( attr->trigger ) { + dSP; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + + /* FIXME copy self & meta attr? */ + XPUSHs(self); + XPUSHs(sv_2mortal(newSVsv(value))); + XPUSHs(attr->meta_attr); + + /* we invoke the builder as a stringified method. This will not work for + * $obj->$coderef etc, for that we need to use 'default' */ + PUTBACK; + call_method(SvPV_nolen(attr->def.sv), G_VOID); + + FREETMPS; + LEAVE; + } +} + + + + + + + +/* Perl-space level functionality + * + * These subs are installed by new_sub's various aliases as the bodies of the + * new XSUBs + * */ + + + +/* generate a new attribute method */ +STATIC CV *new_attr_method (pTHX_ SV *attr, XSPROTO(body), char *name) { + CV *cv = newXS(name, body, __FILE__); + + if (cv == NULL) + croak("Oi vey!"); + + /* associate CV with meta attr */ + stash_in_mg(aTHX_ (SV *)cv, attr); + + /* this will be set on first call */ + XSANY.any_i32 = 0; + + return cv; +} + + + + +/* This macro is used in the XS subs to set up the 'attr' variable. + * + * if XSANY is NULL then define_attr is called on the CV, to set the pointer + * to the ATTR struct. + * */ +#define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv)) + + +STATIC XS(reader); +STATIC XS(reader) +{ +#ifdef dVAR + dVAR; +#endif + dXSARGS; + dATTR; + SV *value; + + if (items != 1) + Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); + + SP -= items; + + value = attr_get_value(aTHX_ ST(0), attr); + + if (value) { + ST(0) = value; + XSRETURN(1); + } else { + XSRETURN_UNDEF; + } +} + +STATIC XS(writer); +STATIC XS(writer) +{ +#ifdef dVAR + dVAR; +#endif + dXSARGS; + dATTR; + + if (items != 2) + Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value"); + + SP -= items; + + attr_set_value(aTHX_ ST(0), attr, ST(1)); + + ST(0) = ST(1); /* return value */ + XSRETURN(1); +} + +STATIC XS(accessor); +STATIC XS(accessor) +{ +#ifdef dVAR + dVAR; +#endif + dXSARGS; + dATTR; + + if (items < 1) + Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value"); + + SP -= items; + + if (items > 1) { + attr_set_value(aTHX_ ST(0), attr, ST(1)); + ST(0) = ST(1); /* return value */ + } else { + SV *value = attr_get_value(aTHX_ ST(0), attr); + if ( value ) { + ST(0) = value; + } else { + XSRETURN_UNDEF; + } + } + + XSRETURN(1); +} + +STATIC XS(predicate); +STATIC XS(predicate) +{ +#ifdef dVAR + dVAR; +#endif + dXSARGS; + dATTR; + + if (items != 1) + Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); + + SP -= items; + + if ( has_slot_value(aTHX_ ST(0), attr) ) + XSRETURN_YES; + else + XSRETURN_NO; +} + + + + + + + +enum xs_body { + xs_body_reader = 0, + xs_body_writer, + xs_body_accessor, + xs_body_predicate, + max_xs_body +}; + +STATIC XSPROTO ((*xs_bodies[])) = { + reader, + writer, + accessor, + predicate, +}; + +MODULE = Moose PACKAGE = Moose::XS +PROTOTYPES: ENABLE + +CV * +new_attr_method(attr, name) + INPUT: + SV *attr; + SV *name; + PROTOTYPE: $;$ + PREINIT: + char *pv = SvOK(name) ? SvPV_nolen(name) : NULL; + ALIAS: + new_reader = xs_body_reader + new_writer = xs_body_writer + new_accessor = xs_body_accessor + new_predicate = xs_body_predicate + CODE: + if ( ix >= max_xs_body ) + croak("Unknown Moose::XS body type"); + + if ( !sv_isobject(attr) ) + croak("'attr' must be a Moose::Meta::Attribute"); + + RETVAL = new_attr_method(aTHX_ attr, xs_bodies[ix], pv); + OUTPUT: + RETVAL + + +MODULE = Moose PACKAGE = Moose::XS::Meta::Instance +PROTOTYPES: DISABLE + +void +DESTROY(self) + INPUT: + SV *self; + PREINIT: + MI *mi = INT2PTR(MI *, SvIV(SvRV(self))); + CODE: + if ( mi ) + delete_mi(aTHX_ mi); + + +MODULE = Moose PACKAGE = Moose::XS::TypeConstraints +PROTOTYPES: ENABLE + +bool +_check_type(sv) + INPUT: + SV* sv + ALIAS: + Any = Any + Item = Any + Bool = Any + Undef = Undef + Defined = Defined + Str = Str + Value = Str + Num = Num + Int = Int + GlobRef = GlobRef + ArrayRef = ArrayRef + HashRef = HashRef + CodeRef = CodeRef + Ref = Ref + ScalarRef = ScalarRef + FileHandle = FileHandle + RegexpRef = RegexpRef + Object = Object + Role = Role + ClassName = ClassName + CODE: + RETVAL = check_sv_type(ix, sv); + OUTPUT: + RETVAL + +bool +ObjectOfType(sv, class) + INPUT: + SV* sv + SV* class + PREINIT: + HV *stash = gv_stashsv(class, 0); + CODE: + RETVAL = check_sv_class(aTHX_ stash, sv); + OUTPUT: + RETVAL