[gitmo/Moose.git] / Moose.xs

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

#define NEED_newRV_noinc
#define NEED_newSVpvn_share
#define NEED_sv_2pv_flags
#include "ppport.h"

#ifndef XSPROTO
#define XSPROTO(name) void name(pTHX_ CV* cv)
#endif

#ifndef gv_stashpvs
#define gv_stashpvs(x, y) gv_stashpvn(STR_WITH_LEN(x), y)
#endif

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

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 SV *get_stashed_in_mg(pTHX_ SV *sv) {
    MAGIC *mg, *moremagic;

    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;
}


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 *meta_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 = (XSANY.any_i32 ? 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 {
    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->meta_attr = newSVsv(*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, AV *attrs) {
    MI *mi;
    I32 ix;
    const I32 num = av_len(attrs) + 1;

    Newx(mi, 1, MI);

    SvREFCNT_inc_simple(stash);
    mi->stash = stash;

    mi->type = 0; /* nothing else implemented yet */

    /* initialize attributes */
    mi->num_attrs = num;
    Newx(mi->attrs, num, ATTR);
    for ( ix = 0; ix < num; ix++ ) {
        SV **desc = av_fetch(attrs, ix, 0);

        if ( !desc || !*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 *new_mi_obj (pTHX_ MI *mi) {
    HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
    SV *obj = newRV_noinc(newSViv(PTR2IV(mi)));
    sv_bless( obj, stash );
    return obj;
}

STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
    dSP;
    I32 count;
    SV *mi;

    if ( !meta_attr )
        croak("No attr found in magic!");

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    XPUSHs(meta_attr);
    PUTBACK;
    count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);

    if ( count != 1 )
        croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);

    SPAGAIN;
    mi = POPs;

    SvREFCNT_inc(mi);

    PUTBACK;
    FREETMPS;
    LEAVE;

    return mi;
}

STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
    dSP;
    I32 count;
    MI *mi = NULL;
    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)", count);

    SPAGAIN;
    attrs = POPs;
    class = POPs;

    PUTBACK;

    stash = gv_stashsv(class, 0);

    mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));

    FREETMPS;
    LEAVE;

    return new_mi_obj(aTHX_ mi);
}

STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
    I32 ix;

    for ( ix = 0; ix < mi->num_attrs; ix++ ) {
        if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
            return &mi->attrs[ix];
        }
    }

    sv_dump(meta_attr);
    croak("Attr not found");
    return NULL;
}

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 *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
    MI *mi;

    if (!c_mi) {
        c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
        stash_in_mg(aTHX_ perl_mi, c_mi);
    }

    sv_2mortal(perl_mi);

    mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));

    return mi_find_attr(mi, meta_attr);
}

STATIC ATTR *define_attr (pTHX_ CV *cv) {
    ATTR *attr = get_attr(aTHX_ cv);
    assert(attr);

    XSANY.any_i32 = PTR2IV(attr);

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

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 {
        SV *value;
        assert( ATTR_DUMB_WRITER(attr) );
        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 */
        stash_in_mg(aTHX_ (SV *)cv, attr);

        /* this will be set on first call */
        XSANY.any_i32 = 0;

        RETVAL = cv;
    OUTPUT:
        RETVAL


MODULE = Moose  PACKAGE = Moose::XS::Meta::Instance

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