Commit | Line | Data |
1ea12c91 |
1 | #include "EXTERN.h" |
2 | #include "perl.h" |
3 | #include "XSUB.h" |
4 | |
035fd0c4 |
5 | #define NEED_newRV_noinc |
6 | #define NEED_newSVpvn_share |
7 | #define NEED_sv_2pv_flags |
8 | #include "ppport.h" |
9 | |
10 | #ifndef XSPROTO |
11 | #define XSPROTO(name) void name(pTHX_ CV* cv) |
12 | #endif |
13 | |
14 | #ifndef gv_stashpvs |
15 | #define gv_stashpvs(x, y) gv_stashpvn(STR_WITH_LEN(x), y) |
16 | #endif |
17 | |
1ea12c91 |
18 | /* FIXME |
1ea12c91 |
19 | * delegations and attribute helpers: |
20 | * |
21 | * typedef struct { |
de2f2e97 |
22 | * ATTR *attr; |
1ea12c91 |
23 | * pv *method; |
24 | * } delegation; |
25 | * |
26 | * typedef struct { |
de2f2e97 |
27 | * ATTR *attr; |
1ea12c91 |
28 | * I32 *type; // hash, array, whatever + vtable for operation |
29 | * } attributehelper; |
30 | */ |
31 | |
de2f2e97 |
32 | |
2cd9d2ba |
33 | |
34 | |
35 | |
36 | |
37 | |
38 | /* These two functions attach magic with no behavior to an SV. |
39 | * |
40 | * The stashed value is reference counted, and is destroyed when it's parent |
41 | * object is destroyed. |
42 | * |
43 | * This is used to keep a reference the the meta attribute from a generated |
44 | * method, and to cache the C struct based wrapper attached to the meta |
45 | * instance. |
46 | */ |
47 | |
de2f2e97 |
48 | STATIC MGVTBL null_mg_vtbl = { |
49 | NULL, /* get */ |
50 | NULL, /* set */ |
51 | NULL, /* len */ |
52 | NULL, /* clear */ |
53 | NULL, /* free */ |
54 | #if MGf_COPY |
55 | NULL, /* copy */ |
56 | #endif /* MGf_COPY */ |
57 | #if MGf_DUP |
58 | NULL, /* dup */ |
59 | #endif /* MGf_DUP */ |
60 | #if MGf_LOCAL |
61 | NULL, /* local */ |
62 | #endif /* MGf_LOCAL */ |
63 | }; |
64 | |
f253044f |
65 | STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) { |
66 | MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 ); |
67 | mg->mg_flags |= MGf_REFCOUNTED; |
68 | |
69 | return mg; |
70 | } |
71 | |
72 | STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) { |
73 | MAGIC *mg, *moremagic; |
74 | |
75 | if (SvTYPE(sv) >= SVt_PVMG) { |
76 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
77 | if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl)) |
78 | break; |
79 | } |
80 | if (mg) |
81 | return mg->mg_obj; |
82 | } |
83 | |
84 | return NULL; |
85 | } |
de2f2e97 |
86 | |
2cd9d2ba |
87 | |
88 | |
89 | |
90 | |
91 | |
92 | |
93 | |
94 | |
95 | /* The folloing data structures deal with type constraints */ |
96 | |
97 | /* this is an enum of the various kinds of constraint checking an attribute can |
98 | * have. |
99 | * |
100 | * tc_cv is the fallback behavior (simply applying the |
101 | * ->_compiled_type_constraint to the value, but other more optimal checks are |
102 | * implemented too. */ |
103 | |
104 | typedef enum { |
105 | tc_none = 0, /* no type checking */ |
106 | tc_type, /* a builtin type to be checked by check_sv_type */ |
107 | tc_stash, /* a stash for a class, implements TypeConstraint::Class by comparing SvSTASH and then invoking C<isa> if necessary */ |
108 | tc_cv, /* applies a code reference to the value and checks for truth */ |
109 | tc_fptr, /* apply a C function pointer */ |
110 | tc_enum, /* TODO check that the value is in an allowed set of values (strings) */ |
111 | } tc_kind; |
112 | |
113 | /* this is a enum of builtin type check. They are handled in a switch statement |
114 | * in check_sv_type */ |
de2f2e97 |
115 | typedef enum { |
4c6fbfb1 |
116 | Any, /* or item, or bool */ |
117 | Undef, |
118 | Defined, |
119 | Str, /* or value */ |
120 | Num, |
121 | Int, |
122 | GlobRef, /* SVt_PVGV */ |
123 | ArrayRef, /* SVt_PVAV */ |
124 | HashRef, /* SVt_PVHV */ |
125 | CodeRef, /* SVt_PVCV */ |
126 | Ref, |
127 | ScalarRef, |
2cd9d2ba |
128 | FileHandle, /* TODO */ |
4c6fbfb1 |
129 | RegexpRef, |
130 | Object, |
2cd9d2ba |
131 | Role, /* TODO */ |
160f9ca7 |
132 | ClassName, |
de2f2e97 |
133 | } TC; |
134 | |
2cd9d2ba |
135 | /* auxillary pointer/int union used for constraint checking */ |
de2f2e97 |
136 | typedef union { |
2cd9d2ba |
137 | TC type; /* the builtin type number for tc_type */ |
138 | SV *sv; /* the cv for tc_cv, or the stash for tc_stash */ |
139 | OP *op; /* TODO not used */ |
140 | bool (*fptr)(pTHX_ SV *type_constraint, SV *sv); /* the function pointer for tc_fptr FIXME aux data? */ |
4c6fbfb1 |
141 | } TC_CHECK; |
142 | |
2cd9d2ba |
143 | |
144 | |
145 | |
146 | |
147 | |
148 | /* The folloing data structures deal with type default value generation */ |
149 | |
150 | /* This is an enum for the various types of default value behaviors an |
151 | * attribute can have */ |
de2f2e97 |
152 | |
153 | typedef enum { |
2cd9d2ba |
154 | default_none = 0, /* no default value */ |
155 | default_normal, /* code reference or scalar */ |
156 | default_builder, /* builder method */ |
157 | default_type, /* TODO enumerated type optimization (will call newHV, newAV etc to avoid calling a code ref for these simple cases) */ |
de2f2e97 |
158 | } default_kind; |
159 | |
2cd9d2ba |
160 | typedef union { |
161 | SV *sv; /* The default value, or a code ref to generate one. If builder then this sv is applied as a method (stringified) */ |
162 | U32 type; /* TODO for default_type, should probably be one of SVt_PVAV/SVt_PVHV */ |
163 | } DEFAULT; |
164 | |
165 | |
166 | |
167 | |
168 | |
169 | |
170 | /* the ATTR struct contains all the meta data for a Moose::Meta::Attribute for |
171 | * a given meta instance |
172 | * |
173 | * flags determines the various behaviors |
174 | * |
175 | * This supports only one slot per attribute in the current implementation, but |
176 | * slot_sv could contain an array |
177 | * |
178 | * A list of XSUBs that rely on this attr struct are cross indexed in the cvs |
179 | * array, so that when the meta instance is destroyed the XSANY field will be |
180 | * cleared. This is done in delete_mi |
181 | * */ |
182 | |
1ea12c91 |
183 | typedef struct { |
2cd9d2ba |
184 | /* pointer to the MI this attribute is a part of the meta instance struct */ |
de2f2e97 |
185 | struct mi *mi; |
186 | |
187 | U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */ |
188 | |
189 | /* slot access fields */ |
2cd9d2ba |
190 | SV *slot_sv; /* value of the slot (currently always slot name) */ |
191 | U32 slot_u32; /* for optimized access (precomputed hash, possibly something else) */ |
de2f2e97 |
192 | |
193 | DEFAULT def; /* cv, value or other, depending on flags */ |
194 | |
2cd9d2ba |
195 | TC_CHECK tc_check; /* see TC_CHECK*/ |
196 | SV *type_constraint; /* Moose::Meta::TypeConstraint object */ |
de2f2e97 |
197 | |
2cd9d2ba |
198 | CV *initializer; /* TODO */ |
199 | CV *trigger; /* TODO */ |
de2f2e97 |
200 | |
2cd9d2ba |
201 | SV *meta_attr; /* the Moose::Meta::Attribute */ |
202 | AV *cvs; /* an array of CVs which use this attr, see delete_mi */ |
de2f2e97 |
203 | } ATTR; |
204 | |
2cd9d2ba |
205 | /* the flags integer is mapped as follows |
206 | * instance misc reading writing |
de2f2e97 |
207 | * 00000000 00000000 00000000 00000000 |
2cd9d2ba |
208 | * writing |
7ce1a351 |
209 | * ^ trigger |
210 | * ^ weak |
45922f54 |
211 | * ^ tc.sv is refcounted |
de2f2e97 |
212 | * ^^^ tc_kind |
213 | * ^ coerce |
2cd9d2ba |
214 | * |
215 | * reading |
de2f2e97 |
216 | * ^^^ default_kind |
217 | * ^ lazy |
45922f54 |
218 | * ^ def.sv is refcounted |
2cd9d2ba |
219 | * |
220 | * misc |
221 | * ^ attr is required TODO |
222 | * |
223 | * flags having to do with the instance layout (TODO, only hash supported for now) |
de2f2e97 |
224 | * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD |
225 | */ |
226 | |
227 | #define ATTR_INSTANCE_MASK 0xff000000 |
228 | #define ATTR_READING_MASK 0x0000ff00 |
229 | #define ATTR_WRITING_MASK 0x000000ff |
230 | |
231 | #define ATTR_MASK_TYPE 0x7 |
232 | |
233 | #define ATTR_MASK_DEFAULT 0x700 |
fe0194bf |
234 | #define ATTR_SHIFT_DEFAULT 8 |
de2f2e97 |
235 | |
236 | #define ATTR_LAZY 0x800 |
fe0194bf |
237 | #define ATTR_DEFREFCNT 0x1000 |
de2f2e97 |
238 | |
7ce1a351 |
239 | #define ATTR_COERCE 0x8 |
240 | #define ATTR_TCREFCNT 0x10 |
241 | #define ATTR_WEAK 0x20 |
242 | #define ATTR_TRIGGER 0x40 |
de2f2e97 |
243 | |
244 | #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK ) |
245 | #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY ) |
246 | #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE ) |
1ea12c91 |
247 | |
de2f2e97 |
248 | #define ATTR_TYPE(f) ( attr->flags & 0x7 ) |
249 | #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT ) |
1ea12c91 |
250 | |
de2f2e97 |
251 | #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr) |
252 | #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 ) |
253 | #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 ) |
1ea12c91 |
254 | |
de2f2e97 |
255 | |
256 | |
2cd9d2ba |
257 | /* This unused (TODO) vtable will implement the meta instance protocol in terms |
258 | * of function pointers to allow the XS accessors to be used with custom meta |
259 | * instances in the future. |
260 | * |
261 | * We'll need to define a default instance of this vtable that uses call_sv, |
262 | * too. */ |
263 | |
264 | /* FIXME define a vtable that does call_sv for fallback meta instance protocol */ |
de2f2e97 |
265 | typedef struct { |
266 | SV * (*get)(pTHX_ SV *self, ATTR *attr); |
267 | void (*set)(pTHX_ SV *self, ATTR *attr, SV *value); |
268 | bool * (*has)(pTHX_ SV *self, ATTR *attr); |
269 | SV * (*delete)(pTHX_ SV *self, ATTR *attr); |
270 | } instance_vtbl; |
271 | |
2cd9d2ba |
272 | /* TODO this table describes the instance layout of the object. Not yet |
273 | * implemented */ |
de2f2e97 |
274 | typedef enum { |
275 | hash = 0, |
276 | |
277 | /* these are not yet implemented */ |
278 | array, |
279 | fptr, |
280 | cv, |
281 | judy, |
282 | } instance_types; |
283 | |
2cd9d2ba |
284 | |
285 | /* this struct models the meta instance *and* meta attributes simultaneously. |
286 | * It is a cache of the meta attribute behaviors for a given class or subclass |
287 | * and can be parametrized on that level |
288 | * |
289 | * |
290 | * An object pointing to this structure is kept in a refcounted magic inside |
291 | * the meta instance it corresponds to. On C<invalidate_meta_instance> the meta |
292 | * instance is destroyed, causing the proxy object to be destroyed, deleting |
293 | * this structure, clearing the XSANY of all dependent attribute methods. |
294 | * |
295 | * The next invocation of an attribute method will eventually call get_attr, |
296 | * which will call C<get_meta_instance> on the metaclass (recreating it in the |
297 | * Class::MOP level), and cache a new MI struct inside it. Subsequent |
298 | * invocations of get_attr will then search the MI for an ATTR matching the |
299 | * meta_attribute of the attribute method */ |
de2f2e97 |
300 | typedef struct mi { |
de2f2e97 |
301 | HV *stash; |
302 | |
303 | /* slot access method */ |
2cd9d2ba |
304 | instance_types type; /* TODO only hashes supported currently */ |
305 | instance_vtbl *vtbl; /* TODO */ |
de2f2e97 |
306 | |
307 | /* attr descriptors */ |
308 | I32 num_attrs; |
309 | ATTR *attrs; |
310 | } MI; |
311 | |
312 | |
4c6fbfb1 |
313 | |
314 | |
2cd9d2ba |
315 | |
316 | |
317 | |
318 | |
319 | /* these functions implement type constraint checking */ |
320 | |
321 | /* checks that the SV is a scalar ref */ |
4c6fbfb1 |
322 | STATIC bool check_is_scalar_ref(SV *sv) { |
323 | if( SvROK(sv) ) { |
324 | switch (SvTYPE(SvRV(sv))) { |
325 | case SVt_IV: |
326 | case SVt_NV: |
327 | case SVt_PV: |
328 | case SVt_NULL: |
329 | return 1; |
330 | break; |
331 | default: |
332 | return 0; |
333 | } |
334 | } |
335 | return 0; |
336 | } |
337 | |
2cd9d2ba |
338 | /* checks that the SV is a ref to a certain SvTYPE, where type is in the table |
339 | * above */ |
4c6fbfb1 |
340 | STATIC bool check_reftype(TC type, SV *sv) { |
341 | int svt; |
342 | |
343 | if ( !SvROK(sv) ) |
344 | return 0; |
345 | |
346 | switch (type) { |
347 | case GlobRef: |
348 | svt = SVt_PVGV; |
349 | break; |
350 | case ArrayRef: |
351 | svt = SVt_PVAV; |
352 | break; |
353 | case HashRef: |
354 | svt = SVt_PVHV; |
355 | break; |
356 | case CodeRef: |
357 | svt = SVt_PVCV; |
358 | break; |
359 | } |
360 | |
160f9ca7 |
361 | return SvTYPE(SvRV(sv)) == svt; |
4c6fbfb1 |
362 | } |
363 | |
2cd9d2ba |
364 | /* checks whether an SV is of a certain class |
365 | * SvSTASH is first compared by pointer for efficiency */ |
7ce1a351 |
366 | STATIC bool check_sv_class(pTHX_ HV *stash, SV *sv) { |
4c6fbfb1 |
367 | dSP; |
368 | bool ret; |
7ce1a351 |
369 | SV *rv; |
4c6fbfb1 |
370 | |
371 | if (!sv) |
372 | return 0; |
373 | SvGETMAGIC(sv); |
374 | if (!SvROK(sv)) |
375 | return 0; |
7ce1a351 |
376 | rv = (SV*)SvRV(sv); |
377 | if (!SvOBJECT(rv)) |
4c6fbfb1 |
378 | return 0; |
7ce1a351 |
379 | if (SvSTASH(rv) == stash) |
4c6fbfb1 |
380 | return 1; |
381 | |
382 | ENTER; |
383 | SAVETMPS; |
384 | PUSHMARK(SP); |
385 | XPUSHs(sv); |
7ce1a351 |
386 | XPUSHs(sv_2mortal(newSVpv(HvNAME_get(stash), 0))); |
4c6fbfb1 |
387 | PUTBACK; |
388 | |
389 | call_method("isa", G_SCALAR); |
390 | |
391 | SPAGAIN; |
392 | ret = SvTRUE(TOPs); |
393 | |
394 | FREETMPS; |
395 | LEAVE; |
396 | |
397 | return ret; |
398 | } |
399 | |
2cd9d2ba |
400 | /* checks whether SV of of a known simple type. Most of the non parametrized |
401 | * Moose core types are implemented here */ |
4c6fbfb1 |
402 | STATIC bool check_sv_type (TC type, SV *sv) { |
403 | if (!sv) |
404 | return 0; |
160f9ca7 |
405 | |
4c6fbfb1 |
406 | switch (type) { |
407 | case Any: |
408 | return 1; |
409 | break; |
410 | case Undef: |
411 | return !SvOK(sv); |
412 | break; |
413 | case Defined: |
414 | return SvOK(sv); |
415 | break; |
416 | case Str: |
417 | return (SvOK(sv) && !SvROK(sv)); |
160f9ca7 |
418 | case Num: |
419 | #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5) |
420 | if (!SvPOK(sv) && !SvPOKp(sv)) |
421 | return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); |
422 | else |
423 | #endif |
424 | return looks_like_number(sv); |
425 | break; |
426 | case Int: |
427 | if ( SvIOK(sv) ) { |
428 | return 1; |
429 | } else if ( SvPOK(sv) ) { |
0be3b17f |
430 | /* FIXME i really don't like this */ |
160f9ca7 |
431 | int i; |
432 | STRLEN len; |
433 | char *pv = SvPV(sv, len); |
434 | char *end = pv + len; |
0be3b17f |
435 | char *tail = end; |
160f9ca7 |
436 | |
437 | errno = 0; |
0be3b17f |
438 | i = strtol(pv, &tail, 0); |
439 | |
440 | if ( errno ) return 0; |
441 | |
442 | while ( tail != end ) { |
443 | if ( !isspace(*tail++) ) return 0; |
444 | } |
445 | |
446 | return 1; |
160f9ca7 |
447 | } |
448 | return 0; |
449 | break; |
4c6fbfb1 |
450 | case Ref: |
451 | return SvROK(sv); |
452 | break; |
453 | case ScalarRef: |
454 | return check_is_scalar_ref(sv); |
455 | break; |
456 | case ArrayRef: |
457 | case HashRef: |
458 | case CodeRef: |
459 | case GlobRef: |
460 | return check_reftype(type, sv); |
461 | break; |
3c63e75d |
462 | case RegexpRef: |
463 | return ( sv_isobject(sv) && ( strEQ("Regexp", HvNAME_get(SvSTASH(SvRV(sv)))) ) ); |
464 | break; |
4c6fbfb1 |
465 | case Object: |
3c63e75d |
466 | return ( sv_isobject(sv) && ( strNE("Regexp", HvNAME_get(SvSTASH(SvRV(sv)))) ) ); |
4c6fbfb1 |
467 | break; |
160f9ca7 |
468 | case ClassName: |
7ce1a351 |
469 | if ( SvOK(sv) && !SvROK(sv) ) { |
160f9ca7 |
470 | STRLEN len; |
471 | char *pv; |
472 | pv = SvPV(sv, len); |
473 | return ( gv_stashpvn(pv, len, 0) != NULL ); |
160f9ca7 |
474 | } |
7ce1a351 |
475 | return 0; |
476 | break; |
4c6fbfb1 |
477 | case FileHandle: |
478 | croak("todo"); |
479 | break; |
480 | default: |
481 | croak("todo"); |
482 | } |
483 | |
484 | return 0; |
485 | } |
486 | |
2cd9d2ba |
487 | /* invoke a CV on an SV and return SvTRUE of the result */ |
45922f54 |
488 | STATIC bool check_sv_cv (pTHX_ SV *cv, SV *sv) { |
489 | bool ret; |
490 | dSP; |
491 | |
492 | ENTER; |
493 | SAVETMPS; |
494 | PUSHMARK(SP); |
495 | XPUSHs(sv); |
496 | PUTBACK; |
497 | |
498 | call_sv(cv, G_SCALAR); |
499 | |
500 | SPAGAIN; |
501 | ret = SvTRUE(POPs); |
502 | |
503 | PUTBACK; |
504 | FREETMPS; |
505 | LEAVE; |
506 | |
507 | return ret; |
508 | } |
509 | |
2cd9d2ba |
510 | /* checks the type constraint for an SV based on the type constraint kind */ |
160f9ca7 |
511 | STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) { |
4c6fbfb1 |
512 | switch (kind) { |
513 | case tc_none: |
514 | return 1; |
515 | break; |
516 | case tc_type: |
517 | return check_sv_type(tc_check.type, sv); |
518 | break; |
519 | case tc_stash: |
7ce1a351 |
520 | return check_sv_class(aTHX_ (HV *)tc_check.sv, sv); |
4c6fbfb1 |
521 | break; |
4c6fbfb1 |
522 | case tc_fptr: |
523 | return tc_check.fptr(aTHX_ type_constraint, sv); |
524 | break; |
525 | case tc_cv: |
45922f54 |
526 | return check_sv_cv(aTHX_ tc_check.sv, sv); |
527 | break; |
4c6fbfb1 |
528 | } |
529 | |
530 | croak("todo"); |
531 | return 0; |
532 | } |
533 | |
534 | |
2cd9d2ba |
535 | /* end of type constraint checking functions */ |
536 | |
537 | |
538 | |
539 | |
540 | |
541 | |
542 | |
543 | |
544 | |
545 | /* Initialize the ATTR structure using positional arguments from Perl space. */ |
546 | |
160f9ca7 |
547 | STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) { |
548 | U32 flags = 0; |
1ea12c91 |
549 | U32 hash; |
550 | STRLEN len; |
de2f2e97 |
551 | char *pv; |
160f9ca7 |
552 | I32 ix = av_len(desc); |
553 | SV **params = AvARRAY(desc); |
554 | SV *tc; |
555 | SV *key; |
de2f2e97 |
556 | |
557 | attr->mi = mi; |
558 | |
de2f2e97 |
559 | |
160f9ca7 |
560 | if ( ix != 12 ) |
561 | croak("wrong number of args (%d != 13)", ix + 1); |
de2f2e97 |
562 | |
160f9ca7 |
563 | for ( ; ix >= 0; ix-- ) { |
564 | if ( !params[ix] || params[ix] == &PL_sv_undef ) |
565 | croak("bad params"); |
566 | } |
567 | |
2cd9d2ba |
568 | |
569 | |
570 | /* handle attribute slot array */ |
571 | |
160f9ca7 |
572 | if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV ) |
573 | croak("slots is not an array"); |
de2f2e97 |
574 | |
160f9ca7 |
575 | if ( av_len((AV *)SvRV(params[1])) != 0 ) |
576 | croak("Only unary slots are supported at the moment"); |
1ea12c91 |
577 | |
160f9ca7 |
578 | /* calculate a hash from the slot */ |
579 | /* FIXME arrays etc should also be supported */ |
580 | key = *av_fetch((AV *)SvRV(params[1]), 0, 0); |
581 | pv = SvPV(key, len); |
1ea12c91 |
582 | PERL_HASH(hash, pv, len); |
1ea12c91 |
583 | |
de2f2e97 |
584 | |
2cd9d2ba |
585 | |
586 | |
587 | /* FIXME better organize these, positionals suck */ |
160f9ca7 |
588 | if ( SvTRUE(params[2]) ) |
589 | flags |= ATTR_WEAK; |
590 | |
591 | if ( SvTRUE(params[3]) ) |
592 | flags |= ATTR_COERCE; |
de2f2e97 |
593 | |
160f9ca7 |
594 | if ( SvTRUE(params[4]) ) |
595 | flags |= ATTR_LAZY; |
de2f2e97 |
596 | |
2cd9d2ba |
597 | |
598 | |
599 | /* type constraint data */ |
600 | |
160f9ca7 |
601 | tc = params[5]; |
de2f2e97 |
602 | |
160f9ca7 |
603 | if ( SvOK(tc) ) { |
604 | int tc_kind = SvIV(params[6]); |
605 | SV *data = params[7]; |
606 | |
607 | switch (tc_kind) { |
160f9ca7 |
608 | case tc_type: |
609 | attr->tc_check.type = SvIV(data); |
610 | break; |
7ce1a351 |
611 | case tc_stash: |
612 | flags |= ATTR_TCREFCNT; |
613 | attr->tc_check.sv = (SV *)gv_stashsv(data, 0); |
614 | break; |
160f9ca7 |
615 | case tc_cv: |
7ce1a351 |
616 | flags |= ATTR_TCREFCNT; |
617 | attr->tc_check.sv = SvRV(data); |
618 | if ( SvTYPE(attr->tc_check.sv) != SVt_PVCV ) |
160f9ca7 |
619 | croak("compiled type constraint is not a coderef"); |
620 | break; |
621 | default: |
622 | croak("todo"); |
623 | } |
624 | |
625 | flags |= tc_kind; |
626 | } |
627 | |
2cd9d2ba |
628 | |
629 | |
630 | /* default/builder data */ |
fe0194bf |
631 | |
632 | if ( SvTRUE(params[10]) ) { /* has default */ |
633 | SV *sv = params[11]; |
634 | |
635 | if ( SvROK(sv) ) { |
636 | attr->def.sv = SvRV(sv); |
637 | if ( SvTYPE(attr->def.sv) != SVt_PVCV ) |
638 | croak("compiled type constraint is not a coderef"); |
639 | } else { |
640 | attr->def.sv = newSVsv(sv); |
641 | sv_2mortal(attr->def.sv); /* in case of error soon, we refcnt inc it later after we're done checking params */ |
642 | } |
643 | |
644 | flags |= ( ATTR_DEFREFCNT | ( default_normal << ATTR_SHIFT_DEFAULT ) ); |
645 | } else if ( SvOK(params[12]) ) { /* builder */ |
646 | attr->def.sv = newSVsv(params[12]); |
647 | flags |= ( ATTR_DEFREFCNT | ( default_builder << ATTR_SHIFT_DEFAULT ) ); |
648 | } |
649 | |
2cd9d2ba |
650 | |
160f9ca7 |
651 | |
652 | attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL; |
653 | if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV ) |
654 | croak("trigger is not a coderef"); |
655 | |
656 | attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL; |
657 | if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV ) |
658 | croak("initializer is not a coderef"); |
659 | |
2cd9d2ba |
660 | |
661 | |
662 | /* now that we're done preparing/checking args and shit, so we finalize the |
663 | * attr, increasing refcounts for any referenced data, and creating the CV |
664 | * array */ |
665 | |
666 | attr->flags = flags; |
667 | |
668 | /* copy the outer ref SV */ |
160f9ca7 |
669 | attr->meta_attr = newSVsv(params[0]); |
670 | attr->type_constraint = newSVsv(tc); |
2cd9d2ba |
671 | |
672 | /* increase the refcount for auxillary structures */ |
7ce1a351 |
673 | SvREFCNT_inc(attr->trigger); |
674 | SvREFCNT_inc(attr->initializer); |
9be0171f |
675 | if ( flags & ATTR_TCREFCNT ) SvREFCNT_inc(attr->tc_check.sv); |
fe0194bf |
676 | if ( flags & ATTR_DEFREFCNT ) SvREFCNT_inc(attr->def.sv); |
160f9ca7 |
677 | |
2cd9d2ba |
678 | /* create a new SV for the hash key */ |
160f9ca7 |
679 | attr->slot_sv = newSVpvn_share(pv, len, hash); |
680 | attr->slot_u32 = hash; |
681 | |
de2f2e97 |
682 | /* cross refs to CVs which use this struct */ |
683 | attr->cvs = newAV(); |
684 | } |
685 | |
2cd9d2ba |
686 | STATIC SV *new_mi (pTHX_ HV *stash, AV *attrs) { |
687 | HV *mi_stash = gv_stashpvs("Moose::XS::Meta::Instance",0); |
688 | SV *sv_ptr = newSViv(0); |
689 | SV *obj = sv_2mortal(sv_bless(newRV_noinc(sv_ptr), mi_stash)); |
de2f2e97 |
690 | MI *mi; |
2cd9d2ba |
691 | const I32 num_attrs = av_len(attrs) + 1; |
de2f2e97 |
692 | |
687453c6 |
693 | Newxz(mi, 1, MI); |
2cd9d2ba |
694 | |
695 | /* set the pointer now, if we have any initialization errors it'll get |
696 | * cleaned up because obj is mortal */ |
697 | sv_setiv(sv_ptr, PTR2IV(mi)); |
698 | |
687453c6 |
699 | Newxz(mi->attrs, num_attrs, ATTR); |
2cd9d2ba |
700 | |
de2f2e97 |
701 | SvREFCNT_inc_simple(stash); |
702 | mi->stash = stash; |
703 | |
de2f2e97 |
704 | mi->type = 0; /* nothing else implemented yet */ |
705 | |
706 | /* initialize attributes */ |
2cd9d2ba |
707 | for ( ; mi->num_attrs < num_attrs; mi->num_attrs++ ) { |
708 | SV **desc = av_fetch(attrs, mi->num_attrs, 0); |
de2f2e97 |
709 | |
160f9ca7 |
710 | if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) { |
de2f2e97 |
711 | croak("Attribute descriptor has to be a hash reference"); |
f253044f |
712 | } |
de2f2e97 |
713 | |
2cd9d2ba |
714 | init_attr(mi, &mi->attrs[mi->num_attrs], (AV *)SvRV(*desc)); |
de2f2e97 |
715 | } |
716 | |
2cd9d2ba |
717 | return obj; |
718 | } |
719 | |
720 | STATIC void delete_attr (pTHX_ ATTR *attr) { |
721 | I32 i; |
722 | SV **cvs = AvARRAY(attr->cvs); |
723 | |
724 | /* remove the pointers to this ATTR struct from all the the dependent CVs */ |
725 | for ( i = av_len(attr->cvs); i >= 0; i-- ) { |
726 | CV *cv = (CV *)cvs[i]; |
727 | XSANY.any_i32 = 0; |
728 | } |
729 | |
730 | SvREFCNT_dec(attr->cvs); |
731 | SvREFCNT_dec(attr->slot_sv); |
732 | SvREFCNT_dec(attr->type_constraint); |
733 | if ( attr->flags & ATTR_TCREFCNT ) SvREFCNT_dec(attr->tc_check.sv); |
734 | if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv); |
735 | SvREFCNT_dec(attr->initializer); |
736 | SvREFCNT_dec(attr->trigger); |
737 | SvREFCNT_dec(attr->meta_attr); |
de2f2e97 |
738 | } |
739 | |
7ce1a351 |
740 | STATIC void delete_mi (pTHX_ MI *mi) { |
2cd9d2ba |
741 | SvREFCNT_dec(mi->stash); |
7ce1a351 |
742 | |
2cd9d2ba |
743 | while ( mi->num_attrs--) { |
744 | ATTR *attr = &mi->attrs[mi->num_attrs]; |
745 | delete_attr(aTHX_ attr); |
7ce1a351 |
746 | } |
747 | |
2cd9d2ba |
748 | if ( mi->attrs ) Safefree(mi->attrs); |
7ce1a351 |
749 | Safefree(mi); |
750 | } |
751 | |
de2f2e97 |
752 | |
2cd9d2ba |
753 | |
754 | |
755 | /* these functions call Perl-space for MOP methods, helpers etc */ |
756 | |
757 | |
758 | /* wow, so much code for the equivalent of |
759 | * $attr->associated_class->get_meta_instance */ |
f253044f |
760 | STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) { |
761 | dSP; |
762 | I32 count; |
763 | SV *mi; |
764 | |
765 | if ( !meta_attr ) |
766 | croak("No attr found in magic!"); |
767 | |
768 | ENTER; |
769 | SAVETMPS; |
770 | PUSHMARK(SP); |
2cd9d2ba |
771 | |
f253044f |
772 | XPUSHs(meta_attr); |
2cd9d2ba |
773 | |
f253044f |
774 | PUTBACK; |
775 | count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR); |
776 | |
777 | if ( count != 1 ) |
778 | croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count); |
779 | |
780 | SPAGAIN; |
781 | mi = POPs; |
782 | |
783 | SvREFCNT_inc(mi); |
784 | |
785 | PUTBACK; |
786 | FREETMPS; |
787 | LEAVE; |
788 | |
fe0194bf |
789 | return sv_2mortal(mi); |
f253044f |
790 | } |
791 | |
2cd9d2ba |
792 | /* gets a class and an array of attr parameters */ |
f253044f |
793 | STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) { |
794 | dSP; |
795 | I32 count; |
2cd9d2ba |
796 | SV *mi; |
f253044f |
797 | SV *class; |
798 | SV *attrs; |
799 | HV *stash; |
800 | |
801 | ENTER; |
802 | SAVETMPS; |
803 | PUSHMARK(SP); |
2cd9d2ba |
804 | |
f253044f |
805 | XPUSHs(perl_mi); |
2cd9d2ba |
806 | |
f253044f |
807 | PUTBACK; |
808 | count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY); |
809 | |
810 | if ( count != 2 ) |
811 | croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count); |
812 | |
813 | SPAGAIN; |
814 | attrs = POPs; |
815 | class = POPs; |
816 | |
817 | PUTBACK; |
818 | |
819 | stash = gv_stashsv(class, 0); |
820 | |
821 | mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs)); |
2cd9d2ba |
822 | SvREFCNT_inc(mi); |
f253044f |
823 | |
824 | FREETMPS; |
825 | LEAVE; |
826 | |
2cd9d2ba |
827 | return sv_2mortal(mi); |
f253044f |
828 | } |
829 | |
2cd9d2ba |
830 | |
831 | |
832 | /* locate an ATTR for a MOP level attribute inside an MI */ |
833 | STATIC ATTR *mi_find_attr(SV *mi_obj, SV *meta_attr) { |
f253044f |
834 | I32 ix; |
2cd9d2ba |
835 | MI *mi = INT2PTR(MI *, SvIV(SvRV(mi_obj))); |
f253044f |
836 | |
035fd0c4 |
837 | for ( ix = 0; ix < mi->num_attrs; ix++ ) { |
f253044f |
838 | if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) { |
839 | return &mi->attrs[ix]; |
de2f2e97 |
840 | } |
de2f2e97 |
841 | } |
842 | |
2cd9d2ba |
843 | croak("Attr %x not found in meta instance of %s", SvRV(meta_attr) /* SvPV_force_nomg(sv_2mortal(newSVsv(meta_attr))) */, HvNAME_get(mi->stash) ); |
de2f2e97 |
844 | return NULL; |
845 | } |
846 | |
2cd9d2ba |
847 | /* returns the ATTR for a CV: |
848 | * |
849 | * 1. get the Moose::Meta::Attribute using get_stashed_in_mg from the CV itself |
850 | * 2. get the meta instance by calling $attr->associated_class->get_meta_instance |
851 | * 3. get the MI by using get_stashed_in_mg from the meta instance, creating it if necessary |
852 | * 4. search for the appropriate ATTR in the MI using mi_find_attr |
853 | */ |
de2f2e97 |
854 | STATIC ATTR *get_attr(pTHX_ CV *cv) { |
f253044f |
855 | SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv); |
856 | SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr); |
2cd9d2ba |
857 | SV *mi_obj = get_stashed_in_mg(aTHX_ SvRV(perl_mi)); |
de2f2e97 |
858 | |
2cd9d2ba |
859 | if (!mi_obj) { |
860 | mi_obj = perl_mi_to_c_mi(aTHX_ perl_mi); |
861 | stash_in_mg(aTHX_ SvRV(perl_mi), mi_obj); |
f253044f |
862 | } |
863 | |
2cd9d2ba |
864 | return mi_find_attr(mi_obj, meta_attr); |
1ea12c91 |
865 | } |
866 | |
2cd9d2ba |
867 | /* Cache a pointer to the appropriate ATTR in the XSANY of the CV, using |
868 | * get_attr */ |
de2f2e97 |
869 | STATIC ATTR *define_attr (pTHX_ CV *cv) { |
870 | ATTR *attr = get_attr(aTHX_ cv); |
871 | assert(attr); |
872 | |
873 | XSANY.any_i32 = PTR2IV(attr); |
f253044f |
874 | |
7ce1a351 |
875 | SvREFCNT_inc(cv); |
f253044f |
876 | av_push( attr->cvs, (SV *)cv ); |
de2f2e97 |
877 | |
878 | return attr; |
879 | } |
880 | |
2cd9d2ba |
881 | |
882 | |
883 | |
884 | |
885 | |
886 | |
de2f2e97 |
887 | STATIC void weaken(pTHX_ SV *sv) { |
1ea12c91 |
888 | #ifdef SvWEAKREF |
de2f2e97 |
889 | sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */ |
1ea12c91 |
890 | #else |
891 | croak("weak references are not implemented in this release of perl"); |
892 | #endif |
893 | } |
894 | |
895 | |
2cd9d2ba |
896 | |
897 | |
898 | |
899 | |
1ea12c91 |
900 | /* meta instance protocol */ |
901 | |
de2f2e97 |
902 | STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) { |
1ea12c91 |
903 | HE *he; |
904 | |
905 | assert(self); |
906 | assert(SvROK(self)); |
907 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
908 | |
de2f2e97 |
909 | assert( ATTR_DUMB_INSTANCE(attr) ); |
910 | |
911 | if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32))) |
1ea12c91 |
912 | return HeVAL(he); |
913 | else |
914 | return NULL; |
915 | } |
916 | |
de2f2e97 |
917 | STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) { |
1ea12c91 |
918 | HE *he; |
4c6fbfb1 |
919 | SV *copy; |
1ea12c91 |
920 | |
921 | assert(self); |
922 | assert(SvROK(self)); |
923 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
924 | |
de2f2e97 |
925 | assert( ATTR_DUMB_INSTANCE(attr) ); |
926 | |
4c6fbfb1 |
927 | copy = newSVsv(value); |
928 | |
929 | he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32); |
1ea12c91 |
930 | |
1ea12c91 |
931 | if (he != NULL) { |
de2f2e97 |
932 | if ( ATTR_ISWEAK(attr) ) |
4c6fbfb1 |
933 | weaken(aTHX_ HeVAL(he)); |
1ea12c91 |
934 | } else { |
4c6fbfb1 |
935 | SvREFCNT_dec(copy); |
1ea12c91 |
936 | croak("Hash store failed."); |
937 | } |
938 | } |
939 | |
de2f2e97 |
940 | STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) { |
1ea12c91 |
941 | assert(self); |
942 | assert(SvROK(self)); |
943 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
944 | |
de2f2e97 |
945 | assert( ATTR_DUMB_INSTANCE(attr) ); |
946 | |
947 | return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32); |
948 | } |
949 | |
950 | STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) { |
951 | assert(self); |
952 | assert(SvROK(self)); |
953 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
954 | |
955 | assert( ATTR_DUMB_INSTANCE(attr) ); |
956 | |
957 | return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32); |
1ea12c91 |
958 | } |
959 | |
fe0194bf |
960 | |
961 | |
fe0194bf |
962 | |
fe0194bf |
963 | |
fe0194bf |
964 | |
2cd9d2ba |
965 | /* Shared functionality for readers/writers/accessors, this roughly corresponds |
966 | * to the methods of Moose::Meta::Attribute on the instance |
967 | * (get_value/set_value, default value handling, etc) */ |
fe0194bf |
968 | |
2cd9d2ba |
969 | STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value); |
fe0194bf |
970 | |
2cd9d2ba |
971 | STATIC SV *call_builder (pTHX_ SV *self, ATTR *attr) { |
972 | SV *sv; |
973 | dSP; |
fe0194bf |
974 | |
2cd9d2ba |
975 | ENTER; |
976 | SAVETMPS; |
977 | PUSHMARK(SP); |
978 | |
979 | XPUSHs(self); |
980 | |
981 | /* we invoke the builder as a stringified method. This will not work for |
982 | * $obj->$coderef etc, for that we need to use 'default' */ |
983 | PUTBACK; |
984 | call_method(SvPV_nolen(attr->def.sv), G_SCALAR); |
985 | SPAGAIN; |
986 | |
987 | /* the value is a mortal with a refcount of 1, so we need to keep it around */ |
988 | sv = POPs; |
989 | SvREFCNT_inc(sv); |
990 | |
991 | PUTBACK; |
992 | FREETMPS; |
993 | LEAVE; |
994 | |
995 | return sv_2mortal(sv); |
996 | } |
997 | |
998 | |
999 | /* Returns an SV for the default value. Should be copied by the caller because |
1000 | * it's either an alias for a simple value, or a mortal from cv/builder */ |
1001 | STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) { |
1002 | switch ( ATTR_DEFAULT(attr) ) { |
1003 | case default_none: |
1004 | return NULL; |
1005 | break; |
1006 | case default_builder: |
1007 | return call_builder(aTHX_ self, attr); |
fe0194bf |
1008 | break; |
1009 | case default_normal: |
1010 | if ( SvROK(attr->def.sv) ) { |
1011 | printf("CV default\n"); |
2cd9d2ba |
1012 | croak("todo"); |
fe0194bf |
1013 | } else { |
1014 | printf("simple value\n"); |
1015 | return attr->def.sv; /* will be copied by set for lazy, and by reader for both cases */ |
1016 | } |
1017 | break; |
fe0194bf |
1018 | case default_type: |
1019 | croak("todo"); |
1020 | break; |
1021 | } |
1022 | |
1023 | return NULL; |
1024 | } |
1025 | |
2cd9d2ba |
1026 | /* $attr->get_value($self), will vivify lazy values if needed |
1027 | * returns an alias to the sv that is copied in the reader/writer/accessor code |
1028 | * */ |
1029 | STATIC SV *attr_get_value(pTHX_ SV *self, ATTR *attr) { |
fe0194bf |
1030 | SV *value = get_slot_value(aTHX_ self, attr); |
1031 | |
1032 | if ( value ) { |
1033 | return value; |
1034 | } else if ( ATTR_ISLAZY(attr) ) { |
1035 | value = get_default(aTHX_ self, attr); |
2cd9d2ba |
1036 | attr_set_value(aTHX_ self, attr, value); |
fe0194bf |
1037 | return value; |
1038 | } |
1039 | |
1040 | return NULL; |
160f9ca7 |
1041 | } |
1042 | |
2cd9d2ba |
1043 | /* $attr->set_value($self) */ |
1044 | STATIC void attr_set_value(pTHX_ SV *self, ATTR *attr, SV *value) { |
fe0194bf |
1045 | if ( ATTR_TYPE(attr) ) { |
1046 | if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) ) |
160f9ca7 |
1047 | croak("Bad param"); |
1048 | } |
1049 | |
1050 | set_slot_value(aTHX_ self, attr, value); |
1051 | } |
1ea12c91 |
1052 | |
2cd9d2ba |
1053 | |
1054 | |
1055 | |
1056 | |
1057 | |
1058 | |
1059 | /* Perl-space level functionality |
1060 | * |
1061 | * These subs are installed by new_sub's various aliases as the bodies of the |
1062 | * new XSUBs |
1063 | * */ |
1064 | |
1065 | |
1066 | |
1067 | /* This macro is used in the XS subs to set up the 'attr' variable. |
1068 | * |
1069 | * if XSANY is NULL then define_attr is called on the CV, to set the pointer |
1070 | * to the ATTR struct. |
1071 | * */ |
1072 | #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv)) |
1073 | |
1ea12c91 |
1074 | |
24a7a8c5 |
1075 | STATIC XS(reader); |
1076 | STATIC XS(reader) |
1ea12c91 |
1077 | { |
1078 | #ifdef dVAR |
1079 | dVAR; |
1080 | #endif |
1081 | dXSARGS; |
de2f2e97 |
1082 | dATTR; |
1ea12c91 |
1083 | SV *value; |
1084 | |
1085 | if (items != 1) |
1086 | Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); |
1087 | |
1088 | SP -= items; |
1089 | |
2cd9d2ba |
1090 | value = attr_get_value(aTHX_ ST(0), attr); |
1ea12c91 |
1091 | |
1092 | if (value) { |
1093 | ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */ |
1094 | XSRETURN(1); |
1095 | } else { |
1096 | XSRETURN_UNDEF; |
1097 | } |
1098 | } |
1099 | |
24a7a8c5 |
1100 | STATIC XS(writer); |
1101 | STATIC XS(writer) |
1ea12c91 |
1102 | { |
1103 | #ifdef dVAR |
1104 | dVAR; |
1105 | #endif |
1106 | dXSARGS; |
de2f2e97 |
1107 | dATTR; |
1ea12c91 |
1108 | |
1109 | if (items != 2) |
1110 | Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value"); |
1111 | |
1112 | SP -= items; |
1113 | |
2cd9d2ba |
1114 | attr_set_value(aTHX_ ST(0), attr, ST(1)); |
1ea12c91 |
1115 | |
1116 | ST(0) = ST(1); /* return value */ |
1117 | XSRETURN(1); |
1118 | } |
1119 | |
de2f2e97 |
1120 | STATIC XS(accessor); |
1121 | STATIC XS(accessor) |
1ea12c91 |
1122 | { |
1123 | #ifdef dVAR |
1124 | dVAR; |
1125 | #endif |
1126 | dXSARGS; |
de2f2e97 |
1127 | dATTR; |
1ea12c91 |
1128 | |
1129 | if (items < 1) |
1130 | Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value"); |
1131 | |
1132 | SP -= items; |
1133 | |
1134 | if (items > 1) { |
2cd9d2ba |
1135 | attr_set_value(aTHX_ ST(0), attr, ST(1)); |
1ea12c91 |
1136 | ST(0) = ST(1); /* return value */ |
1137 | } else { |
2cd9d2ba |
1138 | SV *value = attr_get_value(aTHX_ ST(0), attr); |
1ea12c91 |
1139 | if ( value ) { |
1140 | ST(0) = value; |
1141 | } else { |
1142 | XSRETURN_UNDEF; |
1143 | } |
1144 | } |
1145 | |
1146 | XSRETURN(1); |
1147 | } |
1148 | |
1149 | STATIC XS(predicate); |
1150 | STATIC XS(predicate) |
1151 | { |
1152 | #ifdef dVAR |
1153 | dVAR; |
1154 | #endif |
1155 | dXSARGS; |
de2f2e97 |
1156 | dATTR; |
1ea12c91 |
1157 | |
1158 | if (items != 1) |
1159 | Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); |
1160 | |
1161 | SP -= items; |
1162 | |
de2f2e97 |
1163 | if ( has_slot_value(aTHX_ ST(0), attr) ) |
1ea12c91 |
1164 | XSRETURN_YES; |
1165 | else |
1166 | XSRETURN_NO; |
1167 | } |
1168 | |
1169 | enum xs_body { |
24a7a8c5 |
1170 | xs_body_reader = 0, |
1171 | xs_body_writer, |
de2f2e97 |
1172 | xs_body_accessor, |
1ea12c91 |
1173 | xs_body_predicate, |
1174 | max_xs_body |
1175 | }; |
1176 | |
1177 | STATIC XSPROTO ((*xs_bodies[])) = { |
24a7a8c5 |
1178 | reader, |
1179 | writer, |
de2f2e97 |
1180 | accessor, |
1ea12c91 |
1181 | predicate, |
1182 | }; |
1183 | |
1184 | MODULE = Moose PACKAGE = Moose::XS |
4e783f63 |
1185 | PROTOTYPES: ENABLE |
1ea12c91 |
1186 | |
1187 | CV * |
de2f2e97 |
1188 | new_sub(attr, name) |
1ea12c91 |
1189 | INPUT: |
de2f2e97 |
1190 | SV *attr; |
1191 | SV *name; |
4e783f63 |
1192 | PROTOTYPE: $;$ |
1ea12c91 |
1193 | ALIAS: |
24a7a8c5 |
1194 | new_reader = xs_body_reader |
1195 | new_writer = xs_body_writer |
de2f2e97 |
1196 | new_accessor = xs_body_accessor |
1197 | new_predicate = xs_body_predicate |
1ea12c91 |
1198 | PREINIT: |
1199 | CV * cv; |
1200 | CODE: |
1201 | if ( ix >= max_xs_body ) |
1202 | croak("Unknown Moose::XS body type"); |
1203 | |
de2f2e97 |
1204 | if ( !sv_isobject(attr) ) |
1205 | croak("'attr' must be a Moose::Meta::Attribute"); |
1206 | |
1207 | cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__); |
1ea12c91 |
1208 | |
1209 | if (cv == NULL) |
1210 | croak("Oi vey!"); |
1211 | |
de2f2e97 |
1212 | /* associate CV with meta attr */ |
f253044f |
1213 | stash_in_mg(aTHX_ (SV *)cv, attr); |
de2f2e97 |
1214 | |
1215 | /* this will be set on first call */ |
1216 | XSANY.any_i32 = 0; |
1ea12c91 |
1217 | |
1218 | RETVAL = cv; |
1219 | OUTPUT: |
1220 | RETVAL |
1221 | |
1222 | |
f253044f |
1223 | MODULE = Moose PACKAGE = Moose::XS::Meta::Instance |
4e783f63 |
1224 | PROTOTYPES: DISABLE |
f253044f |
1225 | |
1226 | void |
1227 | DESTROY(self) |
1228 | INPUT: |
1229 | SV *self; |
1230 | PREINIT: |
1231 | MI *mi = INT2PTR(MI *, SvIV(SvRV(self))); |
1232 | CODE: |
2cd9d2ba |
1233 | if ( mi ) |
1234 | delete_mi(aTHX_ mi); |
1235 | |
3c63e75d |
1236 | |
1237 | MODULE = Moose PACKAGE = Moose::XS::TypeConstraints |
1238 | PROTOTYPES: ENABLE |
1239 | |
1240 | bool |
1241 | _check_type(sv) |
1242 | INPUT: |
1243 | SV* sv |
1244 | ALIAS: |
1245 | Any = Any |
1246 | Item = Any |
1247 | Bool = Any |
1248 | Undef = Undef |
1249 | Defined = Defined |
1250 | Str = Str |
1251 | Value = Str |
1252 | Num = Num |
1253 | Int = Int |
1254 | GlobRef = GlobRef |
1255 | ArrayRef = ArrayRef |
1256 | HashRef = HashRef |
1257 | CodeRef = CodeRef |
1258 | Ref = Ref |
1259 | ScalarRef = ScalarRef |
1260 | FileHandle = FileHandle |
1261 | RegexpRef = RegexpRef |
1262 | Object = Object |
1263 | Role = Role |
1264 | ClassName = ClassName |
1265 | CODE: |
1266 | RETVAL = check_sv_type(ix, sv); |
1267 | OUTPUT: |
1268 | RETVAL |
1269 | |
1270 | bool |
1271 | ObjectOfType(sv, class) |
1272 | INPUT: |
1273 | SV* sv |
1274 | SV* class |
1275 | PREINIT: |
1276 | HV *stash = gv_stashsv(class, 0); |
1277 | CODE: |
1278 | RETVAL = check_sv_class(aTHX_ stash, sv); |
1279 | OUTPUT: |
1280 | RETVAL |