5 #define NEED_newRV_noinc
6 #define NEED_newSVpvn_share
7 #define NEED_sv_2pv_flags
11 #define XSPROTO(name) void name(pTHX_ CV* cv)
15 #define gv_stashpvs(x, y) gv_stashpvn(STR_WITH_LEN(x), y)
19 * type constraints are already implemented by konobi
20 * should be trivial to do coercions for the core types, too
22 * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then*
23 * call ->isa (should handle vast majority of cases)
25 * base parametrized types are also trivial
27 * ClassName is get_stathpvn
31 * for a constructor we have ATTR *attrs, and iterate that, removing init_arg
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
37 * delegations and attribute helpers:
46 * I32 *type; // hash, array, whatever + vtable for operation
51 STATIC MGVTBL null_mg_vtbl = {
65 #endif /* MGf_LOCAL */
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;
75 STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
76 MAGIC *mg, *moremagic;
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))
90 /* this is a enum of checks */
92 Any, /* or item, or bool */
98 GlobRef, /* SVt_PVGV */
99 ArrayRef, /* SVt_PVAV */
100 HashRef, /* SVt_PVHV */
101 CodeRef, /* SVt_PVCV */
127 bool (*fptr)(pTHX_ SV *type_constraint, SV *sv);
148 /* the meta instance struct */
151 U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
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) */
157 DEFAULT def; /* cv, value or other, depending on flags */
159 TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
160 SV *type_constraint; /* meta attr */
165 SV *meta_attr; /* the meta attr object */
166 AV *cvs; /* CVs which use this attr */
170 * instance reading writing
171 * 00000000 00000000 00000000 00000000
179 * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD
182 #define ATTR_INSTANCE_MASK 0xff000000
183 #define ATTR_READING_MASK 0x0000ff00
184 #define ATTR_WRITING_MASK 0x000000ff
186 #define ATTR_MASK_TYPE 0x7
188 #define ATTR_MASK_DEFAULT 0x700
189 #define ATTR_SHIFT_DEAFULT 8
191 #define ATTR_LAZY 0x800
193 #define ATTR_COERCE 0x08
194 #define ATTR_WEAK 0x10
195 #define ATTR_TRIGGER 0x10
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 )
201 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
202 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
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 )
208 #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv))
211 /* FIXME define a vtable that does call_sv */
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);
223 /* these are not yet implemented */
233 /* slot access method */
237 /* attr descriptors */
245 STATIC bool check_is_scalar_ref(SV *sv) {
247 switch (SvTYPE(SvRV(sv))) {
261 STATIC bool check_reftype(TC type, SV *sv) {
282 return SvTYPE(SvRV(sv)) == svt;
285 STATIC bool check_sv_class (pTHX_ HV *stash, SV *sv) {
297 if (SvSTASH(sv) == stash)
304 XPUSHs(newSVpv(HvNAME_get(SvSTASH(sv)), 0));
307 call_method("isa", G_SCALAR);
318 STATIC bool check_sv_type (TC type, SV *sv) {
333 return (SvOK(sv) && !SvROK(sv));
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);
340 return looks_like_number(sv);
345 } else if ( SvPOK(sv) ) {
349 char *pv = SvPV(sv, len);
350 char *end = pv + len;
353 i = strtol(pv, &end, 0);
362 return check_is_scalar_ref(sv);
368 return check_reftype(type, sv);
371 return sv_isobject(sv);
378 return ( gv_stashpvn(pv, len, 0) != NULL );
382 return sv_isa(sv, "Regexp");
394 STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
400 return check_sv_type(tc_check.type, sv);
403 return check_sv_class(aTHX_ tc_check.stash, sv);
406 return tc_check.fptr(aTHX_ type_constraint, sv);
419 STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
424 I32 ix = av_len(desc);
425 SV **params = AvARRAY(desc);
433 croak("wrong number of args (%d != 13)", ix + 1);
435 for ( ; ix >= 0; ix-- ) {
436 if ( !params[ix] || params[ix] == &PL_sv_undef )
440 if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV )
441 croak("slots is not an array");
443 if ( av_len((AV *)SvRV(params[1])) != 0 )
444 croak("Only unary slots are supported at the moment");
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);
450 PERL_HASH(hash, pv, len);
453 /* FIXME better organize these */
454 if ( SvTRUE(params[2]) )
457 if ( SvTRUE(params[3]) )
458 flags |= ATTR_COERCE;
460 if ( SvTRUE(params[4]) )
466 int tc_kind = SvIV(params[6]);
467 SV *data = params[7];
471 attr->tc_check.stash = gv_stashsv(data, 0);
474 attr->tc_check.type = SvIV(data);
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");
488 attr->flags = flags; /* FIXME default_kind */
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");
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");
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);
504 attr->slot_sv = newSVpvn_share(pv, len, hash);
505 attr->slot_u32 = hash;
509 /* cross refs to CVs which use this struct */
513 STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) {
516 const I32 num = av_len(attrs) + 1;
520 SvREFCNT_inc_simple(stash);
523 mi->type = 0; /* nothing else implemented yet */
525 /* initialize attributes */
527 Newx(mi->attrs, num, ATTR);
528 for ( ix = 0; ix < num; ix++ ) {
529 SV **desc = av_fetch(attrs, ix, 0);
531 if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
532 croak("Attribute descriptor has to be a hash reference");
535 init_attr(mi, &mi->attrs[ix], (AV *)SvRV(*desc));
541 STATIC SV *new_mi_obj (pTHX_ MI *mi) {
542 HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
543 SV *obj = newRV_noinc(newSViv(PTR2IV(mi)));
544 sv_bless( obj, stash );
548 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
554 croak("No attr found in magic!");
561 count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
564 croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
578 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
591 count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
594 croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
602 stash = gv_stashsv(class, 0);
604 mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
609 return new_mi_obj(aTHX_ mi);
612 STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
615 for ( ix = 0; ix < mi->num_attrs; ix++ ) {
616 if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
617 return &mi->attrs[ix];
622 croak("Attr not found");
626 STATIC ATTR *get_attr(pTHX_ CV *cv) {
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));
633 c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
634 stash_in_mg(aTHX_ SvRV(perl_mi), c_mi);
639 mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
641 return mi_find_attr(mi, meta_attr);
644 STATIC ATTR *define_attr (pTHX_ CV *cv) {
645 ATTR *attr = get_attr(aTHX_ cv);
648 XSANY.any_i32 = PTR2IV(attr);
650 av_push( attr->cvs, (SV *)cv );
655 STATIC void weaken(pTHX_ SV *sv) {
657 sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
659 croak("weak references are not implemented in this release of perl");
664 /* meta instance protocol */
666 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
671 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
673 assert( ATTR_DUMB_INSTANCE(attr) );
675 if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
681 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
687 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
689 assert( ATTR_DUMB_INSTANCE(attr) );
691 copy = newSVsv(value);
693 he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
696 if ( ATTR_ISWEAK(attr) )
697 weaken(aTHX_ HeVAL(he));
700 croak("Hash store failed.");
704 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
707 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
709 assert( ATTR_DUMB_INSTANCE(attr) );
711 return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
714 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
717 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
719 assert( ATTR_DUMB_INSTANCE(attr) );
721 return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
724 STATIC SV *getter_common(pTHX_ SV *self, ATTR *attr) {
725 assert( ATTR_DUMB_READER(attr) );
726 return get_slot_value(aTHX_ self, attr);
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) )
735 set_slot_value(aTHX_ self, attr, value);
738 /* simple high level api */
751 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
755 value = getter_common(aTHX_ ST(0), attr);
758 ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
775 Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
779 setter_common(aTHX_ ST(0), attr, ST(1));
781 ST(0) = ST(1); /* return value */
795 Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
800 setter_common(aTHX_ ST(0), attr, ST(1));
801 ST(0) = ST(1); /* return value */
803 SV *value = getter_common(aTHX_ ST(0), attr);
814 STATIC XS(predicate);
824 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
828 if ( has_slot_value(aTHX_ ST(0), attr) )
842 STATIC XSPROTO ((*xs_bodies[])) = {
849 MODULE = Moose PACKAGE = Moose::XS
857 new_getter = xs_body_getter
858 new_setter = xs_body_setter
859 new_accessor = xs_body_accessor
860 new_predicate = xs_body_predicate
864 if ( ix >= max_xs_body )
865 croak("Unknown Moose::XS body type");
867 if ( !sv_isobject(attr) )
868 croak("'attr' must be a Moose::Meta::Attribute");
870 cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
875 /* associate CV with meta attr */
876 stash_in_mg(aTHX_ (SV *)cv, attr);
878 /* this will be set on first call */
886 MODULE = Moose PACKAGE = Moose::XS::Meta::Instance
893 MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
895 printf("destroying\n");
896 /* foreach attr ( delete cvs XSANY ), free attrs free mi */