#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?)
- */
+#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
#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 = 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
+ 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,
+ /* complex checks */
+ Role,
+ ClassName,
+ Enum,
} 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_stash,
+ tc_classname,
+ tc_fptr,
} tc_kind;
typedef union {
+ TC type;
+ CV *cv;
+ OP *op;
+ HV *stash;
+ char *classname;
+ bool (*fptr)(pTHX_ SV *type_constraint, SV *sv);
+} TC_CHECK;
+
+typedef union {
char *builder;
SV *value;
CV *sub;
CV *initializer;
CV *trigger;
- SV *attr; /* the meta attr object */
+ SV *meta_attr; /* the meta attr object */
AV *cvs; /* CVs which use this attr */
} 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))))
+#define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv))
/* FIXME define a vtable that does call_sv */
} instance_types;
typedef struct mi {
- SV *associated_metaclass;
HV *stash;
/* slot access method */
} 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(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 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 RegexpRef:
+ return sv_isa(sv, "Regexp");
+ break;
+ case FileHandle:
+ croak("todo");
+ break;
+ default:
+ croak("todo");
+ }
+
+ return 0;
+}
+
+STATIC bool check_sv_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_class(aTHX_ tc_check.stash, sv);
+ break;
+ case tc_classname:
+ return ( gv_stashpv(tc_check.classname, 0) != NULL );
+ 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, HV *desc) {
U32 hash;
STRLEN len;
if ( !meta_attr ) croak("'meta' is required");
- attr->attr = *meta_attr;
+ attr->meta_attr = newSVsv(*meta_attr);
attr->mi = mi;
attr->cvs = newAV();
}
-STATIC MI *new_mi (pTHX_ HV *stash, SV *meta, AV *attrs) {
+STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) {
MI *mi;
I32 ix;
const I32 num = av_len(attrs) + 1;
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++ ) {
+ for ( ix = 0; ix < num; ix++ ) {
SV **desc = av_fetch(attrs, ix, 0);
- if ( !desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVHV) )
+ 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 *get_meta_attr_from_mg(pTHX_ CV *cv) {
- MAGIC *mg, *moremagic;
+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;
+}
- 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;
+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];
}
- if (mg)
- return mg->mg_obj;
}
- croak("No attr found in magic!");
+ sv_dump(meta_attr);
+ croak("Attr not found");
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
+ 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;
- return NULL;
+ 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) {
assert(attr);
XSANY.any_i32 = PTR2IV(attr);
- av_push( attr->cvs, cv );
+
+ av_push( attr->cvs, (SV *)cv );
return attr;
}
STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
HE *he;
+ SV *copy;
assert(self);
assert(SvROK(self));
assert( ATTR_DUMB_INSTANCE(attr) );
- SvREFCNT_inc(value);
+ copy = newSVsv(value);
+
+ he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
- 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 */
+ weaken(aTHX_ HeVAL(he));
} else {
+ SvREFCNT_dec(copy);
croak("Hash store failed.");
}
}
set_slot_value(aTHX_ ST(0), attr, ST(1));
ST(0) = ST(1); /* return value */
} else {
+ SV *value;
assert( ATTR_DUMB_WRITER(attr) );
- SV *value = get_slot_value(aTHX_ ST(0), attr);
+ value = get_slot_value(aTHX_ ST(0), attr);
if ( value ) {
ST(0) = value;
} else {
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") );
+ stash_in_mg(aTHX_ (SV *)cv, attr);
/* this will be set on first call */
XSANY.any_i32 = 0;
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 */
projects / gitmo/Moose.git / blobdiff