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

/* this is a enum of checks */
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,
    RegexpRef,
    Object,
    ClassName,
    /* complex checks */
    Role,
    Enum,
} TC;

typedef enum {
    tc_none = 0,
    tc_type,
    tc_stash,
    tc_cv,
    tc_op,
    tc_fptr,
} tc_kind;

typedef union {
    TC type;
    HV *stash;
    CV *cv;
    OP *op;
    bool (*fptr)(pTHX_ SV *type_constraint, SV *sv);
} TC_CHECK;

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 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 bool check_reftype(TC type, SV *sv) {
    int svt;

    if ( !SvROK(sv) )
        return 0;

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

    return SvTYPE(SvRV(sv)) == svt;
}

STATIC bool check_sv_class (pTHX_ HV *stash, SV *sv) {
    dSP;
    bool ret;

    if (!sv)
        return 0;
    SvGETMAGIC(sv);
    if (!SvROK(sv))
        return 0;
    sv = (SV*)SvRV(sv);
    if (!SvOBJECT(sv))
        return 0;
    if (SvSTASH(sv) == stash)
        return 1;

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    XPUSHs(sv);
    XPUSHs(newSVpv(HvNAME_get(SvSTASH(sv)), 0));
    PUTBACK;

    call_method("isa", G_SCALAR);

    SPAGAIN;
    ret = SvTRUE(TOPs);

    FREETMPS;
    LEAVE;

    return ret;
}

STATIC bool check_sv_type (TC type, SV *sv) {
    if (!sv)
        return 0;

    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) ) {
                croak("todo");
                int i;
                STRLEN len;
                char *pv = SvPV(sv, len);
                char *end = pv + len;

                errno = 0;
                i = strtol(pv, &end, 0);
                return !errno;
            }
            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 Object:
            return sv_isobject(sv);
            break;
        case ClassName:
            {
                STRLEN len;
                char *pv;
                pv = SvPV(sv, len);
                return ( gv_stashpvn(pv, len, 0) != NULL );
                break;
            }
        case RegexpRef:
            return sv_isa(sv, "Regexp");
            break;
        case FileHandle:
            croak("todo");
            break;
        default:
            croak("todo");
    }

    return 0;
}

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_ tc_check.stash, sv);
            break;
        case tc_fptr:
            return tc_check.fptr(aTHX_ type_constraint, sv);
            break;
        case tc_cv:
        case tc_op:
            croak("todo");
            break;
    }

    croak("todo");
    return 0;
}


STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
    U32 flags = 0;
    U32 hash;
    STRLEN len;
    char *pv;
    I32 ix = av_len(desc);
    SV **params = AvARRAY(desc);
    SV *tc;
    SV *key;

    attr->mi = mi;


    if ( ix != 12 )
        croak("wrong number of args (%d != 13)", ix + 1);

    for ( ; ix >= 0; ix-- ) {
        if ( !params[ix] || params[ix] == &PL_sv_undef )
            croak("bad params");
    }

    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 */
    key = *av_fetch((AV *)SvRV(params[1]), 0, 0);
    pv = SvPV(key, len);
    PERL_HASH(hash, pv, len);


    /* FIXME better organize these */
    if ( SvTRUE(params[2]) )
        flags |= ATTR_WEAK;

    if ( SvTRUE(params[3]) )
        flags |= ATTR_COERCE;

    if ( SvTRUE(params[4]) )
        flags |= ATTR_LAZY;

    tc = params[5];

    if ( SvOK(tc) ) {
        int tc_kind = SvIV(params[6]);
        SV *data = params[7];

        switch (tc_kind) {
            case tc_stash:
                attr->tc_check.stash = gv_stashsv(data, 0);
                break;
            case tc_type:
                attr->tc_check.type = SvIV(data);
                break;
            case tc_cv:
                attr->tc_check.cv = (CV *)SvRV(data);
                if ( SvTYPE(attr->tc_check.cv) != SVt_PVCV )
                    croak("compiled type constraint is not a coderef");
                break;
            default:
                croak("todo");
        }

        flags |= tc_kind;
    }

    attr->flags = flags; /* FIXME default_kind */

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

    /* copy refs */
    attr->meta_attr       = newSVsv(params[0]);
    attr->type_constraint = newSVsv(tc);
    if ( attr->trigger )     SvREFCNT_inc(attr->trigger);
    if ( attr->initializer ) SvREFCNT_inc(attr->initializer);

    attr->slot_sv = newSVpvn_share(pv, len, hash);
    attr->slot_u32 = hash;

    attr->def.type = 0;

    /* 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_PVAV) ) {
            croak("Attribute descriptor has to be a hash reference");
        }

        init_attr(mi, &mi->attrs[ix], (AV *)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;
    SV *copy;

    assert(self);
    assert(SvROK(self));
    assert(SvTYPE(SvRV(self)) == SVt_PVHV);

    assert( ATTR_DUMB_INSTANCE(attr) );

    copy = newSVsv(value);

    he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);

    if (he != NULL) {
        if ( ATTR_ISWEAK(attr) )
            weaken(aTHX_ HeVAL(he));
    } else {
        SvREFCNT_dec(copy);
        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);
}

STATIC SV *getter_common(pTHX_ SV *self, ATTR *attr) {
    assert( ATTR_DUMB_READER(attr) );
    return get_slot_value(aTHX_ self, attr);
}

STATIC void setter_common(pTHX_ SV *self, ATTR *attr, SV *value) {
    if ( attr->flags & ATTR_MASK_TYPE ) {
        if ( !check_type_constraint(aTHX_ attr->flags & ATTR_MASK_TYPE, attr->tc_check, attr->type_constraint, value) )
            croak("Bad param");
    }

    set_slot_value(aTHX_ self, attr, value);
}

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

    value = getter_common(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;

    setter_common(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) {
        setter_common(aTHX_ ST(0), attr, ST(1));
        ST(0) = ST(1); /* return value */
    } else {
        SV *value = getter_common(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
4c6fbfb1	90	/* this is a enum of checks */
de2f2e97	91	typedef enum {
4c6fbfb1	92	Any, /* or item, or bool */
	93	Undef,
	94	Defined,
	95	Str, /* or value */
	96	Num,
	97	Int,
	98	GlobRef, /* SVt_PVGV */
	99	ArrayRef, /* SVt_PVAV */
	100	HashRef, /* SVt_PVHV */
	101	CodeRef, /* SVt_PVCV */
	102	Ref,
	103	ScalarRef,
	104	FileHandle,
	105	RegexpRef,
	106	Object,
160f9ca7	107	ClassName,
4c6fbfb1	108	/* complex checks */
4c6fbfb1	109	Role,
4c6fbfb1	110	Enum,
de2f2e97	111	} TC;
de2f2e97	112
de2f2e97	113	typedef enum {
	114	tc_none = 0,
	115	tc_type,
160f9ca7	116	tc_stash,
de2f2e97	117	tc_cv,
de2f2e97	118	tc_op,
4c6fbfb1	119	tc_fptr,
de2f2e97	120	} tc_kind;
	121
	122	typedef union {
4c6fbfb1	123	TC type;
160f9ca7	124	HV *stash;
4c6fbfb1	125	CV *cv;
4c6fbfb1	126	OP *op;
4c6fbfb1	127	bool (fptr)(pTHX_ SV type_constraint, SV *sv);
	128	} TC_CHECK;
	129
	130	typedef union {
de2f2e97	131	char *builder;
	132	SV *value;
	133	CV *sub;
	134	OP *op;
	135	U32 type;
	136	} DEFAULT;
	137
	138	typedef enum {
	139	default_none = 0,
	140	default_type,
	141	default_builder,
	142	default_value,
	143	default_sub,
	144	default_op,
	145	} default_kind;
	146
1ea12c91	147	typedef struct {
de2f2e97	148	/* the meta instance struct */
	149	struct mi *mi;
	150
	151	U32 flags; /* slot type, TC behavior, coerce, weaken, (no default \| default, builder + lazy), auto_deref */
	152
	153	/* slot access fields */
	154	SV slot_sv; / value of the slot (slot name presumably) */
	155	U32 slot_u32; /* for optimized access (precomputed hash or otherr) */
	156
	157	DEFAULT def; /* cv, value or other, depending on flags */
	158
	159	TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
	160	SV type_constraint; / meta attr */
	161
	162	CV *initializer;
	163	CV *trigger;
	164
f253044f	165	SV meta_attr; / the meta attr object */
de2f2e97	166	AV cvs; / CVs which use this attr */
	167	} ATTR;
	168
	169	/* slot flags:
	170	* instance reading writing
	171	* 00000000 00000000 00000000 00000000
	172	* ^ trigger
	173	* ^ weak
	174	* ^^^ tc_kind
	175	* ^ coerce
	176	* ^^^ default_kind
	177	* ^ lazy
	178	* ^ required
	179	* ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD
	180	*/
	181
	182	#define ATTR_INSTANCE_MASK 0xff000000
	183	#define ATTR_READING_MASK 0x0000ff00
	184	#define ATTR_WRITING_MASK 0x000000ff
	185
	186	#define ATTR_MASK_TYPE 0x7
	187
	188	#define ATTR_MASK_DEFAULT 0x700
	189	#define ATTR_SHIFT_DEAFULT 8
	190
	191	#define ATTR_LAZY 0x800
	192
	193	#define ATTR_COERCE 0x08
	194	#define ATTR_WEAK 0x10
	195	#define ATTR_TRIGGER 0x10
	196
	197	#define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK )
	198	#define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY )
	199	#define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE )
1ea12c91	200
de2f2e97	201	#define ATTR_TYPE(f) ( attr->flags & 0x7 )
de2f2e97	202	#define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
1ea12c91	203
de2f2e97	204	#define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr)
	205	#define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 )
	206	#define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 )
1ea12c91	207
f253044f	208	#define dATTR ATTR attr = (XSANY.any_i32 ? INT2PTR(ATTR , (XSANY.any_i32)) : define_attr(aTHX_ cv))
de2f2e97	209
	210
	211	/* FIXME define a vtable that does call_sv */
	212	typedef struct {
	213	SV * (get)(pTHX_ SV self, ATTR *attr);
	214	void (set)(pTHX_ SV self, ATTR attr, SV value);
	215	bool * (has)(pTHX_ SV self, ATTR *attr);
	216	SV * (delete)(pTHX_ SV self, ATTR *attr);
	217	} instance_vtbl;
	218
	219
	220	typedef enum {
	221	hash = 0,
	222
	223	/* these are not yet implemented */
	224	array,
	225	fptr,
	226	cv,
	227	judy,
	228	} instance_types;
	229
	230	typedef struct mi {
de2f2e97	231	HV *stash;
	232
	233	/* slot access method */
	234	instance_types type;
	235	instance_vtbl *vtbl;
	236
	237	/* attr descriptors */
	238	I32 num_attrs;
	239	ATTR *attrs;
	240	} MI;
	241
	242
4c6fbfb1	243
	244
	245	STATIC bool check_is_scalar_ref(SV *sv) {
	246	if( SvROK(sv) ) {
	247	switch (SvTYPE(SvRV(sv))) {
	248	case SVt_IV:
	249	case SVt_NV:
	250	case SVt_PV:
	251	case SVt_NULL:
	252	return 1;
	253	break;
	254	default:
	255	return 0;
	256	}
	257	}
	258	return 0;
	259	}
	260
	261	STATIC bool check_reftype(TC type, SV *sv) {
	262	int svt;
	263
	264	if ( !SvROK(sv) )
	265	return 0;
	266
	267	switch (type) {
	268	case GlobRef:
	269	svt = SVt_PVGV;
	270	break;
	271	case ArrayRef:
	272	svt = SVt_PVAV;
	273	break;
	274	case HashRef:
	275	svt = SVt_PVHV;
	276	break;
	277	case CodeRef:
	278	svt = SVt_PVCV;
	279	break;
	280	}
	281
160f9ca7	282	return SvTYPE(SvRV(sv)) == svt;
4c6fbfb1	283	}
	284
	285	STATIC bool check_sv_class (pTHX_ HV stash, SV sv) {
	286	dSP;
	287	bool ret;
	288
	289	if (!sv)
	290	return 0;
	291	SvGETMAGIC(sv);
	292	if (!SvROK(sv))
	293	return 0;
	294	sv = (SV*)SvRV(sv);
	295	if (!SvOBJECT(sv))
	296	return 0;
	297	if (SvSTASH(sv) == stash)
	298	return 1;
	299
	300	ENTER;
	301	SAVETMPS;
	302	PUSHMARK(SP);
	303	XPUSHs(sv);
	304	XPUSHs(newSVpv(HvNAME_get(SvSTASH(sv)), 0));
	305	PUTBACK;
	306
	307	call_method("isa", G_SCALAR);
	308
	309	SPAGAIN;
	310	ret = SvTRUE(TOPs);
	311
	312	FREETMPS;
	313	LEAVE;
	314
	315	return ret;
	316	}
	317
	318	STATIC bool check_sv_type (TC type, SV *sv) {
	319	if (!sv)
	320	return 0;
160f9ca7	321
4c6fbfb1	322	switch (type) {
	323	case Any:
	324	return 1;
	325	break;
	326	case Undef:
	327	return !SvOK(sv);
	328	break;
	329	case Defined:
	330	return SvOK(sv);
	331	break;
	332	case Str:
	333	return (SvOK(sv) && !SvROK(sv));
160f9ca7	334	case Num:
	335	#if (PERL_VERSION < 8) \|\| (PERL_VERSION == 8 && PERL_SUBVERSION <5)
	336	if (!SvPOK(sv) && !SvPOKp(sv))
	337	return SvFLAGS(sv) & (SVf_NOK\|SVp_NOK\|SVf_IOK\|SVp_IOK);
	338	else
	339	#endif
	340	return looks_like_number(sv);
	341	break;
	342	case Int:
	343	if ( SvIOK(sv) ) {
	344	return 1;
	345	} else if ( SvPOK(sv) ) {
	346	croak("todo");
	347	int i;
	348	STRLEN len;
	349	char *pv = SvPV(sv, len);
	350	char *end = pv + len;
	351
	352	errno = 0;
	353	i = strtol(pv, &end, 0);
	354	return !errno;
	355	}
	356	return 0;
	357	break;
4c6fbfb1	358	case Ref:
	359	return SvROK(sv);
	360	break;
	361	case ScalarRef:
	362	return check_is_scalar_ref(sv);
	363	break;
	364	case ArrayRef:
	365	case HashRef:
	366	case CodeRef:
	367	case GlobRef:
	368	return check_reftype(type, sv);
	369	break;
	370	case Object:
	371	return sv_isobject(sv);
	372	break;
160f9ca7	373	case ClassName:
	374	{
	375	STRLEN len;
	376	char *pv;
	377	pv = SvPV(sv, len);
	378	return ( gv_stashpvn(pv, len, 0) != NULL );
	379	break;
	380	}
4c6fbfb1	381	case RegexpRef:
	382	return sv_isa(sv, "Regexp");
	383	break;
	384	case FileHandle:
	385	croak("todo");
	386	break;
	387	default:
	388	croak("todo");
	389	}
	390
	391	return 0;
	392	}
	393
160f9ca7	394	STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV type_constraint, SV sv) {
4c6fbfb1	395	switch (kind) {
	396	case tc_none:
	397	return 1;
	398	break;
	399	case tc_type:
	400	return check_sv_type(tc_check.type, sv);
	401	break;
	402	case tc_stash:
a812574b	403	return check_sv_class(aTHX_ tc_check.stash, sv);
4c6fbfb1	404	break;
4c6fbfb1	405	case tc_fptr:
	406	return tc_check.fptr(aTHX_ type_constraint, sv);
	407	break;
	408	case tc_cv:
	409	case tc_op:
	410	croak("todo");
	411	break;
	412	}
	413
	414	croak("todo");
	415	return 0;
	416	}
	417
	418
160f9ca7	419	STATIC void init_attr (MI mi, ATTR attr, AV *desc) {
160f9ca7	420	U32 flags = 0;
1ea12c91	421	U32 hash;
1ea12c91	422	STRLEN len;
de2f2e97	423	char *pv;
160f9ca7	424	I32 ix = av_len(desc);
	425	SV **params = AvARRAY(desc);
	426	SV *tc;
	427	SV *key;
de2f2e97	428
	429	attr->mi = mi;
	430
de2f2e97	431
160f9ca7	432	if ( ix != 12 )
160f9ca7	433	croak("wrong number of args (%d != 13)", ix + 1);
de2f2e97	434
160f9ca7	435	for ( ; ix >= 0; ix-- ) {
	436	if ( !params[ix] \|\| params[ix] == &PL_sv_undef )
	437	croak("bad params");
	438	}
	439
	440	if ( !SvROK(params[1]) \|\| SvTYPE(SvRV(params[1])) != SVt_PVAV )
	441	croak("slots is not an array");
de2f2e97	442
160f9ca7	443	if ( av_len((AV *)SvRV(params[1])) != 0 )
160f9ca7	444	croak("Only unary slots are supported at the moment");
1ea12c91	445
160f9ca7	446	/* calculate a hash from the slot */
	447	/* FIXME arrays etc should also be supported */
	448	key = av_fetch((AV )SvRV(params[1]), 0, 0);
	449	pv = SvPV(key, len);
1ea12c91	450	PERL_HASH(hash, pv, len);
1ea12c91	451
de2f2e97	452
160f9ca7	453	/* FIXME better organize these */
	454	if ( SvTRUE(params[2]) )
	455	flags \|= ATTR_WEAK;
	456
	457	if ( SvTRUE(params[3]) )
	458	flags \|= ATTR_COERCE;
de2f2e97	459
160f9ca7	460	if ( SvTRUE(params[4]) )
160f9ca7	461	flags \|= ATTR_LAZY;
de2f2e97	462
160f9ca7	463	tc = params[5];
de2f2e97	464
160f9ca7	465	if ( SvOK(tc) ) {
	466	int tc_kind = SvIV(params[6]);
	467	SV *data = params[7];
	468
	469	switch (tc_kind) {
	470	case tc_stash:
	471	attr->tc_check.stash = gv_stashsv(data, 0);
	472	break;
	473	case tc_type:
	474	attr->tc_check.type = SvIV(data);
	475	break;
	476	case tc_cv:
	477	attr->tc_check.cv = (CV *)SvRV(data);
	478	if ( SvTYPE(attr->tc_check.cv) != SVt_PVCV )
	479	croak("compiled type constraint is not a coderef");
	480	break;
	481	default:
	482	croak("todo");
	483	}
	484
	485	flags \|= tc_kind;
	486	}
	487
	488	attr->flags = flags; /* FIXME default_kind */
	489
	490	attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL;
	491	if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV )
	492	croak("trigger is not a coderef");
	493
	494	attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL;
	495	if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV )
	496	croak("initializer is not a coderef");
	497
	498	/* copy refs */
	499	attr->meta_attr = newSVsv(params[0]);
	500	attr->type_constraint = newSVsv(tc);
	501	if ( attr->trigger ) SvREFCNT_inc(attr->trigger);
	502	if ( attr->initializer ) SvREFCNT_inc(attr->initializer);
	503
	504	attr->slot_sv = newSVpvn_share(pv, len, hash);
	505	attr->slot_u32 = hash;
	506
	507	attr->def.type = 0;
