[gitmo/Moose.git] / Moose.xs

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

/* 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 ATTR slots[]
 *
 * 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
 * type constraints are already implemented by konobi
 * should be trivial to do coercions for the core types, too
 *
 * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then*
 * call ->isa (should handle vast majority of cases)
 *
 * base parametrized types are also trivial
 *
 * ClassName is get_stathpvn
 */

/* FIXME
 * 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
 * */

/* 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;
 */


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 {
    /* 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 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 )

#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;
    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);

    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 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); /* 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 */

STATIC SV *get_slot_value(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 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), attr->slot_sv, value, attr->slot_u32);
    if (he != NULL) {
        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(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);
}


/* simple high level api */

STATIC XS(getter);
STATIC XS(getter)
{
#ifdef dVAR
    dVAR;
#endif
    dXSARGS;
    dATTR;
    SV *value;

    if (items != 1)
        Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");

    SP -= items;

    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 */
        XSRETURN(1);
    } else {
        XSRETURN_UNDEF;
    }
}

STATIC XS(setter);
STATIC XS(setter)
{
#ifdef dVAR
    dVAR;
#endif
    dXSARGS;
    dATTR;

    if (items != 2)
        Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");

    SP -= items;

    assert( ATTR_DUMB_WRITER(attr) );

    set_slot_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) {
        assert( ATTR_DUMB_READER(attr) );
        set_slot_value(aTHX_ ST(0), attr, ST(1));
        ST(0) = ST(1); /* return value */
    } else {
        assert( ATTR_DUMB_WRITER(attr) );
        SV *value = get_slot_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_getter = 0,
    xs_body_setter,
    xs_body_accessor,
    xs_body_predicate,
    max_xs_body
};

STATIC XSPROTO ((*xs_bodies[])) = {
    getter,
    setter,
    accessor,
    predicate,
};

MODULE = Moose PACKAGE = Moose::XS

CV *
new_sub(attr, name)
    INPUT:
        SV *attr;
        SV *name;
    ALIAS:
        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");

        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!");

        /* 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:
        RETVAL
Commit	Line	Data
1ea12c91	1	#include "EXTERN.h"
	2	#include "perl.h"
	3	#include "XSUB.h"
	4
1ea12c91	5	/* FIXME
	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.
	9	*
de2f2e97	10	* Instance contains SvSTASH, and ATTR slots[]
1ea12c91	11	*
de2f2e97	12	* On recreation of the meta instance we refresh the ATTR value of all the CVs
1ea12c91	13	* we installed
	14	*
	15	* need a good way to handle time between invalidate and regeneration (just
	16	* check XSANY and call get_meta_instance if null?)
	17	*/
	18
1ea12c91	19	/* FIXME
	20	* type constraints are already implemented by konobi
	21	* should be trivial to do coercions for the core types, too
	22	*
	23	* TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq then
	24	* call ->isa (should handle vast majority of cases)
	25	*
	26	* base parametrized types are also trivial
	27	*
	28	* ClassName is get_stathpvn
	29	*/
	30
	31	/* FIXME
de2f2e97	32	* for a constructor we have ATTR *attrs, and iterate that, removing init_arg
1ea12c91	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
	35	* */
	36
	37	/* FIXME
	38	* delegations and attribute helpers:
	39	*
	40	* typedef struct {
de2f2e97	41	* ATTR *attr;
1ea12c91	42	* pv *method;
	43	* } delegation;
	44	*
	45	* typedef struct {
de2f2e97	46	* ATTR *attr;
1ea12c91	47	* I32 *type; // hash, array, whatever + vtable for operation
	48	* } attributehelper;
	49	*/
	50
de2f2e97	51
	52	STATIC MGVTBL null_mg_vtbl = {
	53	NULL, /* get */
	54	NULL, /* set */
	55	NULL, /* len */
	56	NULL, /* clear */
	57	NULL, /* free */
	58	#if MGf_COPY
	59	NULL, /* copy */
	60	#endif /* MGf_COPY */
	61	#if MGf_DUP
	62	NULL, /* dup */
	63	#endif /* MGf_DUP */
	64	#if MGf_LOCAL
	65	NULL, /* local */
	66	#endif /* MGf_LOCAL */
	67	};
	68
	69
	70
	71	typedef enum {
	72	Any = 0,
	73	Item,
	74	Bool,
	75	Maybe, /* [`a] */
	76	Undef,
	77	Defined,
	78	Value,
	79	Num,
	80	Int,
	81	Str,
	82	ClassName,
	83	Ref,
	84	ScalarRef,
	85	ArrayRef, /* [`a] */
	86	HashRef, /* [`a] */
	87	CodeRef,
	88	RegexpRef,
	89	GlobRef,
	90	FileHandle,
	91	Object,
	92	Role,
	93
	94	/* XS only types */
	95	Class,
	96
	97	max_TC
	98	} TC;
	99
	100	typedef union {
	101	TC type;
	102	CV *cv;
	103	HV *stash;
	104	OP *op;
	105	} TC_CHECK;
	106
	107	typedef enum {
	108	tc_none = 0,
	109	tc_type,
	110	tc_cv,
	111	tc_stash,
	112	tc_op,
	113	} tc_kind;
	114
