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 * delegations and attribute helpers:
28 * I32 *type; // hash, array, whatever + vtable for operation
33 STATIC MGVTBL null_mg_vtbl = {
47 #endif /* MGf_LOCAL */
50 STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) {
51 MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 );
52 mg->mg_flags |= MGf_REFCOUNTED;
57 STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
58 MAGIC *mg, *moremagic;
60 if (SvTYPE(sv) >= SVt_PVMG) {
61 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
62 if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl))
72 /* this is a enum of checks */
74 Any, /* or item, or bool */
80 GlobRef, /* SVt_PVGV */
81 ArrayRef, /* SVt_PVAV */
82 HashRef, /* SVt_PVHV */
83 CodeRef, /* SVt_PVCV */
108 bool (*fptr)(pTHX_ SV *type_constraint, SV *sv);
127 /* the meta instance struct */
130 U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
132 /* slot access fields */
133 SV *slot_sv; /* value of the slot (slot name presumably) */
134 U32 slot_u32; /* for optimized access (precomputed hash or otherr) */
136 DEFAULT def; /* cv, value or other, depending on flags */
138 TC_CHECK tc_check; /* cv, value or other, dependidng on flags */
139 SV *type_constraint; /* meta attr */
144 SV *meta_attr; /* the meta attr object */
145 AV *cvs; /* CVs which use this attr */
149 * instance reading writing
150 * 00000000 00000000 00000000 00000000
153 * ^ tc.sv is refcounted
158 * ^ def.sv is refcounted
160 * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD
163 #define ATTR_INSTANCE_MASK 0xff000000
164 #define ATTR_READING_MASK 0x0000ff00
165 #define ATTR_WRITING_MASK 0x000000ff
167 #define ATTR_MASK_TYPE 0x7
169 #define ATTR_MASK_DEFAULT 0x700
170 #define ATTR_SHIFT_DEFAULT 8
172 #define ATTR_LAZY 0x800
173 #define ATTR_DEFREFCNT 0x1000
175 #define ATTR_COERCE 0x8
176 #define ATTR_TCREFCNT 0x10
177 #define ATTR_WEAK 0x20
178 #define ATTR_TRIGGER 0x40
180 #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK )
181 #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY )
182 #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE )
184 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
185 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
187 #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr)
188 #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 )
189 #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 )
191 #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv))
194 /* FIXME define a vtable that does call_sv */
196 SV * (*get)(pTHX_ SV *self, ATTR *attr);
197 void (*set)(pTHX_ SV *self, ATTR *attr, SV *value);
198 bool * (*has)(pTHX_ SV *self, ATTR *attr);
199 SV * (*delete)(pTHX_ SV *self, ATTR *attr);
206 /* these are not yet implemented */
216 /* slot access method */
220 /* attr descriptors */
228 STATIC bool check_is_scalar_ref(SV *sv) {
230 switch (SvTYPE(SvRV(sv))) {
244 STATIC bool check_reftype(TC type, SV *sv) {
265 return SvTYPE(SvRV(sv)) == svt;
268 STATIC bool check_sv_class(pTHX_ HV *stash, SV *sv) {
281 if (SvSTASH(rv) == stash)
288 XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0)));
291 call_method("isa", G_SCALAR);
302 STATIC bool check_sv_type (TC type, SV *sv) {
317 return (SvOK(sv) && !SvROK(sv));
319 #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
320 if (!SvPOK(sv) && !SvPOKp(sv))
321 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
324 return looks_like_number(sv);
329 } else if ( SvPOK(sv) ) {
330 /* FIXME i really don't like this */
333 char *pv = SvPV(sv, len);
334 char *end = pv + len;
338 i = strtol(pv, &tail, 0);
340 if ( errno ) return 0;
342 while ( tail != end ) {
343 if ( !isspace(*tail++) ) return 0;
354 return check_is_scalar_ref(sv);
360 return check_reftype(type, sv);
363 return sv_isobject(sv);
366 if ( SvOK(sv) && !SvROK(sv) ) {
370 return ( gv_stashpvn(pv, len, 0) != NULL );
375 return sv_isa(sv, "Regexp");
387 STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) {
397 call_sv(cv, G_SCALAR);
409 STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
415 return check_sv_type(tc_check.type, sv);
418 return check_sv_class(aTHX_ (HV *)tc_check.sv, sv);
421 return tc_check.fptr(aTHX_ type_constraint, sv);
424 return check_sv_cv(aTHX_ tc_check.sv, sv);
436 STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
441 I32 ix = av_len(desc);
442 SV **params = AvARRAY(desc);
450 croak("wrong number of args (%d != 13)", ix + 1);
452 for ( ; ix >= 0; ix-- ) {
453 if ( !params[ix] || params[ix] == &PL_sv_undef )
457 if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV )
458 croak("slots is not an array");
460 if ( av_len((AV *)SvRV(params[1])) != 0 )
461 croak("Only unary slots are supported at the moment");
463 /* calculate a hash from the slot */
464 /* FIXME arrays etc should also be supported */
465 key = *av_fetch((AV *)SvRV(params[1]), 0, 0);
467 PERL_HASH(hash, pv, len);
470 /* FIXME better organize these */
471 if ( SvTRUE(params[2]) )
474 if ( SvTRUE(params[3]) )
475 flags |= ATTR_COERCE;
477 if ( SvTRUE(params[4]) )
483 int tc_kind = SvIV(params[6]);
484 SV *data = params[7];
488 attr->tc_check.type = SvIV(data);
491 flags |= ATTR_TCREFCNT;
492 attr->tc_check.sv = (SV *)gv_stashsv(data, 0);
495 flags |= ATTR_TCREFCNT;
496 attr->tc_check.sv = SvRV(data);
497 if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV )
498 croak("compiled type constraint is not a coderef");
508 if ( SvTRUE(params[10]) ) { /* has default */
512 attr->def.sv = SvRV(sv);
513 if ( SvTYPE(attr->def.sv) != SVt_PVCV )
514 croak("compiled type constraint is not a coderef");
516 attr->def.sv = newSVsv(sv);
517 sv_2mortal(attr->def.sv); /* in case of error soon, we refcnt inc it later after we're done checking params */
520 flags |= ( ATTR_DEFREFCNT | ( default_normal << ATTR_SHIFT_DEFAULT ) );
521 } else if ( SvOK(params[12]) ) { /* builder */
522 attr->def.sv = newSVsv(params[12]);
523 flags |= ( ATTR_DEFREFCNT | ( default_builder << ATTR_SHIFT_DEFAULT ) );
526 attr->flags = flags; /* FIXME default_kind */
528 attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL;
529 if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV )
530 croak("trigger is not a coderef");
532 attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL;
533 if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV )
534 croak("initializer is not a coderef");
537 attr->meta_attr = newSVsv(params[0]);
538 attr->type_constraint = newSVsv(tc);
539 SvREFCNT_inc(attr->trigger);
540 SvREFCNT_inc(attr->initializer);
541 if ( flags & ATTR_TCREFCNT ) SvREFCNT_inc(attr->tc_check.sv);
542 if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc(attr->def.sv);
544 attr->slot_sv = newSVpvn_share(pv, len, hash);
545 attr->slot_u32 = hash;
547 /* cross refs to CVs which use this struct */
551 STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) {
554 const I32 num = av_len(attrs) + 1;
558 SvREFCNT_inc_simple(stash);
561 mi->type = 0; /* nothing else implemented yet */
563 /* initialize attributes */
565 Newx(mi->attrs, num, ATTR);
566 for ( ix = 0; ix < num; ix++ ) {
567 SV **desc = av_fetch(attrs, ix, 0);
569 if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
570 croak("Attribute descriptor has to be a hash reference");
573 init_attr(mi, &mi->attrs[ix], (AV *)SvRV(*desc));
579 STATIC void delete_mi (pTHX_ MI *mi) {
582 for ( i = 0; i < mi->num_attrs; i++ ) {
583 ATTR *attr = &mi->attrs[i];
584 /* clear the pointers to this meta attr from all the CVs */
585 SV **cvs = AvARRAY(attr->cvs);
586 for ( j = av_len(attr->cvs); j >= 0; j-- ) {
587 CV *cv = (CV *)cvs[j];
591 SvREFCNT_dec(attr->cvs);
592 SvREFCNT_dec(attr->slot_sv);
593 SvREFCNT_dec(attr->type_constraint);
594 if ( attr->flags & ATTR_TCREFCNT ) SvREFCNT_dec(attr->tc_check.sv);
595 if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv);
596 SvREFCNT_dec(attr->initializer);
597 SvREFCNT_dec(attr->trigger);
598 SvREFCNT_dec(attr->meta_attr);
605 STATIC SV *new_mi_obj (pTHX_ MI *mi) {
606 HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
607 SV *obj = newRV_noinc(newSViv(PTR2IV(mi)));
608 sv_bless( obj, stash );
612 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
618 croak("No attr found in magic!");
625 count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
628 croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
639 return sv_2mortal(mi);
642 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
655 count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
658 croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
666 stash = gv_stashsv(class, 0);
668 mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
673 return new_mi_obj(aTHX_ mi);
676 STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
679 for ( ix = 0; ix < mi->num_attrs; ix++ ) {
680 if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
681 return &mi->attrs[ix];
686 croak("Attr not found");
690 STATIC ATTR *get_attr(pTHX_ CV *cv) {
691 SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv);
692 SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
693 SV *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
697 c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
698 stash_in_mg(aTHX_ SvRV(perl_mi), c_mi);
702 mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
704 return mi_find_attr(mi, meta_attr);
707 STATIC ATTR *define_attr (pTHX_ CV *cv) {
708 ATTR *attr = get_attr(aTHX_ cv);
711 XSANY.any_i32 = PTR2IV(attr);
714 av_push( attr->cvs, (SV *)cv );
719 STATIC void weaken(pTHX_ SV *sv) {
721 sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
723 croak("weak references are not implemented in this release of perl");
728 /* meta instance protocol */
730 STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
735 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
737 assert( ATTR_DUMB_INSTANCE(attr) );
739 if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
745 STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
751 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
753 assert( ATTR_DUMB_INSTANCE(attr) );
755 copy = newSVsv(value);
757 he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
760 if ( ATTR_ISWEAK(attr) )
761 weaken(aTHX_ HeVAL(he));
764 croak("Hash store failed.");
768 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
771 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
773 assert( ATTR_DUMB_INSTANCE(attr) );
775 return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
778 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
781 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
783 assert( ATTR_DUMB_INSTANCE(attr) );
785 return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
788 STATIC void writer_common(pTHX_ SV *self, ATTR *attr, SV *value);
791 STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) {
792 switch ( ATTR_DEFAULT(attr) ) {
796 case default_builder:
807 call_method(SvPV_nolen(attr->def.sv), G_SCALAR);
818 return sv_2mortal(sv);
822 if ( SvROK(attr->def.sv) ) {
823 printf("CV default\n");
825 printf("simple value\n");
826 return attr->def.sv; /* will be copied by set for lazy, and by reader for both cases */
838 STATIC SV *reader_common(pTHX_ SV *self, ATTR *attr) {
839 SV *value = get_slot_value(aTHX_ self, attr);
843 } else if ( ATTR_ISLAZY(attr) ) {
844 value = get_default(aTHX_ self, attr);
845 writer_common(aTHX_ self, attr, value);
852 STATIC void writer_common(pTHX_ SV *self, ATTR *attr, SV *value) {
853 if ( ATTR_TYPE(attr) ) {
854 if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) )
858 set_slot_value(aTHX_ self, attr, value);
861 /* simple high level api */
874 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
878 value = reader_common(aTHX_ ST(0), attr);
881 ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
898 Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
902 writer_common(aTHX_ ST(0), attr, ST(1));
904 ST(0) = ST(1); /* return value */
918 Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
923 writer_common(aTHX_ ST(0), attr, ST(1));
924 ST(0) = ST(1); /* return value */
926 SV *value = reader_common(aTHX_ ST(0), attr);
937 STATIC XS(predicate);
947 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
951 if ( has_slot_value(aTHX_ ST(0), attr) )
965 STATIC XSPROTO ((*xs_bodies[])) = {
972 MODULE = Moose PACKAGE = Moose::XS
980 new_reader = xs_body_reader
981 new_writer = xs_body_writer
982 new_accessor = xs_body_accessor
983 new_predicate = xs_body_predicate
987 if ( ix >= max_xs_body )
988 croak("Unknown Moose::XS body type");
990 if ( !sv_isobject(attr) )
991 croak("'attr' must be a Moose::Meta::Attribute");
993 cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
998 /* associate CV with meta attr */
999 stash_in_mg(aTHX_ (SV *)cv, attr);
1001 /* this will be set on first call */
1009 MODULE = Moose PACKAGE = Moose::XS::Meta::Instance
1016 MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
1018 delete_mi(aTHX_ mi);