de2f2e97	508
	509	/* cross refs to CVs which use this struct */
	510	attr->cvs = newAV();
	511	}
	512
f253044f	513	STATIC MI new_mi (pTHX_ HV stash, AV *attrs) {
de2f2e97	514	MI *mi;
	515	I32 ix;
	516	const I32 num = av_len(attrs) + 1;
	517
	518	Newx(mi, 1, MI);
	519
	520	SvREFCNT_inc_simple(stash);
	521	mi->stash = stash;
	522
de2f2e97	523	mi->type = 0; /* nothing else implemented yet */
	524
	525	/* initialize attributes */
	526	mi->num_attrs = num;
	527	Newx(mi->attrs, num, ATTR);
f253044f	528	for ( ix = 0; ix < num; ix++ ) {
de2f2e97	529	SV **desc = av_fetch(attrs, ix, 0);
de2f2e97	530
160f9ca7	531	if ( !desc \|\| !desc \|\| !SvROK(desc) \|\| !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
de2f2e97	532	croak("Attribute descriptor has to be a hash reference");
f253044f	533	}
de2f2e97	534
160f9ca7	535	init_attr(mi, &mi->attrs[ix], (AV )SvRV(desc));
de2f2e97	536	}
	537
	538	return mi;
	539	}
	540