115	typedef union {
116	char *builder;
117	SV *value;
118	CV *sub;
119	OP *op;
120	U32 type;
121	} DEFAULT;
122
123	typedef enum {
124	default_none = 0,
125	default_type,
126	default_builder,
127	default_value,
128	default_sub,
129	default_op,
130	} default_kind;
131
1ea12c91	132	typedef struct {
de2f2e97	133	/* the meta instance struct */
	134	struct mi *mi;
	135
	136	U32 flags; /* slot type, TC behavior, coerce, weaken, (no default \| default, builder + lazy), auto_deref */
	137
	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) */
	141
	142	DEFAULT def; /* cv, value or other, depending on flags */
	143
	144	TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
	145	SV type_constraint; / meta attr */
	146
	147	CV *initializer;
	148	CV *trigger;
	149
	150	SV attr; / the meta attr object */
	151	AV cvs; / CVs which use this attr */
	152	} ATTR;
	153
	154	/* slot flags:
	155	* instance reading writing
	156	* 00000000 00000000 00000000 00000000
	157	* ^ trigger
	158	* ^ weak
	159	* ^^^ tc_kind
	160	* ^ coerce
	161	* ^^^ default_kind
	162	* ^ lazy
	163	* ^ required
	164	* ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD
	165	*/
	166
	167	#define ATTR_INSTANCE_MASK 0xff000000
	168	#define ATTR_READING_MASK 0x0000ff00
	169	#define ATTR_WRITING_MASK 0x000000ff
	170
	171	#define ATTR_MASK_TYPE 0x7
	172
	173	#define ATTR_MASK_DEFAULT 0x700
	174	#define ATTR_SHIFT_DEAFULT 8
	175
	176	#define ATTR_LAZY 0x800
	177
	178	#define ATTR_COERCE 0x08
	179	#define ATTR_WEAK 0x10
	180	#define ATTR_TRIGGER 0x10
	181
	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 )
