5 #define NEED_grok_number
6 #define NEED_grok_numeric_radix
7 #define NEED_newRV_noinc
8 #define NEED_newSVpvn_share
9 #define NEED_sv_2pv_flags
13 #define XSPROTO(name) void name(pTHX_ CV* cv)
17 #define gv_stashpvs(x, y) Perl_gv_stashpvn(aTHX_ STR_WITH_LEN(x), y)
21 * delegations and attribute helpers:
30 * I32 *type; // hash, array, whatever + vtable for operation
39 /* These two functions attach magic with no behavior to an SV.
41 * The stashed value is reference counted, and is destroyed when it's parent
42 * object is destroyed.
44 * This is used to keep a reference the the meta attribute from a generated
45 * method, and to cache the C struct based wrapper attached to the meta
49 STATIC MGVTBL null_mg_vtbl = {
63 #endif /* MGf_LOCAL */
66 STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) {
67 MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 );
68 mg->mg_flags |= MGf_REFCOUNTED;
73 STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) {
76 if (SvTYPE(sv) >= SVt_PVMG) {
77 for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
78 if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl))
96 /* The folloing data structures deal with type constraints */
98 /* this is an enum of the various kinds of constraint checking an attribute can
101 * tc_cv is the fallback behavior (simply applying the
102 * ->_compiled_type_constraint to the value, but other more optimal checks are
103 * implemented too. */
106 tc_none = 0, /* no type checking */
107 tc_type, /* a builtin type to be checked by check_sv_type */
108 tc_stash, /* a stash for a class, implements TypeConstraint::Class by comparing SvSTASH and then invoking C<isa> if necessary */
109 tc_cv, /* applies a code reference to the value and checks for truth */
110 tc_fptr, /* apply a C function pointer */
111 tc_enum /* TODO check that the value is in an allowed set of values (strings) */
114 /* this is a enum of builtin type check. They are handled in a switch statement
115 * in check_sv_type */
117 Any, /* or item, or bool */
123 GlobRef, /* SVt_PVGV */
124 ArrayRef, /* SVt_PVAV */
125 HashRef, /* SVt_PVHV */
126 CodeRef, /* SVt_PVCV */
129 FileHandle, /* TODO */
136 /* auxillary pointer/int union used for constraint checking */
138 TC type; /* the builtin type number for tc_type */
139 SV *sv; /* the cv for tc_cv, or the stash for tc_stash */
140 OP *op; /* TODO not used */
141 bool (*fptr)(pTHX_ SV *type_constraint, SV *sv); /* the function pointer for tc_fptr FIXME aux data? */
149 /* The folloing data structures deal with type default value generation */
151 /* This is an enum for the various types of default value behaviors an
152 * attribute can have */
155 default_none = 0, /* no default value */
156 default_normal, /* code reference or scalar */
157 default_builder, /* builder method */
158 default_type /* TODO enumerated type optimization (will call newHV, newAV etc to avoid calling a code ref for these simple cases) */
162 SV *sv; /* The default value, or a code ref to generate one. If builder then this sv is applied as a method (stringified) */
163 U32 type; /* TODO for default_type, should probably be one of SVt_PVAV/SVt_PVHV */
171 /* the ATTR struct contains all the meta data for a Moose::Meta::Attribute for
172 * a given meta instance
174 * flags determines the various behaviors
176 * This supports only one slot per attribute in the current implementation, but
177 * slot_sv could contain an array
179 * A list of XSUBs that rely on this attr struct are cross indexed in the cvs
180 * array, so that when the meta instance is destroyed the XSANY field will be
181 * cleared. This is done in delete_mi
185 /* pointer to the MI this attribute is a part of the meta instance struct */
188 U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */
190 /* slot access fields */
191 SV *slot_sv; /* value of the slot (currently always slot name) */
192 U32 slot_u32; /* for optimized access (precomputed hash, possibly something else) */
197 DEFAULT def; /* cv, value or other, depending on flags */
199 TC_CHECK tc_check; /* see TC_CHECK*/
200 SV *type_constraint; /* Moose::Meta::TypeConstraint object */
204 SV *writer; /* used by the initializer */
206 SV *meta_attr; /* the Moose::Meta::Attribute */
207 AV *cvs; /* an array of CVs which use this attr, see delete_mi */
210 /* the flags integer is mapped as follows
211 * instance misc reading writing
212 * 00000000 00000000 00000000 00000000
216 * ^ tc.sv is refcounted
223 * ^ def.sv is refcounted
226 * ^ attr is required TODO
228 * flags having to do with the instance layout (TODO, only hash supported for now)
229 * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD
232 #define ATTR_INSTANCE_MASK 0xff000000
233 #define ATTR_READING_MASK 0x0000ff00
234 #define ATTR_WRITING_MASK 0x000000ff
236 #define ATTR_MASK_TYPE 0x7
238 #define ATTR_MASK_DEFAULT 0x700
239 #define ATTR_SHIFT_DEFAULT 8
241 #define ATTR_LAZY 0x800
242 #define ATTR_DEFREFCNT 0x1000
244 #define ATTR_COERCE 0x8
245 #define ATTR_TCREFCNT 0x10
246 #define ATTR_WEAK 0x20
247 #define ATTR_TRIGGER 0x40
249 #define ATTR_REQUIRED 0x10000
250 #define ATTR_INIT_ARG 0x20000
251 #define ATTR_INITIALIZER 0x40000
253 #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK )
254 #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY )
255 #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE )
256 #define ATTR_HAS_TRIGGER(attr) ( attr->flags & ATTR_TRIGGER )
257 #define ATTR_HAS_INIT_ARG(attr) ( attr->flags & ATTR_INIT_ARG )
258 #define ATTR_HAS_INITIALIZER(attr) ( attr->flags & ATTR_INITIALIZER )
260 #define ATTR_IS_REQUIRED(Attr) ( attr->flags & ATTR_REQUIRED )
262 #define ATTR_TYPE(f) ( attr->flags & 0x7 )
263 #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT )
265 #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr)
266 #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 )
267 #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 )
271 /* This unused (TODO) vtable will implement the meta instance protocol in terms
272 * of function pointers to allow the XS accessors to be used with custom meta
273 * instances in the future.
275 * We'll need to define a default instance of this vtable that uses call_sv,
278 /* FIXME define a vtable that does call_sv for fallback meta instance protocol */
280 SV * (*get)(pTHX_ SV *self, ATTR *attr);
281 void (*set)(pTHX_ SV *self, ATTR *attr, SV *value);
282 bool * (*has)(pTHX_ SV *self, ATTR *attr);
283 SV * (*delete)(pTHX_ SV *self, ATTR *attr);
286 /* TODO this table describes the instance layout of the object. Not yet
291 /* these are not yet implemented */
299 /* this struct models the meta instance *and* meta attributes simultaneously.
300 * It is a cache of the meta attribute behaviors for a given class or subclass
301 * and can be parametrized on that level
304 * An object pointing to this structure is kept in a refcounted magic inside
305 * the meta instance it corresponds to. On C<invalidate_meta_instance> the meta
306 * instance is destroyed, causing the proxy object to be destroyed, deleting
307 * this structure, clearing the XSANY of all dependent attribute methods.
309 * The next invocation of an attribute method will eventually call get_attr,
310 * which will call C<get_meta_instance> on the metaclass (recreating it in the
311 * Class::MOP level), and cache a new MI struct inside it. Subsequent
312 * invocations of get_attr will then search the MI for an ATTR matching the
313 * meta_attribute of the attribute method */
317 /* slot access method */
318 instance_types type; /* TODO only hashes supported currently */
319 instance_vtbl *vtbl; /* TODO */
321 /* attr descriptors */
325 /* dependent methods */
332 /* Moose::Meta::Instance level API */
333 STATIC SV *get_slot_lvalue(pTHX_ SV *self, ATTR *attr);
334 STATIC bool set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value);
335 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr);
336 STATIC SV *create_instance(pTHX_ MI *mi);
337 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr);
339 /* Moose::Meta::Attribute level API */
340 STATIC void attr_set_initial_value(pTHX_ SV *self, ATTR *attr, SV *value);
341 STATIC SV *attr_get_value(pTHX_ SV *self, ATTR *attr);
342 STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value);
343 STATIC SV *attr_clear_value(pTHX_ SV *self, ATTR *attr);
344 STATIC bool attr_has_value(pTHX_ SV *self, ATTR *attr);
345 STATIC SV *class_new_object(pTHX_ MI *mi, HV *params);
348 /* Moose::Meta::Attribute level API (XSUBs) */
349 STATIC CV *new_method (pTHX_ SV *attr, XSPROTO(body), char *name);
350 STATIC XS(initializer); /* only used by attr_set_initial_value */
354 STATIC XS(predicate);
356 STATIC XS(new_object);
358 STATIC ATTR *define_attr(pTHX_ CV *cv);
359 STATIC MI *define_mi(pTHX_ CV *cv);
362 /* This macro is used in the XS subs to set up the 'attr' variable.
364 * if XSANY is NULL then define_attr is called on the CV, to set the pointer
365 * to the ATTR struct.
367 #define dATTR ATTR *attr = (XSANY.any_ptr ? INT2PTR(ATTR *, (XSANY.any_ptr)) : define_attr(aTHX_ cv))
368 #define dMI MI *mi = (XSANY.any_ptr ? INT2PTR(MI *, (XSANY.any_ptr)) : define_mi(aTHX_ cv))
374 /* these functions implement type constraint checking */
376 /* checks that the SV is a scalar ref */
377 STATIC bool check_is_scalar_ref(SV *sv) {
379 switch (SvTYPE(SvRV(sv))) {
393 /* checks that the SV is a ref to a certain SvTYPE, where type is in the table
395 STATIC bool check_reftype(TC type, SV *sv) {
415 croak("not a reftype %d\n", type);
418 return SvTYPE(SvRV(sv)) == svt;
421 /* checks whether an SV is of a certain class
422 * SvSTASH is first compared by pointer for efficiency */
423 STATIC bool check_sv_class(pTHX_ HV *stash, SV *sv) {
436 if (SvSTASH(rv) == stash)
443 XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0)));
446 call_method("isa", G_SCALAR);
457 /* checks whether SV of of a known simple type. Most of the non parametrized
458 * Moose core types are implemented here */
459 STATIC bool check_sv_type (TC type, SV *sv) {
476 return (SvOK(sv) && !SvROK(sv));
478 #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5)
479 if (!SvPOK(sv) && !SvPOKp(sv))
480 return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK);
483 return looks_like_number(sv);
488 } else if ( SvPOK(sv) ) {
490 char *pv = SvPV(sv, len);
491 int flags = grok_number(pv, len, NULL);
492 return ( flags && !(flags & IS_NUMBER_NOT_INT) );
500 return check_is_scalar_ref(sv);
506 return check_reftype(type, sv);
510 /* not using sv_isobject to avoid repeated get magic */
513 if ( SvOBJECT(rv) ) {
514 char *name = HvNAME_get(SvSTASH(SvRV(sv)));
516 bool is_regexp = strEQ("Regexp", name);
517 return ( (type == RegexpRef) ^ !is_regexp );
524 if ( SvOK(sv) && !SvROK(sv) ) {
528 return ( gv_stashpvn(pv, len, 0) != NULL );
542 /* invoke a CV on an SV and return SvTRUE of the result */
543 STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) {
554 call_sv(cv, G_SCALAR);
558 ret = SvTRUE(ret_sv);
567 /* checks the type constraint for an SV based on the type constraint kind */
568 STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) {
574 return check_sv_type(tc_check.type, sv);
577 return check_sv_class(aTHX_ (HV *)tc_check.sv, sv);
580 return tc_check.fptr(aTHX_ type_constraint, sv);
583 return check_sv_cv(aTHX_ tc_check.sv, sv);
595 /* end of type constraint checking functions */
605 /* Initialize the ATTR structure using positional arguments from Perl space. */
607 STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) {
609 U32 slot_hash, init_arg_hash;
610 STRLEN slot_len, init_arg_len;
611 char *slot_pv, *init_arg_pv;
612 I32 ix = av_len(desc);
613 SV **params = AvARRAY(desc);
621 croak("wrong number of args (%d != 14)", (int)ix + 1);
623 for ( ; ix >= 0; ix-- ) {
624 if ( !params[ix] || params[ix] == &PL_sv_undef )
630 /* handle attribute slot array */
632 if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV )
633 croak("slots is not an array");
635 if ( av_len((AV *)SvRV(params[1])) != 0 )
636 croak("Only unary slots are supported at the moment");
638 /* calculate a hash from the slot */
639 /* FIXME arrays etc should also be supported */
640 slot_sv = *av_fetch((AV *)SvRV(params[1]), 0, 0);
641 slot_pv = SvPV(slot_sv, slot_len);
642 PERL_HASH(slot_hash, slot_pv, slot_len);
645 init_arg_sv = params[13];
646 if ( SvOK(init_arg_sv) ) {
647 flags |= ATTR_INIT_ARG;
648 init_arg_pv = SvPV(init_arg_sv, init_arg_len);
649 PERL_HASH(init_arg_hash, init_arg_pv, init_arg_len);
653 /* FIXME better organize these, positionals suck */
654 if ( SvTRUE(params[2]) )
657 if ( SvTRUE(params[3]) )
658 flags |= ATTR_COERCE;
660 if ( SvTRUE(params[4]) )
665 /* type constraint data */
670 int tc_kind = SvIV(params[6]);
671 SV *data = params[7];
675 attr->tc_check.type = SvIV(data);
678 flags |= ATTR_TCREFCNT;
679 attr->tc_check.sv = (SV *)gv_stashsv(data, 0);
682 flags |= ATTR_TCREFCNT;
683 attr->tc_check.sv = SvRV(data);
684 if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV )
685 croak("compiled type constraint is not a coderef");
696 /* default/builder data */
698 if ( SvTRUE(params[10]) ) { /* has default */
702 attr->def.sv = SvRV(sv);
703 if ( SvTYPE(attr->def.sv) != SVt_PVCV )
704 croak("compiled type constraint is not a coderef");
706 attr->def.sv = newSVsv(sv);
707 sv_2mortal(attr->def.sv); /* in case of error soon, we refcnt inc it later after we're done checking params */
710 flags |= ( ATTR_DEFREFCNT | ( default_normal << ATTR_SHIFT_DEFAULT ) );
711 } else if ( SvOK(params[12]) ) { /* builder */
712 attr->def.sv = newSVsv(params[12]);
713 flags |= ( ATTR_DEFREFCNT | ( default_builder << ATTR_SHIFT_DEFAULT ) );
718 attr->trigger = SvROK(params[8]) ? (CV *)SvRV(params[8]) : NULL;
719 if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV )
720 croak("trigger is not a coderef");
722 if ( attr->trigger ) flags |= ATTR_TRIGGER;
724 attr->initializer = SvROK(params[9]) ? (CV *)SvRV(params[9]) : NULL;
725 if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV )
726 croak("initializer is not a coderef");
728 if ( attr->initializer ) flags |= ATTR_INITIALIZER;
730 /* now that we're done preparing/checking args and shit, so we finalize the
731 * attr, increasing refcounts for any referenced data, and creating the CV
736 /* copy the outer ref SV */
737 attr->meta_attr = newSVsv(params[0]);
738 attr->type_constraint = newSVsv(tc);
740 /* increase the refcount for auxillary structures */
741 SvREFCNT_inc_simple_void(attr->trigger);
742 SvREFCNT_inc_simple_void(attr->initializer);
743 if ( flags & ATTR_TCREFCNT ) SvREFCNT_inc_simple_void_NN(attr->tc_check.sv);
744 if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc_simple_void_NN(attr->def.sv);
746 attr->slot_sv = newSVpvn_share(slot_pv, slot_len, slot_hash);
747 attr->slot_u32 = slot_hash;
749 attr->init_arg_sv = newSVpvn_share(init_arg_pv, init_arg_len, init_arg_hash);
750 attr->init_arg_u32 = init_arg_hash;
752 /* cross refs to CVs which use this struct */
756 STATIC SV *new_mi (pTHX_ HV *stash, AV *attrs) {
757 HV *mi_stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
758 SV *sv_ptr = newSViv(0);
759 SV *obj = sv_2mortal(sv_bless(newRV_noinc(sv_ptr), mi_stash));
761 const I32 num_attrs = av_len(attrs) + 1;
765 /* set the pointer now, if we have any initialization errors it'll get
766 * cleaned up because obj is mortal */
767 sv_setiv(sv_ptr, PTR2IV(mi));
769 Newxz(mi->attrs, num_attrs, ATTR);
771 SvREFCNT_inc_simple_void_NN(stash);
774 mi->type = 0; /* nothing else implemented yet */
776 /* initialize attributes */
777 for ( mi->num_attrs = 0; mi->num_attrs < num_attrs; mi->num_attrs++ ) {
778 SV **desc = av_fetch(attrs, mi->num_attrs, 0);
780 if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) {
781 croak("Attribute descriptor has to be a hash reference");
784 init_attr(mi, &mi->attrs[mi->num_attrs], (AV *)SvRV(*desc));
792 STATIC void clear_cvs (AV *av) {
793 SV **cvs = AvARRAY(av);
796 /* remove the pointers from all the the dependent CVs */
798 CV *cv = (CV *)cvs[i--];
799 XSANY.any_ptr = NULL;
805 STATIC void delete_attr (pTHX_ ATTR *attr) {
807 clear_cvs(attr->cvs);
809 SvREFCNT_dec(attr->slot_sv);
810 SvREFCNT_dec(attr->type_constraint);
811 if ( attr->flags & ATTR_TCREFCNT ) SvREFCNT_dec(attr->tc_check.sv);
812 if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv);
813 SvREFCNT_dec(attr->trigger);
814 SvREFCNT_dec(attr->initializer);
815 SvREFCNT_dec(attr->writer);
816 SvREFCNT_dec(attr->meta_attr);
819 STATIC void delete_mi (pTHX_ MI *mi) {
820 SvREFCNT_dec(mi->stash);
822 while ( mi->num_attrs--) {
823 ATTR *attr = &mi->attrs[mi->num_attrs];
824 delete_attr(aTHX_ attr);
827 if ( mi->attrs ) Safefree(mi->attrs);
839 /* these functions call Perl-space for MOP methods, helpers etc */
842 /* wow, so much code for the equivalent of
843 * $attr->associated_class->get_meta_instance */
844 STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
849 croak("No attr found in magic!");
858 call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
863 SvREFCNT_inc_simple_void(mi);
869 return sv_2mortal(mi);
872 /* gets a class and an array of attr parameters */
873 STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
888 count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
891 croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", (int)count);
899 stash = gv_stashsv(class, 0);
901 mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
902 SvREFCNT_inc_simple_void_NN(mi);
907 return sv_2mortal(mi);
912 /* locate an ATTR for a MOP level attribute inside an MI */
913 STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
916 for ( ix = 0; ix < mi->num_attrs; ix++ ) {
917 if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
918 return &mi->attrs[ix];
922 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) );
926 /* returns the ATTR for a CV:
928 * 1. get the Moose::Meta::Attribute using get_stashed_in_mg from the CV itself
929 * 2. get the meta instance by calling $attr->associated_class->get_meta_instance
930 * 3. get the MI by using get_stashed_in_mg from the meta instance, creating it if necessary
931 * 4. search for the appropriate ATTR in the MI using mi_find_attr
933 STATIC MI *get_or_create_mi(pTHX_ SV *perl_mi) {
934 SV *mi_obj = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
937 mi_obj = perl_mi_to_c_mi(aTHX_ perl_mi);
938 stash_in_mg(aTHX_ SvRV(perl_mi), mi_obj);
941 return INT2PTR(MI *, SvIV(SvRV(mi_obj)));
944 STATIC ATTR *get_attr(pTHX_ CV *cv) {
945 SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv);
946 SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
947 MI *mi = get_or_create_mi(aTHX_ perl_mi);
948 return mi_find_attr(mi, meta_attr);
951 STATIC MI *get_mi(pTHX_ CV *cv) {
952 SV *perl_mi = get_stashed_in_mg(aTHX_ (SV *)cv);
953 return(get_or_create_mi(aTHX_ perl_mi));
956 /* Cache a pointer to the appropriate ATTR in the XSANY of the CV, using
958 STATIC ATTR *define_attr (pTHX_ CV *cv) {
959 ATTR *attr = get_attr(aTHX_ cv);
962 XSANY.any_ptr = (void *)attr;
964 SvREFCNT_inc_simple_void(cv);
965 av_push( attr->cvs, (SV *)cv );
970 STATIC MI *define_mi (pTHX_ CV *cv) {
971 MI *mi = get_mi(aTHX_ cv);
974 XSANY.any_ptr = (void *)mi;
976 SvREFCNT_inc_simple_void(cv);
977 av_push( mi->cvs, (SV *)cv );
987 STATIC void weaken(pTHX_ SV *sv) {
989 sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
991 croak("weak references are not implemented in this release of perl");
1000 /* meta instance protocol
1002 * The slot functions don't change the refcount or copy (aliasing semantics)
1004 * create_instance returns a new mortal */
1006 STATIC SV *get_slot_lvalue(pTHX_ SV *self, ATTR *attr) {
1010 assert(SvROK(self));
1011 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
1013 assert( ATTR_DUMB_INSTANCE(attr) );
1015 if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
1021 STATIC bool set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
1025 assert(SvROK(self));
1026 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
1028 assert( ATTR_DUMB_INSTANCE(attr) );
1030 he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32);
1035 STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
1037 assert(SvROK(self));
1038 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
1040 assert( ATTR_DUMB_INSTANCE(attr) );
1042 return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
1045 STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
1047 assert(SvROK(self));
1048 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
1050 assert( ATTR_DUMB_INSTANCE(attr) );
1052 return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
1055 STATIC SV *create_instance(pTHX_ MI *mi) {
1056 return sv_bless(sv_2mortal(newRV_noinc((SV *)newHV())), mi->stash);
1062 /* Shared functionality for readers/writers/accessors, this roughly corresponds
1063 * to the methods of Moose::Meta::Attribute on the instance
1064 * (get_value/set_value, default value handling, etc)
1066 * These functions return mortal copiess and save copies (handling refcounting). */
1068 STATIC void attr_set_common(pTHX_ SV *self, ATTR *attr, SV *value) {
1072 /* FIXME croak if required ? */
1076 if ( ATTR_TYPE(attr) ) {
1077 if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) )
1081 copy = newSVsv(value);
1083 if ( ATTR_ISWEAK(attr) && SvROK(copy) )
1086 if ( !set_slot_value(aTHX_ self, attr, copy) ) {
1088 croak("Hash store failed.");
1093 STATIC XS(initializer)
1102 Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
1106 attr_set_common(aTHX_ ST(0), attr, ST(1));
1111 STATIC void attr_set_initial_value(pTHX_ SV *self, ATTR *attr, SV *value) {
1112 if ( ATTR_HAS_INITIALIZER(attr) ) {
1113 if ( !attr->writer ) {
1114 attr->writer = newRV_inc((SV *)new_method(aTHX_ attr->meta_attr, initializer, NULL ));
1124 XPUSHs(sv_2mortal(newSVsv(value)));
1125 XPUSHs(attr->writer);
1126 XPUSHs(attr->meta_attr);
1129 call_sv((SV *)attr->initializer, G_VOID);
1134 attr_set_common(aTHX_ self, attr, value);
1138 STATIC SV *call_builder (pTHX_ SV *self, ATTR *attr) {
1148 /* we invoke the builder as a stringified method. This will not work for
1149 * $obj->$coderef etc, for that we need to use 'default' */
1151 call_method(SvPV_nolen(attr->def.sv), G_SCALAR);
1153 /* the value is a mortal with a refcount of 1, so we need to keep it around */
1156 SvREFCNT_inc_simple_void(sv);
1162 return sv_2mortal(sv);
1166 STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) {
1167 switch ( ATTR_DEFAULT(attr) ) {
1171 case default_builder:
1172 return call_builder(aTHX_ self, attr);
1174 case default_normal:
1175 if ( SvROK(attr->def.sv) ) {
1176 printf("CV default\n");
1179 printf("simple value\n");
1180 return sv_mortalcopy(attr->def.sv); /* will be copied by set for lazy, and by reader for both cases */
1191 /* $attr->get_value($self), will vivify lazy values if needed
1192 * returns an alias to the sv that is copied in the reader/writer/accessor code
1194 STATIC SV *attr_get_value(pTHX_ SV *self, ATTR *attr) {
1195 SV *value = get_slot_lvalue(aTHX_ self, attr);
1198 return sv_mortalcopy(value);
1199 } else if ( ATTR_ISLAZY(attr) ) {
1200 value = get_default(aTHX_ self, attr);
1201 attr_set_initial_value(aTHX_ self, attr, value);
1208 STATIC void call_trigger (pTHX_ SV *self, ATTR *attr, SV *value) {
1215 /* FIXME copy self & meta attr? */
1217 XPUSHs(sv_2mortal(newSVsv(value)));
1218 XPUSHs(attr->meta_attr);
1220 /* we invoke the builder as a stringified method. This will not work for
1221 * $obj->$coderef etc, for that we need to use 'default' */
1223 call_sv((SV *)attr->trigger, G_VOID);
1229 /* $attr->set_value($self) */
1230 STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value) {
1231 attr_set_common(aTHX_ self, attr, value);
1233 if ( ATTR_HAS_TRIGGER(attr) ) {
1234 call_trigger(aTHX_ self, attr, value);
1238 STATIC bool attr_has_value(pTHX_ SV *self, ATTR *attr) {
1239 return has_slot_value(aTHX_ self, attr);
1242 STATIC SV *attr_clear_value(pTHX_ SV *self, ATTR *attr) {
1243 return deinitialize_slot(aTHX_ self, attr);
1246 STATIC void initialize_instance_slot(pTHX_ SV *self, ATTR *attr, HV *params) {
1250 if ( ATTR_HAS_INIT_ARG(attr) ) {
1251 if ((he = hv_fetch_ent(params, attr->init_arg_sv, 0, attr->init_arg_u32)))
1255 if ( !value && ATTR_DEFAULT(attr) && !ATTR_ISLAZY(attr) ) {
1256 value = get_default(aTHX_ self, attr);
1260 attr_set_initial_value(aTHX_ self, attr, value);
1264 STATIC SV *class_new_object(pTHX_ MI *mi, HV *params) {
1267 SV *self = create_instance(aTHX_ mi);
1269 for ( i = 0; i < mi->num_attrs; i++ ) {
1270 ATTR *attr = &mi->attrs[i];
1271 initialize_instance_slot(aTHX_ self, attr, params);
1278 /* Perl-space level functionality
1280 * These subs are installed by new_sub's various aliases as the bodies of the
1286 /* generate a new attribute method */
1287 STATIC CV *new_method (pTHX_ SV *attr, XSPROTO(body), char *name) {
1288 CV *cv = newXS(name, body, __FILE__);
1293 /* associate CV with meta attr */
1294 stash_in_mg(aTHX_ (SV *)cv, attr);
1296 /* this will be set on first call */
1297 XSANY.any_ptr = NULL;
1315 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
1319 value = attr_get_value(aTHX_ ST(0), attr);
1338 Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
1342 attr_set_value(aTHX_ ST(0), attr, ST(1));
1344 ST(0) = ST(1); /* return value */
1357 Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
1362 attr_set_value(aTHX_ ST(0), attr, ST(1));
1363 ST(0) = ST(1); /* return value */
1365 SV *value = attr_get_value(aTHX_ ST(0), attr);
1376 STATIC XS(predicate)
1385 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
1389 if ( attr_has_value(aTHX_ ST(0), attr) )
1404 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
1408 attr_clear_value(aTHX_ ST(0), attr);
1413 STATIC HV *buildargs (pTHX_ SV **args, I32 items) {
1416 if ( SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV )
1417 return (HV *)SvRV(sv);
1419 croak("Single argument must be hash ref"); /* FIXME copy the same error */
1420 } else if ( items % 2 == 0 ) { /* kvp + self */
1422 HV* const hv = newHV();
1423 sv_2mortal((SV *)hv);
1425 while ( i < (items-1) ) {
1426 SV * const key = args[i++];
1427 SV * const val = args[i++];
1428 SvREFCNT_inc_simple_void(val);
1429 (void)hv_store_ent(hv,key,val,0);
1434 croak("even sized list expected, got %d", items); /* FIXME copy the same error */
1438 STATIC XS(new_object)
1448 Perl_croak(aTHX_ "Usage: %s(%s, ...)", GvNAME(CvGV(cv)), "self");
1452 params = buildargs(aTHX_ (SP+2), items-1);
1454 ST(0) = class_new_object(aTHX_ mi, params);
1469 Perl_croak(aTHX_ "Usage: %s(%s, ...)", GvNAME(CvGV(cv)), "self");
1471 /* chec gv_stashsv of ST(0)
1472 * call buildargs if MI says to
1473 * then call class_new_object
1474 * call array of build methods (either BUILDs or BUILDALLs)
1479 ST(0) = class_new_object(aTHX_ mi, params);
1490 xs_body_initializer,
1497 STATIC XSPROTO ((*xs_bodies[])) = {
1509 MODULE = Moose PACKAGE = Moose::XS
1513 new_method(meta, name)
1519 char *pv = SvOK(name) ? SvPV_nolen(name) : NULL;
1521 new_reader = xs_body_reader
1522 new_writer = xs_body_writer
1523 new_accessor = xs_body_accessor
1524 new_predicate = xs_body_predicate
1525 new_initializer = xs_body_initializer
1526 new_clearer = xs_body_clearer
1527 new_new_object = xs_body_new_object
1528 new_new = xs_body_new
1530 if ( ix >= max_xs_body )
1531 croak("Unknown Moose::XS body type");
1533 if ( !sv_isobject(meta) )
1534 croak("'meta' must be an object");
1536 RETVAL = new_method(aTHX_ meta, xs_bodies[ix], pv);
1541 MODULE = Moose PACKAGE = Moose::XS::Meta::Instance
1549 MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
1552 delete_mi(aTHX_ mi);
1555 MODULE = Moose PACKAGE = Moose::XS::TypeConstraints
1577 ScalarRef = ScalarRef
1578 FileHandle = FileHandle
1579 RegexpRef = RegexpRef
1582 ClassName = ClassName
1584 RETVAL = check_sv_type(ix, sv);
1589 ObjectOfType(sv, class)
1594 HV *stash = gv_stashsv(class, 0);
1596 RETVAL = check_sv_class(aTHX_ stash, sv);