f253044f	541	STATIC SV new_mi_obj (pTHX_ MI mi) {
035fd0c4	542	HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
	543	SV *obj = newRV_noinc(newSViv(PTR2IV(mi)));
	544	sv_bless( obj, stash );
	545	return obj;
f253044f	546	}
de2f2e97	547
f253044f	548	STATIC SV attr_to_meta_instance(pTHX_ SV meta_attr) {
	549	dSP;
	550	I32 count;
	551	SV *mi;
	552
	553	if ( !meta_attr )
	554	croak("No attr found in magic!");
	555
	556	ENTER;
	557	SAVETMPS;
	558	PUSHMARK(SP);
	559	XPUSHs(meta_attr);
	560	PUTBACK;
	561	count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
	562
	563	if ( count != 1 )
	564	croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
	565
	566	SPAGAIN;
	567	mi = POPs;
	568
	569	SvREFCNT_inc(mi);
	570
	571	PUTBACK;
	572	FREETMPS;
	573	LEAVE;
	574
	575	return mi;
	576	}
	577
	578	STATIC SV perl_mi_to_c_mi(pTHX_ SV perl_mi) {
	579	dSP;
	580	I32 count;
	581	MI *mi = NULL;
	582	SV *class;
	583	SV *attrs;
	584	HV *stash;
	585
	586	ENTER;
	587	SAVETMPS;
	588	PUSHMARK(SP);
	589	XPUSHs(perl_mi);
	590	PUTBACK;
	591	count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
	592
	593	if ( count != 2 )
	594	croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
	595
	596	SPAGAIN;
	597	attrs = POPs;
	598	class = POPs;
	599
	600	PUTBACK;
	601
	602	stash = gv_stashsv(class, 0);
	603
	604	mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
	605
	606	FREETMPS;
	607	LEAVE;
	608
	609	return new_mi_obj(aTHX_ mi);
	610	}
	611