1ea12c91	185
de2f2e97	186	#define ATTR_TYPE(f) ( attr->flags & 0x7 )
de2f2e97	187	#define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
1ea12c91	188
de2f2e97	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 )
1ea12c91	192
de2f2e97	193	#define dATTR ATTR attr = (INT2PTR(ATTR , (XSANY.any_i32 \|\| define_attr(aTHX_ cv))))
	194
	195
	196	/* FIXME define a vtable that does call_sv */
	197	typedef struct {
	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);
	202	} instance_vtbl;
	203
	204
	205	typedef enum {
	206	hash = 0,
	207
	208	/* these are not yet implemented */
	209	array,
	210	fptr,
	211	cv,
	212	judy,
	213	} instance_types;
	214
	215	typedef struct mi {
	216	SV *associated_metaclass;
	217	HV *stash;
	218
	219	/* slot access method */
	220	instance_types type;
	221	instance_vtbl *vtbl;
	222
	223	/* attr descriptors */
	224	I32 num_attrs;
	225	ATTR *attrs;
	226	} MI;
	227
	228
	229	STATIC void init_attr (MI mi, ATTR attr, HV *desc) {
1ea12c91	230	U32 hash;
1ea12c91	231	STRLEN len;
de2f2e97	232	SV **key = hv_fetchs(desc, "key", 0);
	233	SV **meta_attr = hv_fetchs(desc, "meta", 0);
	234	char *pv;
	235
	236	if ( !meta_attr ) croak("'meta' is required");
	237
	238	attr->attr = *meta_attr;
	239
	240	attr->mi = mi;
	241
	242	attr->flags = 0;
	243
	244
	245	/* if type == hash */
	246	/* prehash the key */
	247	if ( !key ) croak("'key' is required");
	248
	249	pv = SvPV(*key, len);
1ea12c91	250
1ea12c91	251	PERL_HASH(hash, pv, len);
1ea12c91	252
de2f2e97	253	attr->slot_sv = newSVpvn_share(pv, len, hash);
	254	attr->slot_u32 = hash;
	255
	256	attr->def.type = 0;
	257
	258	attr->tc_check.type = 0;
	259	attr->type_constraint = NULL;
	260
	261
	262	attr->initializer = NULL;
	263	attr->trigger = NULL;
	264
	265	/* cross refs to CVs which use this struct */
	266	attr->cvs = newAV();
	267	}
	268
	269	STATIC MI new_mi (pTHX_ HV stash, SV meta, AV attrs) {
	270	MI *mi;
	271	I32 ix;
	272	const I32 num = av_len(attrs) + 1;
	273
	274	Newx(mi, 1, MI);
	275
	276	SvREFCNT_inc_simple(stash);
	277	mi->stash = stash;
	278
	279	SvREFCNT_inc_simple(meta);
	280	mi->associated_metaclass = meta;
	281
	282	mi->type = 0; /* nothing else implemented yet */
	283
	284	/* initialize attributes */
	285	mi->num_attrs = num;
	286	Newx(mi->attrs, num, ATTR);
	287	for ( ix = 0; ix < mi->num_attrs; ix++ ) {
	288	SV **desc = av_fetch(attrs, ix, 0);
	289
	290	if ( !desc \|\| !SvROK(desc) \|\| !(SvTYPE(SvRV(desc)) == SVt_PVHV) )
	291	croak("Attribute descriptor has to be a hash reference");
	292
	293	init_attr(mi, &mi->attrs[ix], (HV )SvRV(desc));
	294	}
	295
	296	return mi;
	297	}
	298
	299	STATIC SV get_meta_attr_from_mg(pTHX_ CV cv) {
	300	MAGIC mg, moremagic;
	301
	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))
	305	break;
	306	}
	307	if (mg)
	308	return mg->mg_obj;
	309	}
	310
	311	croak("No attr found in magic!");
	312	return NULL;
	313	}
	314
	315	STATIC ATTR get_attr(pTHX_ CV cv) {
	316	SV *meta_attr = get_meta_attr_from_mg(aTHX_ cv);
317
318	#if 0
319	my $mi = $meta_attr->associated_metaclass->get_meta_instance;
320	my @attrs = map {
321	{
322	meta => $_,
323	key => ($_->slots)[0],
324	},
325	} @{ $mi->attributes };
326	#else
327	croak("todo");
328	#endif
329
330	return NULL;
1ea12c91	331	}
1ea12c91	332
de2f2e97	333	STATIC ATTR define_attr (pTHX_ CV cv) {
	334	ATTR *attr = get_attr(aTHX_ cv);
	335	assert(attr);
	336
	337	XSANY.any_i32 = PTR2IV(attr);
	338	av_push( attr->cvs, cv );
	339
	340	return attr;
	341	}
	342
	343	STATIC void weaken(pTHX_ SV *sv) {
1ea12c91	344	#ifdef SvWEAKREF
de2f2e97	345	sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
1ea12c91	346	#else
	347	croak("weak references are not implemented in this release of perl");
	348	#endif
	349	}
	350
	351
	352	/* meta instance protocol */
	353
de2f2e97	354	STATIC SV get_slot_value(pTHX_ SV self, ATTR *attr) {
1ea12c91	355	HE *he;
	356
	357	assert(self);
	358	assert(SvROK(self));
	359	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	360
de2f2e97	361	assert( ATTR_DUMB_INSTANCE(attr) );
	362
	363	if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
1ea12c91	364	return HeVAL(he);
	365	else
	366	return NULL;
	367	}
	368
de2f2e97	369	STATIC void set_slot_value(pTHX_ SV self, ATTR attr, SV *value) {
1ea12c91	370	HE *he;
	371
	372	assert(self);
	373	assert(SvROK(self));
	374	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	375
de2f2e97	376	assert( ATTR_DUMB_INSTANCE(attr) );
de2f2e97	377
1ea12c91	378	SvREFCNT_inc(value);
1ea12c91	379
de2f2e97	380	he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32);
1ea12c91	381	if (he != NULL) {
de2f2e97	382	if ( ATTR_ISWEAK(attr) )
de2f2e97	383	weaken(aTHX_ HeVAL(he)); /* actually only needed once at HE creation time */
1ea12c91	384	} else {
	385	croak("Hash store failed.");
	386	}
	387	}
	388
de2f2e97	389	STATIC bool has_slot_value(pTHX_ SV self, ATTR attr) {
1ea12c91	390	assert(self);
	391	assert(SvROK(self));
	392	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	393
de2f2e97	394	assert( ATTR_DUMB_INSTANCE(attr) );
	395
	396	return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
	397	}
	398
	399	STATIC SV deinitialize_slot(pTHX_ SV self, ATTR *attr) {
	400	assert(self);
	401	assert(SvROK(self));
	402	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	403
	404	assert( ATTR_DUMB_INSTANCE(attr) );
	405
	406	return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
1ea12c91	407	}
	408
	409
	410	/* simple high level api */
	411
