#include "perl.h"
#include "XSUB.h"
+#define NEED_grok_number
+#define NEED_grok_numeric_radix
#define NEED_newRV_noinc
#define NEED_newSVpvn_share
#define NEED_sv_2pv_flags
#endif
#ifndef gv_stashpvs
-#define gv_stashpvs(x, y) gv_stashpvn(STR_WITH_LEN(x), y)
+#define gv_stashpvs(x, y) Perl_gv_stashpvn(aTHX_ STR_WITH_LEN(x), y)
#endif
/* FIXME
}
STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
- MAGIC *mg, *moremagic;
+ MAGIC *mg;
if (SvTYPE(sv) >= SVt_PVMG) {
for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
tc_stash, /* a stash for a class, implements TypeConstraint::Class by comparing SvSTASH and then invoking C<isa> if necessary */
tc_cv, /* applies a code reference to the value and checks for truth */
tc_fptr, /* apply a C function pointer */
- tc_enum, /* TODO check that the value is in an allowed set of values (strings) */
+ tc_enum /* TODO check that the value is in an allowed set of values (strings) */
} tc_kind;
/* this is a enum of builtin type check. They are handled in a switch statement
RegexpRef,
Object,
Role, /* TODO */
- ClassName,
+ ClassName
} TC;
/* auxillary pointer/int union used for constraint checking */
default_none = 0, /* no default value */
default_normal, /* code reference or scalar */
default_builder, /* builder method */
- default_type, /* TODO enumerated type optimization (will call newHV, newAV etc to avoid calling a code ref for these simple cases) */
+ default_type /* TODO enumerated type optimization (will call newHV, newAV etc to avoid calling a code ref for these simple cases) */
} default_kind;
typedef union {
SV *slot_sv; /* value of the slot (currently always slot name) */
U32 slot_u32; /* for optimized access (precomputed hash, possibly something else) */
+ SV *init_arg_sv;
+ U32 init_arg_u32;
+
DEFAULT def; /* cv, value or other, depending on flags */
TC_CHECK tc_check; /* see TC_CHECK*/
SV *type_constraint; /* Moose::Meta::TypeConstraint object */
- CV *initializer; /* TODO */
- CV *trigger; /* TODO */
+ CV *trigger;
+ CV *initializer;
+ CV *writer; /* used by the initializer */
SV *meta_attr; /* the Moose::Meta::Attribute */
AV *cvs; /* an array of CVs which use this attr, see delete_mi */
array,
fptr,
cv,
- judy,
+ judy
} instance_types;
case CodeRef:
svt = SVt_PVCV;
break;
+ default:
+ croak("not a reftype %d\n", type);
}
return SvTYPE(SvRV(sv)) == svt;
if (!sv)
return 0;
+ SvGETMAGIC(sv);
+
switch (type) {
case Any:
return 1;
if ( SvIOK(sv) ) {
return 1;
} else if ( SvPOK(sv) ) {
- /* FIXME i really don't like this */
- int i;
STRLEN len;
char *pv = SvPV(sv, len);
- char *end = pv + len;
- char *tail = end;
-
- errno = 0;
- i = strtol(pv, &tail, 0);
-
- if ( errno ) return 0;
-
- while ( tail != end ) {
- if ( !isspace(*tail++) ) return 0;
- }
-
- return 1;
+ int flags = grok_number(pv, len, NULL);
+ return ( flags && !(flags & IS_NUMBER_NOT_INT) );
}
return 0;
break;
case GlobRef:
return check_reftype(type, sv);
break;
+ case RegexpRef:
case Object:
- return sv_isobject(sv);
+ /* not using sv_isobject to avoid repeated get magic */
+ if ( SvROK(sv) ) {
+ SV *rv = SvRV(sv);
+ if ( SvOBJECT(rv) ) {
+ char *name = HvNAME_get(SvSTASH(SvRV(sv)));
+ if ( name ) {
+ bool is_regexp = strEQ("Regexp", name);
+ return ( (type == RegexpRef) ^ !is_regexp );
+ }
+ }
+ }
+ return 0;
break;
case ClassName:
if ( SvOK(sv) && !SvROK(sv) ) {
}
return 0;
break;
- case RegexpRef:
- return sv_isa(sv, "Regexp");
- break;
case FileHandle:
croak("todo");
break;
/* invoke a CV on an SV and return SvTRUE of the result */
STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) {
+ SV *ret_sv;
bool ret;
dSP;
call_sv(cv, G_SCALAR);
SPAGAIN;
- ret = SvTRUE(POPs);
+ ret_sv = POPs;
+ ret = SvTRUE(ret_sv);
PUTBACK;
FREETMPS;
case tc_cv:
return check_sv_cv(aTHX_ tc_check.sv, sv);
break;
+ case tc_enum:
+ croak("todo\n");
+ break;
}
croak("todo");
STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
U32 flags = 0;
- U32 hash;
- STRLEN len;
- char *pv;
+ U32 slot_hash, init_arg_hash;
+ STRLEN slot_len, init_arg_len;
+ char *slot_pv, *init_arg_pv;
I32 ix = av_len(desc);
SV **params = AvARRAY(desc);
SV *tc;
- SV *key;
+ SV *slot_sv;
+ SV *init_arg_sv;
attr->mi = mi;
-
- if ( ix != 12 )
- croak("wrong number of args (%d != 13)", ix + 1);
+ if ( ix != 13 )
+ croak("wrong number of args (%d != 14)", (int)ix + 1);
for ( ; ix >= 0; ix-- ) {
if ( !params[ix] || params[ix] == &PL_sv_undef )
/* 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);
+ slot_sv = *av_fetch((AV *)SvRV(params[1]), 0, 0);
+ slot_pv = SvPV(slot_sv, slot_len);
+ PERL_HASH(slot_hash, slot_pv, slot_len);
+ init_arg_sv = params[13];
+ init_arg_pv = SvPV(init_arg_sv, init_arg_len);
+ PERL_HASH(init_arg_hash, init_arg_pv, init_arg_len);
/* FIXME better organize these, positionals suck */
if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV )
croak("initializer is not a coderef");
-
-
/* now that we're done preparing/checking args and shit, so we finalize the
* attr, increasing refcounts for any referenced data, and creating the CV
* array */
attr->type_constraint = newSVsv(tc);
/* increase the refcount for auxillary structures */
- SvREFCNT_inc(attr->trigger);
- SvREFCNT_inc(attr->initializer);
- if ( flags & ATTR_TCREFCNT ) SvREFCNT_inc(attr->tc_check.sv);
- if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc(attr->def.sv);
+ SvREFCNT_inc_simple_void(attr->trigger);
+ SvREFCNT_inc_simple_void(attr->initializer);
+ if ( flags & ATTR_TCREFCNT ) SvREFCNT_inc_simple_void_NN(attr->tc_check.sv);
+ if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc_simple_void_NN(attr->def.sv);
+
+ attr->slot_sv = newSVpvn_share(slot_pv, slot_len, slot_hash);
+ attr->slot_u32 = slot_hash;
- /* create a new SV for the hash key */
- attr->slot_sv = newSVpvn_share(pv, len, hash);
- attr->slot_u32 = hash;
+ attr->init_arg_sv = newSVpvn_share(init_arg_pv, init_arg_len, init_arg_hash);
+ attr->init_arg_u32 = init_arg_hash;
/* cross refs to CVs which use this struct */
attr->cvs = newAV();
MI *mi;
const I32 num_attrs = av_len(attrs) + 1;
- Newx(mi, 1, MI);
-
- mi->attrs = NULL;
- mi->stash = NULL;
- mi->num_attrs = 0;
+ Newxz(mi, 1, MI);
/* set the pointer now, if we have any initialization errors it'll get
* cleaned up because obj is mortal */
sv_setiv(sv_ptr, PTR2IV(mi));
- Newx(mi->attrs, num_attrs, ATTR);
+ Newxz(mi->attrs, num_attrs, ATTR);
- SvREFCNT_inc_simple(stash);
+ SvREFCNT_inc_simple_void_NN(stash);
mi->stash = stash;
mi->type = 0; /* nothing else implemented yet */
/* initialize attributes */
- for ( ; mi->num_attrs < num_attrs; mi->num_attrs++ ) {
+ for ( mi->num_attrs = 0; mi->num_attrs < num_attrs; mi->num_attrs++ ) {
SV **desc = av_fetch(attrs, mi->num_attrs, 0);
if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
SvREFCNT_dec(attr->type_constraint);
if ( attr->flags & ATTR_TCREFCNT ) SvREFCNT_dec(attr->tc_check.sv);
if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv);
- SvREFCNT_dec(attr->initializer);
SvREFCNT_dec(attr->trigger);
+ SvREFCNT_dec(attr->initializer);
+ SvREFCNT_dec(attr->writer);
SvREFCNT_dec(attr->meta_attr);
}
* $attr->associated_class->get_meta_instance */
STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
dSP;
- I32 count;
SV *mi;
if ( !meta_attr )
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);
+ call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
SPAGAIN;
mi = POPs;
- SvREFCNT_inc(mi);
+ SvREFCNT_inc_simple_void(mi);
PUTBACK;
FREETMPS;
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);
+ croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", (int)count);
SPAGAIN;
attrs = POPs;
stash = gv_stashsv(class, 0);
mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
- SvREFCNT_inc(mi);
+ SvREFCNT_inc_simple_void_NN(mi);
FREETMPS;
LEAVE;
}
}
- croak("Attr %x not found in meta instance of %s", SvRV(meta_attr) /* SvPV_force_nomg(sv_2mortal(newSVsv(meta_attr))) */, HvNAME_get(mi->stash) );
+ croak("Attr %x not found in meta instance of %s", (unsigned int)PTR2UV(SvRV(meta_attr)) /* SvPV_force_nomg(sv_2mortal(newSVsv(meta_attr))) */, HvNAME_get(mi->stash) );
return NULL;
}
XSANY.any_i32 = PTR2IV(attr);
- SvREFCNT_inc(cv);
+ SvREFCNT_inc_simple_void(cv);
av_push( attr->cvs, (SV *)cv );
return attr;
-/* meta instance protocol */
+/* meta instance protocol
+ *
+ * The slot functions don't change the refcount or copy (aliasing semantics)
+ *
+ * create_instance returns a new mortal */
-STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
+STATIC SV *get_slot_lvalue(pTHX_ SV *self, ATTR *attr) {
HE *he;
assert(self);
return NULL;
}
-STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
+STATIC bool set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
HE *he;
- SV *copy;
assert(self);
assert(SvROK(self));
assert( ATTR_DUMB_INSTANCE(attr) );
- 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));
- } else {
- SvREFCNT_dec(copy);
- croak("Hash store failed.");
- }
+ return he != NULL;
}
STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
}
-
+STATIC SV *create_instance(pTHX_ MI *mi) {
+ return sv_bless(sv_2mortal(newRV_noinc((SV *)newHV())), mi->stash);
+}
/* Shared functionality for readers/writers/accessors, this roughly corresponds
* to the methods of Moose::Meta::Attribute on the instance
- * (get_value/set_value, default value handling, etc) */
+ * (get_value/set_value, default value handling, etc)
+ *
+ * These functions return mortal copiess and save copies (handling refcounting). */
+
+STATIC void attr_set_common(pTHX_ SV *self, ATTR *attr, SV *value) {
+ SV *copy;
-STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value);
+ if ( !value ) {
+ /* FIXME croak if required ? */
+ return;
+ }
+
+ if ( ATTR_TYPE(attr) ) {
+ if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) )
+ croak("Bad param");
+ }
+
+ copy = newSVsv(value);
+
+ if ( ATTR_ISWEAK(attr) && SvROK(copy) )
+ weaken(aTHX_ copy);
+
+ if ( !set_slot_value(aTHX_ self, attr, copy) ) {
+ SvREFCNT_dec(copy);
+ croak("Hash store failed.");
+ }
+}
+
+STATIC void attr_set_initial_value(pTHX_ SV *self, ATTR *attr, SV *value) {
+ if ( attr->initializer ) {
+ croak("todo");
+ } else {
+ attr_set_common(aTHX_ self, attr, value);
+ }
+}
STATIC SV *call_builder (pTHX_ SV *self, ATTR *attr) {
SV *sv;
* $obj->$coderef etc, for that we need to use 'default' */
PUTBACK;
call_method(SvPV_nolen(attr->def.sv), G_SCALAR);
- SPAGAIN;
/* the value is a mortal with a refcount of 1, so we need to keep it around */
+ SPAGAIN;
sv = POPs;
- SvREFCNT_inc(sv);
+ SvREFCNT_inc_simple_void(sv);
PUTBACK;
FREETMPS;
}
-/* Returns an SV for the default value. Should be copied by the caller because
- * it's either an alias for a simple value, or a mortal from cv/builder */
STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) {
switch ( ATTR_DEFAULT(attr) ) {
case default_none:
croak("todo");
} else {
printf("simple value\n");
- return attr->def.sv; /* will be copied by set for lazy, and by reader for both cases */
+ return sv_mortalcopy(attr->def.sv); /* will be copied by set for lazy, and by reader for both cases */
}
break;
case default_type:
* returns an alias to the sv that is copied in the reader/writer/accessor code
* */
STATIC SV *attr_get_value(pTHX_ SV *self, ATTR *attr) {
- SV *value = get_slot_value(aTHX_ self, attr);
+ SV *value = get_slot_lvalue(aTHX_ self, attr);
if ( value ) {
- return value;
+ return sv_mortalcopy(value);
} else if ( ATTR_ISLAZY(attr) ) {
value = get_default(aTHX_ self, attr);
- attr_set_value(aTHX_ self, attr, value);
+ attr_set_initial_value(aTHX_ self, attr, value);
return value;
}
/* $attr->set_value($self) */
STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value) {
- if ( ATTR_TYPE(attr) ) {
- if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) )
- croak("Bad param");
- }
+ attr_set_common(aTHX_ self, attr, value);
+
+ if ( attr->trigger ) {
+ dSP;
- set_slot_value(aTHX_ self, attr, value);
+ ENTER;
+ SAVETMPS;
+ PUSHMARK(SP);
+
+ /* FIXME copy self & meta attr? */
+ XPUSHs(self);
+ XPUSHs(sv_2mortal(newSVsv(value)));
+ XPUSHs(attr->meta_attr);
+
+ /* we invoke the builder as a stringified method. This will not work for
+ * $obj->$coderef etc, for that we need to use 'default' */
+ PUTBACK;
+ call_method(SvPV_nolen(attr->def.sv), G_VOID);
+
+ FREETMPS;
+ LEAVE;
+ }
}
+/* generate a new attribute method */
+STATIC CV *new_attr_method (pTHX_ SV *attr, XSPROTO(body), char *name) {
+ CV *cv = newXS(name, body, __FILE__);
+
+ if (cv == NULL)
+ croak("Oi vey!");
+
+ /* associate CV with meta attr */
+ stash_in_mg(aTHX_ (SV *)cv, attr);
+
+ /* this will be set on first call */
+ XSANY.any_i32 = 0;
+
+ return cv;
+}
+
+
+
+
/* This macro is used in the XS subs to set up the 'attr' variable.
*
* if XSANY is NULL then define_attr is called on the CV, to set the pointer
value = attr_get_value(aTHX_ ST(0), attr);
if (value) {
- ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
+ ST(0) = value;
XSRETURN(1);
} else {
XSRETURN_UNDEF;
XSRETURN_NO;
}
+
+
+
+
+
+
enum xs_body {
xs_body_reader = 0,
xs_body_writer,
};
MODULE = Moose PACKAGE = Moose::XS
+PROTOTYPES: ENABLE
CV *
-new_sub(attr, name)
+new_attr_method(attr, name)
INPUT:
SV *attr;
SV *name;
+ PROTOTYPE: $;$
+ PREINIT:
+ char *pv = SvOK(name) ? SvPV_nolen(name) : NULL;
ALIAS:
new_reader = xs_body_reader
new_writer = xs_body_writer
new_accessor = xs_body_accessor
new_predicate = xs_body_predicate
- 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;
+ RETVAL = new_attr_method(aTHX_ attr, xs_bodies[ix], pv);
OUTPUT:
RETVAL
MODULE = Moose PACKAGE = Moose::XS::Meta::Instance
+PROTOTYPES: DISABLE
void
DESTROY(self)
if ( mi )
delete_mi(aTHX_ mi);
+
+MODULE = Moose PACKAGE = Moose::XS::TypeConstraints
+PROTOTYPES: ENABLE
+
+bool
+_check_type(sv)
+ INPUT:
+ SV* sv
+ ALIAS:
+ Any = Any
+ Item = Any
+ Bool = Any
+ Undef = Undef
+ Defined = Defined
+ Str = Str
+ Value = Str
+ Num = Num
+ Int = Int
+ GlobRef = GlobRef
+ ArrayRef = ArrayRef
+ HashRef = HashRef
+ CodeRef = CodeRef
+ Ref = Ref
+ ScalarRef = ScalarRef
+ FileHandle = FileHandle
+ RegexpRef = RegexpRef
+ Object = Object
+ Role = Role
+ ClassName = ClassName
+ CODE:
+ RETVAL = check_sv_type(ix, sv);
+ OUTPUT:
+ RETVAL
+
+bool
+ObjectOfType(sv, class)
+ INPUT:
+ SV* sv
+ SV* class
+ PREINIT:
+ HV *stash = gv_stashsv(class, 0);
+ CODE:
+ RETVAL = check_sv_class(aTHX_ stash, sv);
+ OUTPUT:
+ RETVAL
projects / gitmo/Moose.git / blobdiff