612	STATIC ATTR mi_find_attr(MI mi, SV *meta_attr) {
613	I32 ix;
614
035fd0c4	615	for ( ix = 0; ix < mi->num_attrs; ix++ ) {
f253044f	616	if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
f253044f	617	return &mi->attrs[ix];
de2f2e97	618	}
de2f2e97	619	}
de2f2e97	620
f253044f	621	sv_dump(meta_attr);
f253044f	622	croak("Attr not found");
de2f2e97	623	return NULL;
	624	}
	625
	626	STATIC ATTR get_attr(pTHX_ CV cv) {
f253044f	627	SV meta_attr = get_stashed_in_mg(aTHX_ (SV )cv);
	628	SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
	629	SV *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
	630	MI *mi;
de2f2e97	631
f253044f	632	if (!c_mi) {
	633	c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
	634	stash_in_mg(aTHX_ perl_mi, c_mi);
	635	}
	636
	637	sv_2mortal(perl_mi);
	638
	639	mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
	640
	641	return mi_find_attr(mi, meta_attr);
1ea12c91	642	}
1ea12c91	643
de2f2e97	644	STATIC ATTR define_attr (pTHX_ CV cv) {
	645	ATTR *attr = get_attr(aTHX_ cv);
	646	assert(attr);
	647
	648	XSANY.any_i32 = PTR2IV(attr);
f253044f	649
f253044f	650	av_push( attr->cvs, (SV *)cv );
de2f2e97	651
	652	return attr;
	653	}
	654
	655	STATIC void weaken(pTHX_ SV *sv) {
1ea12c91	656	#ifdef SvWEAKREF
de2f2e97	657	sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
1ea12c91	658	#else
	659	croak("weak references are not implemented in this release of perl");
	660	#endif
	661	}
	662
	663
	664	/* meta instance protocol */
	665