de2f2e97	412	STATIC XS(getter);
de2f2e97	413	STATIC XS(getter)
1ea12c91	414	{
	415	#ifdef dVAR
	416	dVAR;
	417	#endif
	418	dXSARGS;
de2f2e97	419	dATTR;
1ea12c91	420	SV *value;
	421
	422	if (items != 1)
	423	Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
	424
	425	SP -= items;
	426
de2f2e97	427	assert( ATTR_DUMB_READER(attr) );
	428
	429	value = get_slot_value(aTHX_ ST(0), attr);
1ea12c91	430
	431	if (value) {
	432	ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
	433	XSRETURN(1);
	434	} else {
	435	XSRETURN_UNDEF;
	436	}
	437	}
	438
de2f2e97	439	STATIC XS(setter);
de2f2e97	440	STATIC XS(setter)
1ea12c91	441	{
	442	#ifdef dVAR
	443	dVAR;
	444	#endif
	445	dXSARGS;
de2f2e97	446	dATTR;
1ea12c91	447
	448	if (items != 2)
	449	Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
	450
	451	SP -= items;
	452
de2f2e97	453	assert( ATTR_DUMB_WRITER(attr) );
	454
	455	set_slot_value(aTHX_ ST(0), attr, ST(1));
1ea12c91	456
	457	ST(0) = ST(1); /* return value */
	458	XSRETURN(1);
	459	}
	460
de2f2e97	461	STATIC XS(accessor);
de2f2e97	462	STATIC XS(accessor)
1ea12c91	463	{
	464	#ifdef dVAR
	465	dVAR;
	466	#endif
	467	dXSARGS;
de2f2e97	468	dATTR;
1ea12c91	469
	470	if (items < 1)
	471	Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
	472
	473	SP -= items;
	474
	475	if (items > 1) {
de2f2e97	476	assert( ATTR_DUMB_READER(attr) );
de2f2e97	477	set_slot_value(aTHX_ ST(0), attr, ST(1));
1ea12c91	478	ST(0) = ST(1); /* return value */
1ea12c91	479	} else {
de2f2e97	480	assert( ATTR_DUMB_WRITER(attr) );
de2f2e97	481	SV *value = get_slot_value(aTHX_ ST(0), attr);
1ea12c91	482	if ( value ) {
	483	ST(0) = value;
	484	} else {
	485	XSRETURN_UNDEF;
	486	}
	487	}
	488
	489	XSRETURN(1);
	490	}
	491
	492	STATIC XS(predicate);
	493	STATIC XS(predicate)
	494	{
	495	#ifdef dVAR
	496	dVAR;
	497	#endif
	498	dXSARGS;
de2f2e97	499	dATTR;
1ea12c91	500
	501	if (items != 1)
	502	Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
	503
	504	SP -= items;
	505
de2f2e97	506	if ( has_slot_value(aTHX_ ST(0), attr) )
1ea12c91	507	XSRETURN_YES;
	508	else
	509	XSRETURN_NO;
	510	}
	511
	512	enum xs_body {
de2f2e97	513	xs_body_getter = 0,
	514	xs_body_setter,
	515	xs_body_accessor,
1ea12c91	516	xs_body_predicate,
	517	max_xs_body
	518	};
	519
	520	STATIC XSPROTO ((*xs_bodies[])) = {
de2f2e97	521	getter,
	522	setter,
	523	accessor,
1ea12c91	524	predicate,
	525	};
	526
	527	MODULE = Moose PACKAGE = Moose::XS
	528
	529	CV *
de2f2e97	530	new_sub(attr, name)
1ea12c91	531	INPUT:
de2f2e97	532	SV *attr;
de2f2e97	533	SV *name;
1ea12c91	534	ALIAS:
de2f2e97	535	new_getter = xs_body_getter
	536	new_setter = xs_body_setter
	537	new_accessor = xs_body_accessor
	538	new_predicate = xs_body_predicate
1ea12c91	539	PREINIT:
	540	CV * cv;
	541	CODE:
	542	if ( ix >= max_xs_body )
	543	croak("Unknown Moose::XS body type");
	544
de2f2e97	545	if ( !sv_isobject(attr) )
	546	croak("'attr' must be a Moose::Meta::Attribute");
	547
	548	cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
1ea12c91	549
	550	if (cv == NULL)
	551	croak("Oi vey!");
	552
de2f2e97	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") );
	555
	556	/* this will be set on first call */
	557	XSANY.any_i32 = 0;
1ea12c91	558
	559	RETVAL = cv;
	560	OUTPUT:
	561	RETVAL
	562
	563