FileHandle,
RegexpRef,
Object,
+ ClassName,
/* complex checks */
Role,
- ClassName,
Enum,
} TC;
typedef enum {
tc_none = 0,
tc_type,
+ tc_stash,
tc_cv,
tc_op,
- tc_stash,
- tc_classname,
tc_fptr,
} tc_kind;
typedef union {
TC type;
+ HV *stash;
CV *cv;
OP *op;
- HV *stash;
- char *classname;
bool (*fptr)(pTHX_ SV *type_constraint, SV *sv);
} TC_CHECK;
break;
}
- return SvTYPE(sv) == svt;
+ return SvTYPE(SvRV(sv)) == svt;
}
STATIC bool check_sv_class (pTHX_ HV *stash, SV *sv) {
STATIC bool check_sv_type (TC type, SV *sv) {
if (!sv)
return 0;
+
switch (type) {
case Any:
return 1;
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 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;
return 0;
}
-STATIC bool check_sv_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
+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;
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;
}
-STATIC void init_attr (MI *mi, ATTR *attr, HV *desc) {
+STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
+ U32 flags = 0;
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);
+ I32 ix = av_len(desc);
+ SV **params = AvARRAY(desc);
+ SV *tc;
+ SV *key;
attr->mi = mi;
- attr->flags = 0;
+ if ( ix != 12 )
+ croak("wrong number of args (%d != 13)", ix + 1);
- /* if type == hash */
- /* prehash the key */
- if ( !key ) croak("'key' is required");
+ 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");
- pv = SvPV(*key, len);
+ 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);
- attr->slot_sv = newSVpvn_share(pv, len, hash);
- attr->slot_u32 = hash;
- attr->def.type = 0;
+ /* FIXME better organize these */
+ if ( SvTRUE(params[2]) )
+ flags |= ATTR_WEAK;
+
+ if ( SvTRUE(params[3]) )
+ flags |= ATTR_COERCE;
- attr->tc_check.type = 0;
- attr->type_constraint = NULL;
+ if ( SvTRUE(params[4]) )
+ flags |= ATTR_LAZY;
+ tc = params[5];
- attr->initializer = NULL;
- attr->trigger = NULL;
+ 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();
for ( ix = 0; ix < num; ix++ ) {
SV **desc = av_fetch(attrs, ix, 0);
- if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVHV) ) {
+ 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], (HV *)SvRV(*desc));
+ init_attr(mi, &mi->attrs[ix], (AV *)SvRV(*desc));
}
return mi;
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 */
SP -= items;
- assert( ATTR_DUMB_READER(attr) );
-
- value = get_slot_value(aTHX_ ST(0), attr);
+ value = getter_common(aTHX_ ST(0), attr);
if (value) {
ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
SP -= items;
- assert( ATTR_DUMB_WRITER(attr) );
-
- set_slot_value(aTHX_ ST(0), attr, ST(1));
+ setter_common(aTHX_ ST(0), attr, ST(1));
ST(0) = ST(1); /* return value */
XSRETURN(1);
SP -= items;
if (items > 1) {
- assert( ATTR_DUMB_READER(attr) );
- set_slot_value(aTHX_ ST(0), attr, ST(1));
+ setter_common(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);
+ SV *value = getter_common(aTHX_ ST(0), attr);
if ( value ) {
ST(0) = value;
} else {
return $attr->associated_class->get_meta_instance;
}
+ my $i;
+ my %checks = map { $_ => $i++ } qw(
+ Any
+ Undef
+ Defined
+ Str
+ Num
+ Int
+ GlobRef
+ ArrayRef
+ HashRef
+ CodeRef
+ Ref
+ ScalarRef
+ FileHandle
+ RegexpRef
+ Object
+ ClassName
+ );
+
+ # aliases
+ $checks{Bool} = $checks{Item} = $checks{Any};
+ $checks{Value} = $checks{Str};
+
+ sub tc_params {
+ my $tc = shift;
+
+ return ( undef, 0, undef ) unless $tc;
+
+ if ( ref $tc eq 'Moose::Meta::TypeConstraint' or ref $tc eq 'Moose::Meta::TypeConstraint::Parameterizable') {
+ # builtin moose type #
+ return ( $tc, 1, $checks{$tc->name} );
+ } elsif ( $tc->isa("Moose::Meta::TypeConstraint::Class") ) {
+ return ( $tc, 2, $tc->class );
+ } else {
+ warn ref $tc;
+ return ( $tc, 3, $tc->_compiled_type_constraint );
+ }
+ }
+
sub meta_instance_to_attr_descs {
my $mi = shift;
return (
$mi->associated_metaclass->name,
- [ map { {
- meta => $_,
- key => ($_->slots)[0],
- } } $mi->get_all_attributes ]
+ [ map {[
+ $_,
+ [$_->slots],
+
+ $_->is_weak_ref,
+ $_->should_coerce,
+ $_->is_lazy,
+
+ tc_params($_->type_constraint),
+ $_->trigger,
+ $_->initializer,
+
+ $_->has_default,
+ $_->default,
+ $_->builder,
+ ]} $mi->get_all_attributes ]
);
}
}
has i => ( isa => "Int", is => "rw" );
has s => ( isa => "Str", is => "rw" );
has a => ( isa => "ArrayRef", is => "rw" );
+
+ # FIXME Regexp, Class, ClassName, Object, parametrized, filehandle
}
{
projects / gitmo/Moose.git / commitdiff