de2f2e97	666	STATIC SV get_slot_value(pTHX_ SV self, ATTR *attr) {
1ea12c91	667	HE *he;
	668
	669	assert(self);
	670	assert(SvROK(self));
	671	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	672
de2f2e97	673	assert( ATTR_DUMB_INSTANCE(attr) );
	674
	675	if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
1ea12c91	676	return HeVAL(he);
	677	else
	678	return NULL;
	679	}
	680
de2f2e97	681	STATIC void set_slot_value(pTHX_ SV self, ATTR attr, SV *value) {
1ea12c91	682	HE *he;
4c6fbfb1	683	SV *copy;
1ea12c91	684
	685	assert(self);
	686	assert(SvROK(self));
	687	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	688
de2f2e97	689	assert( ATTR_DUMB_INSTANCE(attr) );
de2f2e97	690
4c6fbfb1	691	copy = newSVsv(value);
	692
	693	he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
1ea12c91	694
1ea12c91	695	if (he != NULL) {
de2f2e97	696	if ( ATTR_ISWEAK(attr) )
4c6fbfb1	697	weaken(aTHX_ HeVAL(he));
1ea12c91	698	} else {
4c6fbfb1	699	SvREFCNT_dec(copy);
1ea12c91	700	croak("Hash store failed.");
	701	}
	702	}
	703
