Commit | Line | Data |
1ea12c91 |
1 | #include "EXTERN.h" |
2 | #include "perl.h" |
3 | #include "XSUB.h" |
4 | |
d0957eef |
5 | #define NEED_grok_number |
6 | #define NEED_grok_numeric_radix |
035fd0c4 |
7 | #define NEED_newRV_noinc |
8 | #define NEED_newSVpvn_share |
9 | #define NEED_sv_2pv_flags |
10 | #include "ppport.h" |
11 | |
12 | #ifndef XSPROTO |
13 | #define XSPROTO(name) void name(pTHX_ CV* cv) |
14 | #endif |
15 | |
16 | #ifndef gv_stashpvs |
70a91f79 |
17 | #define gv_stashpvs(x, y) Perl_gv_stashpvn(aTHX_ STR_WITH_LEN(x), y) |
035fd0c4 |
18 | #endif |
19 | |
1ea12c91 |
20 | /* FIXME |
1ea12c91 |
21 | * delegations and attribute helpers: |
22 | * |
23 | * typedef struct { |
de2f2e97 |
24 | * ATTR *attr; |
1ea12c91 |
25 | * pv *method; |
26 | * } delegation; |
27 | * |
28 | * typedef struct { |
de2f2e97 |
29 | * ATTR *attr; |
1ea12c91 |
30 | * I32 *type; // hash, array, whatever + vtable for operation |
31 | * } attributehelper; |
32 | */ |
33 | |
de2f2e97 |
34 | |
2cd9d2ba |
35 | |
36 | |
37 | |
38 | |
2cd9d2ba |
39 | /* These two functions attach magic with no behavior to an SV. |
40 | * |
41 | * The stashed value is reference counted, and is destroyed when it's parent |
42 | * object is destroyed. |
43 | * |
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 |
46 | * instance. |
47 | */ |
48 | |
de2f2e97 |
49 | STATIC MGVTBL null_mg_vtbl = { |
50 | NULL, /* get */ |
51 | NULL, /* set */ |
52 | NULL, /* len */ |
53 | NULL, /* clear */ |
54 | NULL, /* free */ |
55 | #if MGf_COPY |
56 | NULL, /* copy */ |
57 | #endif /* MGf_COPY */ |
58 | #if MGf_DUP |
59 | NULL, /* dup */ |
60 | #endif /* MGf_DUP */ |
61 | #if MGf_LOCAL |
62 | NULL, /* local */ |
63 | #endif /* MGf_LOCAL */ |
64 | }; |
65 | |
f253044f |
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; |
69 | |
70 | return mg; |
71 | } |
72 | |
73 | STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) { |
85ddc685 |
74 | MAGIC *mg; |
f253044f |
75 | |
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)) |
79 | break; |
80 | } |
81 | if (mg) |
82 | return mg->mg_obj; |
83 | } |
84 | |
85 | return NULL; |
86 | } |
de2f2e97 |
87 | |
2cd9d2ba |
88 | |
89 | |
90 | |
91 | |
92 | |
93 | |
94 | |
95 | |
96 | /* The folloing data structures deal with type constraints */ |
97 | |
98 | /* this is an enum of the various kinds of constraint checking an attribute can |
99 | * have. |
100 | * |
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. */ |
104 | |
105 | typedef enum { |
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 */ |
5b264806 |
111 | tc_enum /* TODO check that the value is in an allowed set of values (strings) */ |
2cd9d2ba |
112 | } tc_kind; |
113 | |
114 | /* this is a enum of builtin type check. They are handled in a switch statement |
115 | * in check_sv_type */ |
de2f2e97 |
116 | typedef enum { |
4c6fbfb1 |
117 | Any, /* or item, or bool */ |
118 | Undef, |
119 | Defined, |
120 | Str, /* or value */ |
121 | Num, |
122 | Int, |
123 | GlobRef, /* SVt_PVGV */ |
124 | ArrayRef, /* SVt_PVAV */ |
125 | HashRef, /* SVt_PVHV */ |
126 | CodeRef, /* SVt_PVCV */ |
127 | Ref, |
128 | ScalarRef, |
2cd9d2ba |
129 | FileHandle, /* TODO */ |
4c6fbfb1 |
130 | RegexpRef, |
131 | Object, |
2cd9d2ba |
132 | Role, /* TODO */ |
5b264806 |
133 | ClassName |
de2f2e97 |
134 | } TC; |
135 | |
2cd9d2ba |
136 | /* auxillary pointer/int union used for constraint checking */ |
de2f2e97 |
137 | typedef union { |
2cd9d2ba |
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? */ |
4c6fbfb1 |
142 | } TC_CHECK; |
143 | |
2cd9d2ba |
144 | |
145 | |
146 | |
147 | |
148 | |
149 | /* The folloing data structures deal with type default value generation */ |
150 | |
151 | /* This is an enum for the various types of default value behaviors an |
152 | * attribute can have */ |
de2f2e97 |
153 | |
154 | typedef enum { |
2cd9d2ba |
155 | default_none = 0, /* no default value */ |
156 | default_normal, /* code reference or scalar */ |
157 | default_builder, /* builder method */ |
5b264806 |
158 | default_type /* TODO enumerated type optimization (will call newHV, newAV etc to avoid calling a code ref for these simple cases) */ |
de2f2e97 |
159 | } default_kind; |
160 | |
2cd9d2ba |
161 | typedef union { |
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 */ |
164 | } DEFAULT; |
165 | |
166 | |
167 | |
168 | |
169 | |
170 | |
171 | /* the ATTR struct contains all the meta data for a Moose::Meta::Attribute for |
172 | * a given meta instance |
173 | * |
174 | * flags determines the various behaviors |
175 | * |
176 | * This supports only one slot per attribute in the current implementation, but |
177 | * slot_sv could contain an array |
178 | * |
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 |
182 | * */ |
183 | |
1ea12c91 |
184 | typedef struct { |
2cd9d2ba |
185 | /* pointer to the MI this attribute is a part of the meta instance struct */ |
de2f2e97 |
186 | struct mi *mi; |
187 | |
188 | U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */ |
189 | |
190 | /* slot access fields */ |
2cd9d2ba |
191 | SV *slot_sv; /* value of the slot (currently always slot name) */ |
192 | U32 slot_u32; /* for optimized access (precomputed hash, possibly something else) */ |
de2f2e97 |
193 | |
f55aeea0 |
194 | SV *init_arg_sv; |
195 | U32 init_arg_u32; |
196 | |
de2f2e97 |
197 | DEFAULT def; /* cv, value or other, depending on flags */ |
198 | |
2cd9d2ba |
199 | TC_CHECK tc_check; /* see TC_CHECK*/ |
200 | SV *type_constraint; /* Moose::Meta::TypeConstraint object */ |
de2f2e97 |
201 | |
a0c236f1 |
202 | CV *trigger; |
203 | CV *initializer; |
81c77c45 |
204 | SV *writer; /* used by the initializer */ |
de2f2e97 |
205 | |
2cd9d2ba |
206 | SV *meta_attr; /* the Moose::Meta::Attribute */ |
207 | AV *cvs; /* an array of CVs which use this attr, see delete_mi */ |
de2f2e97 |
208 | } ATTR; |
209 | |
2cd9d2ba |
210 | /* the flags integer is mapped as follows |
211 | * instance misc reading writing |
de2f2e97 |
212 | * 00000000 00000000 00000000 00000000 |
2cd9d2ba |
213 | * writing |
7ce1a351 |
214 | * ^ trigger |
215 | * ^ weak |
45922f54 |
216 | * ^ tc.sv is refcounted |
de2f2e97 |
217 | * ^^^ tc_kind |
218 | * ^ coerce |
2cd9d2ba |
219 | * |
220 | * reading |
de2f2e97 |
221 | * ^^^ default_kind |
222 | * ^ lazy |
45922f54 |
223 | * ^ def.sv is refcounted |
2cd9d2ba |
224 | * |
225 | * misc |
226 | * ^ attr is required TODO |
227 | * |
228 | * flags having to do with the instance layout (TODO, only hash supported for now) |
de2f2e97 |
229 | * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD |
230 | */ |
231 | |
232 | #define ATTR_INSTANCE_MASK 0xff000000 |
233 | #define ATTR_READING_MASK 0x0000ff00 |
234 | #define ATTR_WRITING_MASK 0x000000ff |
235 | |
236 | #define ATTR_MASK_TYPE 0x7 |
237 | |
238 | #define ATTR_MASK_DEFAULT 0x700 |
fe0194bf |
239 | #define ATTR_SHIFT_DEFAULT 8 |
de2f2e97 |
240 | |
241 | #define ATTR_LAZY 0x800 |
fe0194bf |
242 | #define ATTR_DEFREFCNT 0x1000 |
de2f2e97 |
243 | |
7ce1a351 |
244 | #define ATTR_COERCE 0x8 |
245 | #define ATTR_TCREFCNT 0x10 |
246 | #define ATTR_WEAK 0x20 |
247 | #define ATTR_TRIGGER 0x40 |
de2f2e97 |
248 | |
bdc8e3ec |
249 | #define ATTR_REQUIRED 0x10000 |
250 | #define ATTR_INIT_ARG 0x20000 |
251 | #define ATTR_INITIALIZER 0x40000 |
252 | |
de2f2e97 |
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 ) |
bdc8e3ec |
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 ) |
259 | |
260 | #define ATTR_IS_REQUIRED(Attr) ( attr->flags & ATTR_REQUIRED ) |
1ea12c91 |
261 | |
de2f2e97 |
262 | #define ATTR_TYPE(f) ( attr->flags & 0x7 ) |
263 | #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT ) |
1ea12c91 |
264 | |
de2f2e97 |
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 ) |
1ea12c91 |
268 | |
de2f2e97 |
269 | |
270 | |
2cd9d2ba |
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. |
274 | * |
275 | * We'll need to define a default instance of this vtable that uses call_sv, |
276 | * too. */ |
277 | |
278 | /* FIXME define a vtable that does call_sv for fallback meta instance protocol */ |
de2f2e97 |
279 | typedef struct { |
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); |
284 | } instance_vtbl; |
285 | |
2cd9d2ba |
286 | /* TODO this table describes the instance layout of the object. Not yet |
287 | * implemented */ |
de2f2e97 |
288 | typedef enum { |
289 | hash = 0, |
290 | |
291 | /* these are not yet implemented */ |
292 | array, |
293 | fptr, |
294 | cv, |
5b264806 |
295 | judy |
de2f2e97 |
296 | } instance_types; |
297 | |
2cd9d2ba |
298 | |
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 |
302 | * |
303 | * |
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. |
308 | * |
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 */ |
de2f2e97 |
314 | typedef struct mi { |
de2f2e97 |
315 | HV *stash; |
316 | |
317 | /* slot access method */ |
2cd9d2ba |
318 | instance_types type; /* TODO only hashes supported currently */ |
319 | instance_vtbl *vtbl; /* TODO */ |
de2f2e97 |
320 | |
321 | /* attr descriptors */ |
322 | I32 num_attrs; |
323 | ATTR *attrs; |
b2dbd503 |
324 | |
325 | /* dependent methods */ |
326 | AV *cvs; |
de2f2e97 |
327 | } MI; |
328 | |
329 | |
4c6fbfb1 |
330 | |
331 | |
81c77c45 |
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); |
338 | |
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); |
346 | |
347 | |
348 | /* Moose::Meta::Attribute level API (XSUBs) */ |
b2dbd503 |
349 | STATIC CV *new_method (pTHX_ SV *attr, XSPROTO(body), char *name); |
81c77c45 |
350 | STATIC XS(initializer); /* only used by attr_set_initial_value */ |
351 | STATIC XS(reader); |
352 | STATIC XS(writer); |
353 | STATIC XS(accessor); |
354 | STATIC XS(predicate); |
355 | STATIC XS(clearer); |
356 | STATIC XS(new_object); |
357 | |
358 | STATIC ATTR *define_attr(pTHX_ CV *cv); |
b2dbd503 |
359 | STATIC MI *define_mi(pTHX_ CV *cv); |
81c77c45 |
360 | |
361 | |
362 | /* This macro is used in the XS subs to set up the 'attr' variable. |
363 | * |
364 | * if XSANY is NULL then define_attr is called on the CV, to set the pointer |
365 | * to the ATTR struct. |
366 | * */ |
5a022b97 |
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)) |
81c77c45 |
369 | |
2cd9d2ba |
370 | |
371 | |
372 | |
373 | |
374 | /* these functions implement type constraint checking */ |
375 | |
376 | /* checks that the SV is a scalar ref */ |
4c6fbfb1 |
377 | STATIC bool check_is_scalar_ref(SV *sv) { |
bdc8e3ec |
378 | if ( SvROK(sv) ) { |
4c6fbfb1 |
379 | switch (SvTYPE(SvRV(sv))) { |
380 | case SVt_IV: |
381 | case SVt_NV: |
382 | case SVt_PV: |
383 | case SVt_NULL: |
384 | return 1; |
385 | break; |
386 | default: |
387 | return 0; |
388 | } |
389 | } |
390 | return 0; |
391 | } |
392 | |
2cd9d2ba |
393 | /* checks that the SV is a ref to a certain SvTYPE, where type is in the table |
394 | * above */ |
4c6fbfb1 |
395 | STATIC bool check_reftype(TC type, SV *sv) { |
396 | int svt; |
397 | |
398 | if ( !SvROK(sv) ) |
399 | return 0; |
400 | |
401 | switch (type) { |
402 | case GlobRef: |
403 | svt = SVt_PVGV; |
404 | break; |
405 | case ArrayRef: |
406 | svt = SVt_PVAV; |
407 | break; |
408 | case HashRef: |
409 | svt = SVt_PVHV; |
410 | break; |
411 | case CodeRef: |
412 | svt = SVt_PVCV; |
413 | break; |
85ddc685 |
414 | default: |
415 | croak("not a reftype %d\n", type); |
4c6fbfb1 |
416 | } |
417 | |
160f9ca7 |
418 | return SvTYPE(SvRV(sv)) == svt; |
4c6fbfb1 |
419 | } |
420 | |
2cd9d2ba |
421 | /* checks whether an SV is of a certain class |
422 | * SvSTASH is first compared by pointer for efficiency */ |
7ce1a351 |
423 | STATIC bool check_sv_class(pTHX_ HV *stash, SV *sv) { |
4c6fbfb1 |
424 | dSP; |
425 | bool ret; |
7ce1a351 |
426 | SV *rv; |
4c6fbfb1 |
427 | |
428 | if (!sv) |
429 | return 0; |
430 | SvGETMAGIC(sv); |
431 | if (!SvROK(sv)) |
432 | return 0; |
7ce1a351 |
433 | rv = (SV*)SvRV(sv); |
434 | if (!SvOBJECT(rv)) |
4c6fbfb1 |
435 | return 0; |
7ce1a351 |
436 | if (SvSTASH(rv) == stash) |
4c6fbfb1 |
437 | return 1; |
438 | |
439 | ENTER; |
440 | SAVETMPS; |
441 | PUSHMARK(SP); |
442 | XPUSHs(sv); |
7ce1a351 |
443 | XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0))); |
4c6fbfb1 |
444 | PUTBACK; |
445 | |
446 | call_method("isa", G_SCALAR); |
447 | |
448 | SPAGAIN; |
449 | ret = SvTRUE(TOPs); |
450 | |
451 | FREETMPS; |
452 | LEAVE; |
453 | |
454 | return ret; |
455 | } |
456 | |
2cd9d2ba |
457 | /* checks whether SV of of a known simple type. Most of the non parametrized |
458 | * Moose core types are implemented here */ |
4c6fbfb1 |
459 | STATIC bool check_sv_type (TC type, SV *sv) { |
460 | if (!sv) |
461 | return 0; |
160f9ca7 |
462 | |
8a73f796 |
463 | SvGETMAGIC(sv); |
464 | |
4c6fbfb1 |
465 | switch (type) { |
466 | case Any: |
467 | return 1; |
468 | break; |
469 | case Undef: |
470 | return !SvOK(sv); |
471 | break; |
472 | case Defined: |
473 | return SvOK(sv); |
474 | break; |
475 | case Str: |
476 | return (SvOK(sv) && !SvROK(sv)); |
160f9ca7 |
477 | case Num: |
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); |
481 | else |
482 | #endif |
483 | return looks_like_number(sv); |
484 | break; |
485 | case Int: |
486 | if ( SvIOK(sv) ) { |
487 | return 1; |
488 | } else if ( SvPOK(sv) ) { |
160f9ca7 |
489 | STRLEN len; |
490 | char *pv = SvPV(sv, len); |
4d0ab1b9 |
491 | int flags = grok_number(pv, len, NULL); |
492 | return ( flags && !(flags & IS_NUMBER_NOT_INT) ); |
160f9ca7 |
493 | } |
494 | return 0; |
495 | break; |
4c6fbfb1 |
496 | case Ref: |
497 | return SvROK(sv); |
498 | break; |
499 | case ScalarRef: |
500 | return check_is_scalar_ref(sv); |
501 | break; |
502 | case ArrayRef: |
503 | case HashRef: |
504 | case CodeRef: |
505 | case GlobRef: |
506 | return check_reftype(type, sv); |
507 | break; |
3c63e75d |
508 | case RegexpRef: |
4c6fbfb1 |
509 | case Object: |
8a73f796 |
510 | /* not using sv_isobject to avoid repeated get magic */ |
511 | if ( SvROK(sv) ) { |
512 | SV *rv = SvRV(sv); |
513 | if ( SvOBJECT(rv) ) { |
514 | char *name = HvNAME_get(SvSTASH(SvRV(sv))); |
db87359d |
515 | if ( name ) { |
516 | bool is_regexp = strEQ("Regexp", name); |
517 | return ( (type == RegexpRef) ^ !is_regexp ); |
518 | } |
8a73f796 |
519 | } |
9fad6c09 |
520 | } |
521 | return 0; |
4c6fbfb1 |
522 | break; |
160f9ca7 |
523 | case ClassName: |
7ce1a351 |
524 | if ( SvOK(sv) && !SvROK(sv) ) { |
160f9ca7 |
525 | STRLEN len; |
526 | char *pv; |
527 | pv = SvPV(sv, len); |
528 | return ( gv_stashpvn(pv, len, 0) != NULL ); |
160f9ca7 |
529 | } |
7ce1a351 |
530 | return 0; |
531 | break; |
4c6fbfb1 |
532 | case FileHandle: |
533 | croak("todo"); |
534 | break; |
535 | default: |
536 | croak("todo"); |
537 | } |
538 | |
539 | return 0; |
540 | } |
541 | |
2cd9d2ba |
542 | /* invoke a CV on an SV and return SvTRUE of the result */ |
45922f54 |
543 | STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) { |
fb4ccd5a |
544 | SV *ret_sv; |
45922f54 |
545 | bool ret; |
546 | dSP; |
547 | |
548 | ENTER; |
549 | SAVETMPS; |
550 | PUSHMARK(SP); |
551 | XPUSHs(sv); |
552 | PUTBACK; |
553 | |
554 | call_sv(cv, G_SCALAR); |
555 | |
556 | SPAGAIN; |
fb4ccd5a |
557 | ret_sv = POPs; |
558 | ret = SvTRUE(ret_sv); |
45922f54 |
559 | |
560 | PUTBACK; |
561 | FREETMPS; |
562 | LEAVE; |
563 | |
564 | return ret; |
565 | } |
566 | |
2cd9d2ba |
567 | /* checks the type constraint for an SV based on the type constraint kind */ |
160f9ca7 |
568 | STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) { |
4c6fbfb1 |
569 | switch (kind) { |
570 | case tc_none: |
571 | return 1; |
572 | break; |
573 | case tc_type: |
574 | return check_sv_type(tc_check.type, sv); |
575 | break; |
576 | case tc_stash: |
7ce1a351 |
577 | return check_sv_class(aTHX_ (HV *)tc_check.sv, sv); |
4c6fbfb1 |
578 | break; |
4c6fbfb1 |
579 | case tc_fptr: |
580 | return tc_check.fptr(aTHX_ type_constraint, sv); |
581 | break; |
582 | case tc_cv: |
45922f54 |
583 | return check_sv_cv(aTHX_ tc_check.sv, sv); |
584 | break; |
85ddc685 |
585 | case tc_enum: |
586 | croak("todo\n"); |
587 | break; |
4c6fbfb1 |
588 | } |
589 | |
590 | croak("todo"); |
591 | return 0; |
592 | } |
593 | |
594 | |
2cd9d2ba |
595 | /* end of type constraint checking functions */ |
596 | |
597 | |
598 | |
599 | |
600 | |
601 | |
602 | |
603 | |
604 | |
605 | /* Initialize the ATTR structure using positional arguments from Perl space. */ |
606 | |
160f9ca7 |
607 | STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) { |
608 | U32 flags = 0; |
f55aeea0 |
609 | U32 slot_hash, init_arg_hash; |
610 | STRLEN slot_len, init_arg_len; |
611 | char *slot_pv, *init_arg_pv; |
160f9ca7 |
612 | I32 ix = av_len(desc); |
613 | SV **params = AvARRAY(desc); |
614 | SV *tc; |
f55aeea0 |
615 | SV *slot_sv; |
616 | SV *init_arg_sv; |
de2f2e97 |
617 | |
618 | attr->mi = mi; |
619 | |
f55aeea0 |
620 | if ( ix != 13 ) |
9fad6c09 |
621 | croak("wrong number of args (%d != 14)", (int)ix + 1); |
de2f2e97 |
622 | |
160f9ca7 |
623 | for ( ; ix >= 0; ix-- ) { |
624 | if ( !params[ix] || params[ix] == &PL_sv_undef ) |
625 | croak("bad params"); |
626 | } |
627 | |
2cd9d2ba |
628 | |
629 | |
630 | /* handle attribute slot array */ |
631 | |
160f9ca7 |
632 | if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV ) |
633 | croak("slots is not an array"); |
de2f2e97 |
634 | |
160f9ca7 |
635 | if ( av_len((AV *)SvRV(params[1])) != 0 ) |
636 | croak("Only unary slots are supported at the moment"); |
1ea12c91 |
637 | |
160f9ca7 |
638 | /* calculate a hash from the slot */ |
639 | /* FIXME arrays etc should also be supported */ |
f55aeea0 |
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); |
1ea12c91 |
643 | |
de2f2e97 |
644 | |
f55aeea0 |
645 | init_arg_sv = params[13]; |
b2dbd503 |
646 | if ( SvOK(init_arg_sv) ) { |
bdc8e3ec |
647 | flags |= ATTR_INIT_ARG; |
b2dbd503 |
648 | init_arg_pv = SvPV(init_arg_sv, init_arg_len); |
649 | PERL_HASH(init_arg_hash, init_arg_pv, init_arg_len); |
650 | } |
2cd9d2ba |
651 | |
652 | |
653 | /* FIXME better organize these, positionals suck */ |
160f9ca7 |
654 | if ( SvTRUE(params[2]) ) |
655 | flags |= ATTR_WEAK; |
656 | |
657 | if ( SvTRUE(params[3]) ) |
658 | flags |= ATTR_COERCE; |
de2f2e97 |
659 | |
160f9ca7 |
660 | if ( SvTRUE(params[4]) ) |
661 | flags |= ATTR_LAZY; |
de2f2e97 |
662 | |
2cd9d2ba |
663 | |
664 | |
665 | /* type constraint data */ |
666 | |
160f9ca7 |
667 | tc = params[5]; |
de2f2e97 |
668 | |
160f9ca7 |
669 | if ( SvOK(tc) ) { |
670 | int tc_kind = SvIV(params[6]); |
671 | SV *data = params[7]; |
672 | |
673 | switch (tc_kind) { |
160f9ca7 |
674 | case tc_type: |
675 | attr->tc_check.type = SvIV(data); |
676 | break; |
7ce1a351 |
677 | case tc_stash: |
678 | flags |= ATTR_TCREFCNT; |
679 | attr->tc_check.sv = (SV *)gv_stashsv(data, 0); |
680 | break; |
160f9ca7 |
681 | case tc_cv: |
7ce1a351 |
682 | flags |= ATTR_TCREFCNT; |
683 | attr->tc_check.sv = SvRV(data); |
684 | if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV ) |
160f9ca7 |
685 | croak("compiled type constraint is not a coderef"); |
686 | break; |
687 | default: |
688 | croak("todo"); |
689 | } |
690 | |
691 | flags |= tc_kind; |
692 | } |
693 | |
2cd9d2ba |
694 | |
695 | |
696 | /* default/builder data */ |
fe0194bf |
697 | |
698 | if ( SvTRUE(params[10]) ) { /* has default */ |
699 | SV *sv = params[11]; |
700 | |
701 | if ( SvROK(sv) ) { |
702 | attr->def.sv = SvRV(sv); |
703 | if ( SvTYPE(attr->def.sv) != SVt_PVCV ) |
704 | croak("compiled type constraint is not a coderef"); |
705 | } else { |
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 */ |
708 | } |
709 | |
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 ) ); |
714 | } |
715 | |
2cd9d2ba |
716 | |
160f9ca7 |
717 | |
d08b3299 |
718 | attr->trigger = SvROK(params[8]) ? (CV *)SvRV(params[8]) : NULL; |
160f9ca7 |
719 | if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV ) |
720 | croak("trigger is not a coderef"); |
721 | |
bdc8e3ec |
722 | if ( attr->trigger ) flags |= ATTR_TRIGGER; |
723 | |
d08b3299 |
724 | attr->initializer = SvROK(params[9]) ? (CV *)SvRV(params[9]) : NULL; |
160f9ca7 |
725 | if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV ) |
726 | croak("initializer is not a coderef"); |
727 | |
bdc8e3ec |
728 | if ( attr->initializer ) flags |= ATTR_INITIALIZER; |
729 | |
2cd9d2ba |
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 |
732 | * array */ |
733 | |
734 | attr->flags = flags; |
735 | |
736 | /* copy the outer ref SV */ |
160f9ca7 |
737 | attr->meta_attr = newSVsv(params[0]); |
738 | attr->type_constraint = newSVsv(tc); |
2cd9d2ba |
739 | |
740 | /* increase the refcount for auxillary structures */ |
da6328c3 |
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); |
160f9ca7 |
745 | |
f55aeea0 |
746 | attr->slot_sv = newSVpvn_share(slot_pv, slot_len, slot_hash); |
747 | attr->slot_u32 = slot_hash; |
748 | |
749 | attr->init_arg_sv = newSVpvn_share(init_arg_pv, init_arg_len, init_arg_hash); |
750 | attr->init_arg_u32 = init_arg_hash; |
160f9ca7 |
751 | |
de2f2e97 |
752 | /* cross refs to CVs which use this struct */ |
753 | attr->cvs = newAV(); |
754 | } |
755 | |
2cd9d2ba |
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)); |
de2f2e97 |
760 | MI *mi; |
2cd9d2ba |
761 | const I32 num_attrs = av_len(attrs) + 1; |
de2f2e97 |
762 | |
687453c6 |
763 | Newxz(mi, 1, MI); |
2cd9d2ba |
764 | |
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)); |
768 | |
687453c6 |
769 | Newxz(mi->attrs, num_attrs, ATTR); |
2cd9d2ba |
770 | |
da6328c3 |
771 | SvREFCNT_inc_simple_void_NN(stash); |
de2f2e97 |
772 | mi->stash = stash; |
773 | |
de2f2e97 |
774 | mi->type = 0; /* nothing else implemented yet */ |
775 | |
776 | /* initialize attributes */ |
a0c236f1 |
777 | for ( mi->num_attrs = 0; mi->num_attrs < num_attrs; mi->num_attrs++ ) { |
2cd9d2ba |
778 | SV **desc = av_fetch(attrs, mi->num_attrs, 0); |
de2f2e97 |
779 | |
160f9ca7 |
780 | if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) { |
de2f2e97 |
781 | croak("Attribute descriptor has to be a hash reference"); |
f253044f |
782 | } |
de2f2e97 |
783 | |
2cd9d2ba |
784 | init_attr(mi, &mi->attrs[mi->num_attrs], (AV *)SvRV(*desc)); |
de2f2e97 |
785 | } |
786 | |
b2dbd503 |
787 | mi->cvs = newAV(); |
788 | |
2cd9d2ba |
789 | return obj; |
790 | } |
791 | |
b2dbd503 |
792 | STATIC void clear_cvs (AV *av) { |
793 | SV **cvs = AvARRAY(av); |
794 | I32 i = av_len(av); |
2cd9d2ba |
795 | |
b2dbd503 |
796 | /* remove the pointers from all the the dependent CVs */ |
797 | while ( i >= 0 ) { |
798 | CV *cv = (CV *)cvs[i--]; |
5a022b97 |
799 | XSANY.any_ptr = NULL; |
2cd9d2ba |
800 | } |
801 | |
b2dbd503 |
802 | SvREFCNT_dec(av); |
803 | } |
804 | |
805 | STATIC void delete_attr (pTHX_ ATTR *attr) { |
806 | |
807 | clear_cvs(attr->cvs); |
808 | |
2cd9d2ba |
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); |
2cd9d2ba |
813 | SvREFCNT_dec(attr->trigger); |
a0c236f1 |
814 | SvREFCNT_dec(attr->initializer); |
815 | SvREFCNT_dec(attr->writer); |
2cd9d2ba |
816 | SvREFCNT_dec(attr->meta_attr); |
de2f2e97 |
817 | } |
818 | |
7ce1a351 |
819 | STATIC void delete_mi (pTHX_ MI *mi) { |
2cd9d2ba |
820 | SvREFCNT_dec(mi->stash); |
7ce1a351 |
821 | |
2cd9d2ba |
822 | while ( mi->num_attrs--) { |
823 | ATTR *attr = &mi->attrs[mi->num_attrs]; |
824 | delete_attr(aTHX_ attr); |
7ce1a351 |
825 | } |
826 | |
2cd9d2ba |
827 | if ( mi->attrs ) Safefree(mi->attrs); |
b2dbd503 |
828 | |
829 | if ( mi->cvs ) { |
830 | clear_cvs(mi->cvs); |
831 | } |
832 | |
7ce1a351 |
833 | Safefree(mi); |
834 | } |
835 | |
de2f2e97 |
836 | |
2cd9d2ba |
837 | |
838 | |
839 | /* these functions call Perl-space for MOP methods, helpers etc */ |
840 | |
841 | |
842 | /* wow, so much code for the equivalent of |
843 | * $attr->associated_class->get_meta_instance */ |
f253044f |
844 | STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) { |
845 | dSP; |
f253044f |
846 | SV *mi; |
847 | |
848 | if ( !meta_attr ) |
849 | croak("No attr found in magic!"); |
850 | |
851 | ENTER; |
852 | SAVETMPS; |
853 | PUSHMARK(SP); |
2cd9d2ba |
854 | |
f253044f |
855 | XPUSHs(meta_attr); |
2cd9d2ba |
856 | |
f253044f |
857 | PUTBACK; |
4ca2dd5f |
858 | call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR); |
f253044f |
859 | |
860 | SPAGAIN; |
861 | mi = POPs; |
862 | |
da6328c3 |
863 | SvREFCNT_inc_simple_void(mi); |
f253044f |
864 | |
865 | PUTBACK; |
866 | FREETMPS; |
867 | LEAVE; |
868 | |
fe0194bf |
869 | return sv_2mortal(mi); |
f253044f |
870 | } |
871 | |
2cd9d2ba |
872 | /* gets a class and an array of attr parameters */ |
f253044f |
873 | STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) { |
874 | dSP; |
875 | I32 count; |
2cd9d2ba |
876 | SV *mi; |
f253044f |
877 | SV *class; |
878 | SV *attrs; |
879 | HV *stash; |
880 | |
881 | ENTER; |
882 | SAVETMPS; |
883 | PUSHMARK(SP); |
2cd9d2ba |
884 | |
f253044f |
885 | XPUSHs(perl_mi); |
2cd9d2ba |
886 | |
f253044f |
887 | PUTBACK; |
888 | count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY); |
889 | |
890 | if ( count != 2 ) |
9fad6c09 |
891 | croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", (int)count); |
f253044f |
892 | |
893 | SPAGAIN; |
894 | attrs = POPs; |
895 | class = POPs; |
896 | |
897 | PUTBACK; |
898 | |
899 | stash = gv_stashsv(class, 0); |
900 | |
901 | mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs)); |
da6328c3 |
902 | SvREFCNT_inc_simple_void_NN(mi); |
f253044f |
903 | |
904 | FREETMPS; |
905 | LEAVE; |
906 | |
2cd9d2ba |
907 | return sv_2mortal(mi); |
f253044f |
908 | } |
909 | |
2cd9d2ba |
910 | |
911 | |
912 | /* locate an ATTR for a MOP level attribute inside an MI */ |
b2dbd503 |
913 | STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) { |
f253044f |
914 | I32 ix; |
915 | |
035fd0c4 |
916 | for ( ix = 0; ix < mi->num_attrs; ix++ ) { |
f253044f |
917 | if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) { |
918 | return &mi->attrs[ix]; |
de2f2e97 |
919 | } |
de2f2e97 |
920 | } |
921 | |
9fad6c09 |
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) ); |
de2f2e97 |
923 | return NULL; |
924 | } |
925 | |
2cd9d2ba |
926 | /* returns the ATTR for a CV: |
927 | * |
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 |
932 | */ |
b2dbd503 |
933 | STATIC MI *get_or_create_mi(pTHX_ SV *perl_mi) { |
2cd9d2ba |
934 | SV *mi_obj = get_stashed_in_mg(aTHX_ SvRV(perl_mi)); |
de2f2e97 |
935 | |
2cd9d2ba |
936 | if (!mi_obj) { |
937 | mi_obj = perl_mi_to_c_mi(aTHX_ perl_mi); |
938 | stash_in_mg(aTHX_ SvRV(perl_mi), mi_obj); |
f253044f |
939 | } |
940 | |
b2dbd503 |
941 | return INT2PTR(MI *, SvIV(SvRV(mi_obj))); |
942 | } |
943 | |
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); |
949 | } |
950 | |
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)); |
1ea12c91 |
954 | } |
955 | |
2cd9d2ba |
956 | /* Cache a pointer to the appropriate ATTR in the XSANY of the CV, using |
957 | * get_attr */ |
de2f2e97 |
958 | STATIC ATTR *define_attr (pTHX_ CV *cv) { |
959 | ATTR *attr = get_attr(aTHX_ cv); |
960 | assert(attr); |
961 | |
5a022b97 |
962 | XSANY.any_ptr = (void *)attr; |
f253044f |
963 | |
da6328c3 |
964 | SvREFCNT_inc_simple_void(cv); |
f253044f |
965 | av_push( attr->cvs, (SV *)cv ); |
de2f2e97 |
966 | |
967 | return attr; |
968 | } |
969 | |
b2dbd503 |
970 | STATIC MI *define_mi (pTHX_ CV *cv) { |
971 | MI *mi = get_mi(aTHX_ cv); |
972 | assert(mi); |
973 | |
5a022b97 |
974 | XSANY.any_ptr = (void *)mi; |
b2dbd503 |
975 | |
976 | SvREFCNT_inc_simple_void(cv); |
977 | av_push( mi->cvs, (SV *)cv ); |
978 | |
979 | return mi; |
980 | } |
2cd9d2ba |
981 | |
982 | |
983 | |
984 | |
985 | |
986 | |
de2f2e97 |
987 | STATIC void weaken(pTHX_ SV *sv) { |
1ea12c91 |
988 | #ifdef SvWEAKREF |
de2f2e97 |
989 | sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */ |
1ea12c91 |
990 | #else |
991 | croak("weak references are not implemented in this release of perl"); |
992 | #endif |
993 | } |
994 | |
995 | |
2cd9d2ba |
996 | |
997 | |
998 | |
999 | |
8ab8cdae |
1000 | /* meta instance protocol |
1001 | * |
1002 | * The slot functions don't change the refcount or copy (aliasing semantics) |
1003 | * |
1004 | * create_instance returns a new mortal */ |
1ea12c91 |
1005 | |
9f3805f7 |
1006 | STATIC SV *get_slot_lvalue(pTHX_ SV *self, ATTR *attr) { |
1ea12c91 |
1007 | HE *he; |
1008 | |
1009 | assert(self); |
1010 | assert(SvROK(self)); |
1011 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
1012 | |
de2f2e97 |
1013 | assert( ATTR_DUMB_INSTANCE(attr) ); |
1014 | |
1015 | if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32))) |
1ea12c91 |
1016 | return HeVAL(he); |
1017 | else |
1018 | return NULL; |
1019 | } |
1020 | |
9f3805f7 |
1021 | STATIC bool set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) { |
1ea12c91 |
1022 | HE *he; |
1023 | |
1024 | assert(self); |
1025 | assert(SvROK(self)); |
1026 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
1027 | |
de2f2e97 |
1028 | assert( ATTR_DUMB_INSTANCE(attr) ); |
1029 | |
9f3805f7 |
1030 | he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, value, attr->slot_u32); |
1ea12c91 |
1031 | |
9f3805f7 |
1032 | return he != NULL; |
1ea12c91 |
1033 | } |
1034 | |
de2f2e97 |
1035 | STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) { |
1ea12c91 |
1036 | assert(self); |
1037 | assert(SvROK(self)); |
1038 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
1039 | |
de2f2e97 |
1040 | assert( ATTR_DUMB_INSTANCE(attr) ); |
1041 | |
1042 | return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32); |
1043 | } |
1044 | |
1045 | STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) { |
1046 | assert(self); |
1047 | assert(SvROK(self)); |
1048 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
1049 | |
1050 | assert( ATTR_DUMB_INSTANCE(attr) ); |
1051 | |
1052 | return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32); |
1ea12c91 |
1053 | } |
1054 | |
af0842cb |
1055 | STATIC SV *create_instance(pTHX_ MI *mi) { |
e315cce6 |
1056 | return sv_bless(sv_2mortal(newRV_noinc((SV *)newHV())), mi->stash); |
af0842cb |
1057 | } |
fe0194bf |
1058 | |
fe0194bf |
1059 | |
fe0194bf |
1060 | |
fe0194bf |
1061 | |
2cd9d2ba |
1062 | /* Shared functionality for readers/writers/accessors, this roughly corresponds |
1063 | * to the methods of Moose::Meta::Attribute on the instance |
8ab8cdae |
1064 | * (get_value/set_value, default value handling, etc) |
1065 | * |
1066 | * These functions return mortal copiess and save copies (handling refcounting). */ |
fe0194bf |
1067 | |
7bc5b9a9 |
1068 | STATIC void attr_set_common(pTHX_ SV *self, ATTR *attr, SV *value) { |
1069 | SV *copy; |
1070 | |
1071 | if ( !value ) { |
1072 | /* FIXME croak if required ? */ |
1073 | return; |
1074 | } |
1075 | |
1076 | if ( ATTR_TYPE(attr) ) { |
1077 | if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) ) |
1078 | croak("Bad param"); |
1079 | } |
1080 | |
1081 | copy = newSVsv(value); |
1082 | |
1083 | if ( ATTR_ISWEAK(attr) && SvROK(copy) ) |
1084 | weaken(aTHX_ copy); |
1085 | |
1086 | if ( !set_slot_value(aTHX_ self, attr, copy) ) { |
1087 | SvREFCNT_dec(copy); |
1088 | croak("Hash store failed."); |
1089 | } |
1090 | } |
1091 | |
81c77c45 |
1092 | |
1093 | STATIC XS(initializer) |
1094 | { |
1095 | #ifdef dVAR |
1096 | dVAR; |
1097 | #endif |
1098 | dXSARGS; |
1099 | dATTR; |
1100 | |
1101 | if (items != 2) |
1102 | Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value"); |
1103 | |
1104 | SP -= items; |
1105 | |
1106 | attr_set_common(aTHX_ ST(0), attr, ST(1)); |
1107 | |
1108 | XSRETURN_EMPTY; |
1109 | } |
1110 | |
7bc5b9a9 |
1111 | STATIC void attr_set_initial_value(pTHX_ SV *self, ATTR *attr, SV *value) { |
bdc8e3ec |
1112 | if ( ATTR_HAS_INITIALIZER(attr) ) { |
81c77c45 |
1113 | if ( !attr->writer ) { |
b2dbd503 |
1114 | attr->writer = newRV_inc((SV *)new_method(aTHX_ attr->meta_attr, initializer, NULL )); |
81c77c45 |
1115 | } |
1116 | |
1117 | dSP; |
1118 | |
1119 | ENTER; |
1120 | SAVETMPS; |
1121 | PUSHMARK(SP); |
1122 | |
1123 | XPUSHs(self); |
1124 | XPUSHs(sv_2mortal(newSVsv(value))); |
1125 | XPUSHs(attr->writer); |
1126 | XPUSHs(attr->meta_attr); |
1127 | |
1128 | PUTBACK; |
1129 | call_sv((SV *)attr->initializer, G_VOID); |
1130 | |
1131 | FREETMPS; |
1132 | LEAVE; |
7bc5b9a9 |
1133 | } else { |
1134 | attr_set_common(aTHX_ self, attr, value); |
1135 | } |
1136 | } |
fe0194bf |
1137 | |
2cd9d2ba |
1138 | STATIC SV *call_builder (pTHX_ SV *self, ATTR *attr) { |
1139 | SV *sv; |
1140 | dSP; |
fe0194bf |
1141 | |
2cd9d2ba |
1142 | ENTER; |
1143 | SAVETMPS; |
1144 | PUSHMARK(SP); |
1145 | |
1146 | XPUSHs(self); |
1147 | |
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' */ |
1150 | PUTBACK; |
1151 | call_method(SvPV_nolen(attr->def.sv), G_SCALAR); |
2cd9d2ba |
1152 | |
1153 | /* the value is a mortal with a refcount of 1, so we need to keep it around */ |
4ca2dd5f |
1154 | SPAGAIN; |
2cd9d2ba |
1155 | sv = POPs; |
da6328c3 |
1156 | SvREFCNT_inc_simple_void(sv); |
2cd9d2ba |
1157 | |
1158 | PUTBACK; |
1159 | FREETMPS; |
1160 | LEAVE; |
1161 | |
1162 | return sv_2mortal(sv); |
1163 | } |
1164 | |
1165 | |
2cd9d2ba |
1166 | STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) { |
1167 | switch ( ATTR_DEFAULT(attr) ) { |
1168 | case default_none: |
1169 | return NULL; |
1170 | break; |
1171 | case default_builder: |
1172 | return call_builder(aTHX_ self, attr); |
fe0194bf |
1173 | break; |
1174 | case default_normal: |
1175 | if ( SvROK(attr->def.sv) ) { |
1176 | printf("CV default\n"); |
2cd9d2ba |
1177 | croak("todo"); |
fe0194bf |
1178 | } else { |
1179 | printf("simple value\n"); |
9f3805f7 |
1180 | return sv_mortalcopy(attr->def.sv); /* will be copied by set for lazy, and by reader for both cases */ |
fe0194bf |
1181 | } |
1182 | break; |
fe0194bf |
1183 | case default_type: |
1184 | croak("todo"); |
1185 | break; |
1186 | } |
1187 | |
1188 | return NULL; |
1189 | } |
1190 | |
2cd9d2ba |
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 |
1193 | * */ |
1194 | STATIC SV *attr_get_value(pTHX_ SV *self, ATTR *attr) { |
9f3805f7 |
1195 | SV *value = get_slot_lvalue(aTHX_ self, attr); |
fe0194bf |
1196 | |
1197 | if ( value ) { |
9f3805f7 |
1198 | return sv_mortalcopy(value); |
fe0194bf |
1199 | } else if ( ATTR_ISLAZY(attr) ) { |
1200 | value = get_default(aTHX_ self, attr); |
7bc5b9a9 |
1201 | attr_set_initial_value(aTHX_ self, attr, value); |
fe0194bf |
1202 | return value; |
1203 | } |
1204 | |
1205 | return NULL; |
160f9ca7 |
1206 | } |
1207 | |
bdc8e3ec |
1208 | STATIC void call_trigger (pTHX_ SV *self, ATTR *attr, SV *value) { |
1209 | dSP; |
9f3805f7 |
1210 | |
bdc8e3ec |
1211 | ENTER; |
1212 | SAVETMPS; |
1213 | PUSHMARK(SP); |
9f3805f7 |
1214 | |
bdc8e3ec |
1215 | /* FIXME copy self & meta attr? */ |
1216 | XPUSHs(self); |
1217 | XPUSHs(sv_2mortal(newSVsv(value))); |
1218 | XPUSHs(attr->meta_attr); |
160f9ca7 |
1219 | |
bdc8e3ec |
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' */ |
1222 | PUTBACK; |
1223 | call_sv((SV *)attr->trigger, G_VOID); |
9f3805f7 |
1224 | |
bdc8e3ec |
1225 | FREETMPS; |
1226 | LEAVE; |
1227 | } |
9f3805f7 |
1228 | |
bdc8e3ec |
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); |
1232 | |
1233 | if ( ATTR_HAS_TRIGGER(attr) ) { |
1234 | call_trigger(aTHX_ self, attr, value); |
9f3805f7 |
1235 | } |
160f9ca7 |
1236 | } |
1ea12c91 |
1237 | |
81c77c45 |
1238 | STATIC bool attr_has_value(pTHX_ SV *self, ATTR *attr) { |
1239 | return has_slot_value(aTHX_ self, attr); |
1240 | } |
2cd9d2ba |
1241 | |
81c77c45 |
1242 | STATIC SV *attr_clear_value(pTHX_ SV *self, ATTR *attr) { |
1243 | return deinitialize_slot(aTHX_ self, attr); |
1244 | } |
2cd9d2ba |
1245 | |
b2dbd503 |
1246 | STATIC void initialize_instance_slot(pTHX_ SV *self, ATTR *attr, HV *params) { |
1247 | HE *he; |
1248 | SV *value = NULL; |
2cd9d2ba |
1249 | |
bdc8e3ec |
1250 | if ( ATTR_HAS_INIT_ARG(attr) ) { |
1251 | if ((he = hv_fetch_ent(params, attr->init_arg_sv, 0, attr->init_arg_u32))) |
b2dbd503 |
1252 | value = HeVAL(he); |
1253 | } |
2cd9d2ba |
1254 | |
b2dbd503 |
1255 | if ( !value && ATTR_DEFAULT(attr) && !ATTR_ISLAZY(attr) ) { |
1256 | value = get_default(aTHX_ self, attr); |
1257 | } |
1258 | |
1259 | if ( value ) { |
1260 | attr_set_initial_value(aTHX_ self, attr, value); |
1261 | } |
1262 | } |
1263 | |
1264 | STATIC SV *class_new_object(pTHX_ MI *mi, HV *params) { |
1265 | I32 i; |
1266 | |
1267 | SV *self = create_instance(aTHX_ mi); |
1268 | |
1269 | for ( i = 0; i < mi->num_attrs; i++ ) { |
1270 | ATTR *attr = &mi->attrs[i]; |
1271 | initialize_instance_slot(aTHX_ self, attr, params); |
1272 | } |
1273 | |
1274 | return self; |
1275 | } |
2cd9d2ba |
1276 | |
1277 | |
1278 | /* Perl-space level functionality |
1279 | * |
1280 | * These subs are installed by new_sub's various aliases as the bodies of the |
1281 | * new XSUBs |
1282 | * */ |
1283 | |
1284 | |
1285 | |
a0c236f1 |
1286 | /* generate a new attribute method */ |
b2dbd503 |
1287 | STATIC CV *new_method (pTHX_ SV *attr, XSPROTO(body), char *name) { |
a0c236f1 |
1288 | CV *cv = newXS(name, body, __FILE__); |
1289 | |
1290 | if (cv == NULL) |
1291 | croak("Oi vey!"); |
1292 | |
1293 | /* associate CV with meta attr */ |
1294 | stash_in_mg(aTHX_ (SV *)cv, attr); |
1295 | |
1296 | /* this will be set on first call */ |
5a022b97 |
1297 | XSANY.any_ptr = NULL; |
a0c236f1 |
1298 | |
1299 | return cv; |
1300 | } |
1301 | |
1302 | |
1303 | |
1304 | |
24a7a8c5 |
1305 | STATIC XS(reader) |
1ea12c91 |
1306 | { |
1307 | #ifdef dVAR |
1308 | dVAR; |
1309 | #endif |
1310 | dXSARGS; |
de2f2e97 |
1311 | dATTR; |
1ea12c91 |
1312 | SV *value; |
1313 | |
1314 | if (items != 1) |
1315 | Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); |
1316 | |
1317 | SP -= items; |
1318 | |
2cd9d2ba |
1319 | value = attr_get_value(aTHX_ ST(0), attr); |
1ea12c91 |
1320 | |
1321 | if (value) { |
9f3805f7 |
1322 | ST(0) = value; |
1ea12c91 |
1323 | XSRETURN(1); |
1324 | } else { |
1325 | XSRETURN_UNDEF; |
1326 | } |
1327 | } |
1328 | |
24a7a8c5 |
1329 | STATIC XS(writer) |
1ea12c91 |
1330 | { |
1331 | #ifdef dVAR |
1332 | dVAR; |
1333 | #endif |
1334 | dXSARGS; |
de2f2e97 |
1335 | dATTR; |
1ea12c91 |
1336 | |
1337 | if (items != 2) |
1338 | Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value"); |
1339 | |
1340 | SP -= items; |
1341 | |
2cd9d2ba |
1342 | attr_set_value(aTHX_ ST(0), attr, ST(1)); |
1ea12c91 |
1343 | |
1344 | ST(0) = ST(1); /* return value */ |
1345 | XSRETURN(1); |
1346 | } |
1347 | |
de2f2e97 |
1348 | STATIC XS(accessor) |
1ea12c91 |
1349 | { |
1350 | #ifdef dVAR |
1351 | dVAR; |
1352 | #endif |
1353 | dXSARGS; |
de2f2e97 |
1354 | dATTR; |
1ea12c91 |
1355 | |
1356 | if (items < 1) |
1357 | Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value"); |
1358 | |
1359 | SP -= items; |
1360 | |
1361 | if (items > 1) { |
2cd9d2ba |
1362 | attr_set_value(aTHX_ ST(0), attr, ST(1)); |
1ea12c91 |
1363 | ST(0) = ST(1); /* return value */ |
1364 | } else { |
2cd9d2ba |
1365 | SV *value = attr_get_value(aTHX_ ST(0), attr); |
1ea12c91 |
1366 | if ( value ) { |
1367 | ST(0) = value; |
1368 | } else { |
1369 | XSRETURN_UNDEF; |
1370 | } |
1371 | } |
1372 | |
1373 | XSRETURN(1); |
1374 | } |
1375 | |
1ea12c91 |
1376 | STATIC XS(predicate) |
1377 | { |
1378 | #ifdef dVAR |
1379 | dVAR; |
1380 | #endif |
1381 | dXSARGS; |
de2f2e97 |
1382 | dATTR; |
1ea12c91 |
1383 | |
1384 | if (items != 1) |
1385 | Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); |
1386 | |
1387 | SP -= items; |
1388 | |
81c77c45 |
1389 | if ( attr_has_value(aTHX_ ST(0), attr) ) |
1ea12c91 |
1390 | XSRETURN_YES; |
1391 | else |
1392 | XSRETURN_NO; |
1393 | } |
1394 | |
81c77c45 |
1395 | STATIC XS(clearer) |
1396 | { |
1397 | #ifdef dVAR |
1398 | dVAR; |
1399 | #endif |
1400 | dXSARGS; |
1401 | dATTR; |
1402 | |
1403 | if (items != 1) |
1404 | Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); |
a0c236f1 |
1405 | |
81c77c45 |
1406 | SP -= items; |
1407 | |
1408 | attr_clear_value(aTHX_ ST(0), attr); |
1409 | |
1410 | XSRETURN_EMPTY; |
1411 | } |
a0c236f1 |
1412 | |
47cc0b73 |
1413 | STATIC HV *buildargs (pTHX_ SV **args, I32 items) { |
b2dbd503 |
1414 | if ( items == 1 ) { |
1415 | SV *sv = args[0]; |
1416 | if ( SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVHV ) |
1417 | return (HV *)SvRV(sv); |
1418 | else |
1419 | croak("Single argument must be hash ref"); /* FIXME copy the same error */ |
1420 | } else if ( items % 2 == 0 ) { /* kvp + self */ |
1421 | I32 i = 0; |
1422 | HV* const hv = newHV(); |
1423 | sv_2mortal((SV *)hv); |
1424 | |
1425 | while ( i < (items-1) ) { |
1426 | SV * const key = args[i++]; |
bdc8e3ec |
1427 | SV * const val = args[i++]; |
1428 | SvREFCNT_inc_simple_void(val); |
b2dbd503 |
1429 | (void)hv_store_ent(hv,key,val,0); |
1430 | } |
1431 | |
1432 | return hv; |
1433 | } else { |
1434 | croak("even sized list expected, got %d", items); /* FIXME copy the same error */ |
1435 | } |
1436 | } |
1437 | |
1438 | STATIC XS(new_object) |
1439 | { |
1440 | #ifdef dVAR |
1441 | dVAR; |
1442 | #endif |
1443 | dXSARGS; |
1444 | dMI; |
1445 | HV *params; |
1446 | |
1447 | if (items < 1) |
1448 | Perl_croak(aTHX_ "Usage: %s(%s, ...)", GvNAME(CvGV(cv)), "self"); |
1449 | |
1450 | SP -= items; |
1451 | |
1452 | params = buildargs(aTHX_ (SP+2), items-1); |
1453 | |
1454 | ST(0) = class_new_object(aTHX_ mi, params); |
1455 | |
1456 | XSRETURN(1); |
1457 | } |
1458 | |
1459 | STATIC XS(new) |
1460 | { |
1461 | #ifdef dVAR |
1462 | dVAR; |
1463 | #endif |
1464 | dXSARGS; |
1465 | dMI; |
1466 | HV *params; |
1467 | |
1468 | if (items < 1) |
1469 | Perl_croak(aTHX_ "Usage: %s(%s, ...)", GvNAME(CvGV(cv)), "self"); |
1470 | |
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) |
1475 | */ |
1476 | |
1477 | croak("todo"); |
1478 | |
1479 | ST(0) = class_new_object(aTHX_ mi, params); |
1480 | } |
a0c236f1 |
1481 | |
1482 | |
1483 | |
1484 | |
1ea12c91 |
1485 | enum xs_body { |
24a7a8c5 |
1486 | xs_body_reader = 0, |
1487 | xs_body_writer, |
de2f2e97 |
1488 | xs_body_accessor, |
1ea12c91 |
1489 | xs_body_predicate, |
81c77c45 |
1490 | xs_body_initializer, |
1491 | xs_body_clearer, |
b2dbd503 |
1492 | xs_body_new_object, |
1493 | xs_body_new, |
1ea12c91 |
1494 | max_xs_body |
1495 | }; |
1496 | |
1497 | STATIC XSPROTO ((*xs_bodies[])) = { |
24a7a8c5 |
1498 | reader, |
1499 | writer, |
de2f2e97 |
1500 | accessor, |
1ea12c91 |
1501 | predicate, |
81c77c45 |
1502 | initializer, |
1503 | clearer, |
b2dbd503 |
1504 | new_object, |
1505 | new, |
1506 | NULL |
1ea12c91 |
1507 | }; |
1508 | |
1509 | MODULE = Moose PACKAGE = Moose::XS |
4e783f63 |
1510 | PROTOTYPES: ENABLE |
1ea12c91 |
1511 | |
1512 | CV * |
b2dbd503 |
1513 | new_method(meta, name) |
1ea12c91 |
1514 | INPUT: |
b2dbd503 |
1515 | SV *meta; |
de2f2e97 |
1516 | SV *name; |
4e783f63 |
1517 | PROTOTYPE: $;$ |
a0c236f1 |
1518 | PREINIT: |
1519 | char *pv = SvOK(name) ? SvPV_nolen(name) : NULL; |
1ea12c91 |
1520 | ALIAS: |
81c77c45 |
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 |
b2dbd503 |
1527 | new_new_object = xs_body_new_object |
1528 | new_new = xs_body_new |
1ea12c91 |
1529 | CODE: |
1530 | if ( ix >= max_xs_body ) |
1531 | croak("Unknown Moose::XS body type"); |
1532 | |
b2dbd503 |
1533 | if ( !sv_isobject(meta) ) |
1534 | croak("'meta' must be an object"); |
de2f2e97 |
1535 | |
b2dbd503 |
1536 | RETVAL = new_method(aTHX_ meta, xs_bodies[ix], pv); |
1ea12c91 |
1537 | OUTPUT: |
1538 | RETVAL |
1539 | |
1540 | |
f253044f |
1541 | MODULE = Moose PACKAGE = Moose::XS::Meta::Instance |
4e783f63 |
1542 | PROTOTYPES: DISABLE |
f253044f |
1543 | |
1544 | void |
1545 | DESTROY(self) |
1546 | INPUT: |
1547 | SV *self; |
1548 | PREINIT: |
1549 | MI *mi = INT2PTR(MI *, SvIV(SvRV(self))); |
1550 | CODE: |
2cd9d2ba |
1551 | if ( mi ) |
1552 | delete_mi(aTHX_ mi); |
1553 | |
3c63e75d |
1554 | |
1555 | MODULE = Moose PACKAGE = Moose::XS::TypeConstraints |
1556 | PROTOTYPES: ENABLE |
1557 | |
1558 | bool |
1559 | _check_type(sv) |
1560 | INPUT: |
1561 | SV* sv |
1562 | ALIAS: |
1563 | Any = Any |
1564 | Item = Any |
1565 | Bool = Any |
1566 | Undef = Undef |
1567 | Defined = Defined |
1568 | Str = Str |
1569 | Value = Str |
1570 | Num = Num |
1571 | Int = Int |
1572 | GlobRef = GlobRef |
1573 | ArrayRef = ArrayRef |
1574 | HashRef = HashRef |
1575 | CodeRef = CodeRef |
1576 | Ref = Ref |
1577 | ScalarRef = ScalarRef |
1578 | FileHandle = FileHandle |
1579 | RegexpRef = RegexpRef |
1580 | Object = Object |
1581 | Role = Role |
1582 | ClassName = ClassName |
1583 | CODE: |
1584 | RETVAL = check_sv_type(ix, sv); |
1585 | OUTPUT: |
1586 | RETVAL |
1587 | |
1588 | bool |
1589 | ObjectOfType(sv, class) |
1590 | INPUT: |
1591 | SV* sv |
1592 | SV* class |
1593 | PREINIT: |
1594 | HV *stash = gv_stashsv(class, 0); |
1595 | CODE: |
1596 | RETVAL = check_sv_class(aTHX_ stash, sv); |
1597 | OUTPUT: |
1598 | RETVAL |