de2f2e97	704	STATIC bool has_slot_value(pTHX_ SV self, ATTR attr) {
1ea12c91	705	assert(self);
	706	assert(SvROK(self));
	707	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	708
de2f2e97	709	assert( ATTR_DUMB_INSTANCE(attr) );
	710
	711	return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
	712	}
	713
	714	STATIC SV deinitialize_slot(pTHX_ SV self, ATTR *attr) {
	715	assert(self);
	716	assert(SvROK(self));
	717	assert(SvTYPE(SvRV(self)) == SVt_PVHV);
	718
	719	assert( ATTR_DUMB_INSTANCE(attr) );
	720
	721	return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
1ea12c91	722	}
1ea12c91	723
160f9ca7	724	STATIC SV getter_common(pTHX_ SV self, ATTR *attr) {
	725	assert( ATTR_DUMB_READER(attr) );
	726	return get_slot_value(aTHX_ self, attr);
	727	}
	728
	729	STATIC void setter_common(pTHX_ SV self, ATTR attr, SV *value) {
	730	if ( attr->flags & ATTR_MASK_TYPE ) {
	731	if ( !check_type_constraint(aTHX_ attr->flags & ATTR_MASK_TYPE, attr->tc_check, attr->type_constraint, value) )
	732	croak("Bad param");
	733	}
	734
	735	set_slot_value(aTHX_ self, attr, value);
	736	}
1ea12c91	737
	738	/* simple high level api */
	739
de2f2e97	740	STATIC XS(getter);
de2f2e97	741	STATIC XS(getter)
1ea12c91	742	{
	743	#ifdef dVAR
	744	dVAR;
	745	#endif
	746	dXSARGS;
de2f2e97	747	dATTR;
1ea12c91	748	SV *value;
	749
	750	if (items != 1)
	751	Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
	752
	753	SP -= items;
	754
160f9ca7	755	value = getter_common(aTHX_ ST(0), attr);
1ea12c91	756
	757	if (value) {
	758	ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
	759	XSRETURN(1);
	760	} else {
	761	XSRETURN_UNDEF;
	762	}
	763	}
	764
de2f2e97	765	STATIC XS(setter);
de2f2e97	766	STATIC XS(setter)
1ea12c91	767	{
	768	#ifdef dVAR
	769	dVAR;
	770	#endif
	771	dXSARGS;
de2f2e97	772	dATTR;
1ea12c91	773
	774	if (items != 2)
	775	Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
	776
	777	SP -= items;
	778
160f9ca7	779	setter_common(aTHX_ ST(0), attr, ST(1));
1ea12c91	780
	781	ST(0) = ST(1); /* return value */
	782	XSRETURN(1);
	783	}
	784
de2f2e97	785	STATIC XS(accessor);
de2f2e97	786	STATIC XS(accessor)
1ea12c91	787	{
	788	#ifdef dVAR
	789	dVAR;
	790	#endif
	791	dXSARGS;
de2f2e97	792	dATTR;
1ea12c91	793
	794	if (items < 1)
	795	Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
	796
	797	SP -= items;
	798
	799	if (items > 1) {
160f9ca7	800	setter_common(aTHX_ ST(0), attr, ST(1));
1ea12c91	801	ST(0) = ST(1); /* return value */
1ea12c91	802	} else {
160f9ca7	803	SV *value = getter_common(aTHX_ ST(0), attr);
1ea12c91	804	if ( value ) {
	805	ST(0) = value;
	806	} else {
	807	XSRETURN_UNDEF;
	808	}
	809	}
	810
	811	XSRETURN(1);
	812	}
	813
	814	STATIC XS(predicate);
	815	STATIC XS(predicate)
	816	{
	817	#ifdef dVAR
	818	dVAR;
	819	#endif
	820	dXSARGS;
de2f2e97	821	dATTR;
1ea12c91	822
	823	if (items != 1)
	824	Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
	825
	826	SP -= items;
	827
de2f2e97	828	if ( has_slot_value(aTHX_ ST(0), attr) )
1ea12c91	829	XSRETURN_YES;
	830	else
	831	XSRETURN_NO;
	832	}
	833
	834	enum xs_body {
de2f2e97	835	xs_body_getter = 0,
	836	xs_body_setter,
	837	xs_body_accessor,
1ea12c91	838	xs_body_predicate,
	839	max_xs_body
	840	};
	841
	842	STATIC XSPROTO ((*xs_bodies[])) = {
de2f2e97	843	getter,
	844	setter,
	845	accessor,
1ea12c91	846	predicate,
	847	};
	848
	849	MODULE = Moose PACKAGE = Moose::XS
	850
	851	CV *
de2f2e97	852	new_sub(attr, name)
1ea12c91	853	INPUT:
de2f2e97	854	SV *attr;
de2f2e97	855	SV *name;
1ea12c91	856	ALIAS:
de2f2e97	857	new_getter = xs_body_getter
	858	new_setter = xs_body_setter
	859	new_accessor = xs_body_accessor
	860	new_predicate = xs_body_predicate
1ea12c91	861	PREINIT:
	862	CV * cv;
	863	CODE:
	864	if ( ix >= max_xs_body )
	865	croak("Unknown Moose::XS body type");
	866
de2f2e97	867	if ( !sv_isobject(attr) )
	868	croak("'attr' must be a Moose::Meta::Attribute");
	869
	870	cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
1ea12c91	871
	872	if (cv == NULL)
	873	croak("Oi vey!");
	874
de2f2e97	875	/* associate CV with meta attr */
f253044f	876	stash_in_mg(aTHX_ (SV *)cv, attr);
de2f2e97	877
	878	/* this will be set on first call */
	879	XSANY.any_i32 = 0;
1ea12c91	880
	881	RETVAL = cv;
	882	OUTPUT:
	883	RETVAL
	884
	885
f253044f	886	MODULE = Moose PACKAGE = Moose::XS::Meta::Instance
	887
	888	void
	889	DESTROY(self)
	890	INPUT:
	891	SV *self;
	892	PREINIT:
	893	MI mi = INT2PTR(MI , SvIV(SvRV(self)));
	894	CODE:
	895	/* foreach attr ( delete cvs XSANY ), free attrs free mi */