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 | * type constraints are already implemented by konobi |
20 | * should be trivial to do coercions for the core types, too |
21 | * |
22 | * TypeConstraint::Class can compare SvSTASH by ptr, and if it's neq *then* |
23 | * call ->isa (should handle vast majority of cases) |
24 | * |
25 | * base parametrized types are also trivial |
26 | * |
27 | * ClassName is get_stathpvn |
28 | */ |
29 | |
30 | /* FIXME |
de2f2e97 |
31 | * for a constructor we have ATTR *attrs, and iterate that, removing init_arg |
1ea12c91 |
32 | * we can preallocate the structure to the right size (maybe even with the |
33 | * right HEs?), and do various other prehashing hacks to gain speed |
34 | * */ |
35 | |
36 | /* FIXME |
37 | * delegations and attribute helpers: |
38 | * |
39 | * typedef struct { |
de2f2e97 |
40 | * ATTR *attr; |
1ea12c91 |
41 | * pv *method; |
42 | * } delegation; |
43 | * |
44 | * typedef struct { |
de2f2e97 |
45 | * ATTR *attr; |
1ea12c91 |
46 | * I32 *type; // hash, array, whatever + vtable for operation |
47 | * } attributehelper; |
48 | */ |
49 | |
de2f2e97 |
50 | |
51 | STATIC MGVTBL null_mg_vtbl = { |
52 | NULL, /* get */ |
53 | NULL, /* set */ |
54 | NULL, /* len */ |
55 | NULL, /* clear */ |
56 | NULL, /* free */ |
57 | #if MGf_COPY |
58 | NULL, /* copy */ |
59 | #endif /* MGf_COPY */ |
60 | #if MGf_DUP |
61 | NULL, /* dup */ |
62 | #endif /* MGf_DUP */ |
63 | #if MGf_LOCAL |
64 | NULL, /* local */ |
65 | #endif /* MGf_LOCAL */ |
66 | }; |
67 | |
f253044f |
68 | STATIC MAGIC *stash_in_mg (pTHX_ SV *sv, SV *obj) { |
69 | MAGIC *mg = sv_magicext(sv, obj, PERL_MAGIC_ext, &null_mg_vtbl, NULL, 0 ); |
70 | mg->mg_flags |= MGf_REFCOUNTED; |
71 | |
72 | return mg; |
73 | } |
74 | |
75 | STATIC SV *get_stashed_in_mg(pTHX_ SV *sv) { |
76 | MAGIC *mg, *moremagic; |
77 | |
78 | if (SvTYPE(sv) >= SVt_PVMG) { |
79 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { |
80 | if ((mg->mg_type == PERL_MAGIC_ext) && (mg->mg_virtual == &null_mg_vtbl)) |
81 | break; |
82 | } |
83 | if (mg) |
84 | return mg->mg_obj; |
85 | } |
86 | |
87 | return NULL; |
88 | } |
de2f2e97 |
89 | |
4c6fbfb1 |
90 | /* this is a enum of checks */ |
de2f2e97 |
91 | typedef enum { |
4c6fbfb1 |
92 | Any, /* or item, or bool */ |
93 | Undef, |
94 | Defined, |
95 | Str, /* or value */ |
96 | Num, |
97 | Int, |
98 | GlobRef, /* SVt_PVGV */ |
99 | ArrayRef, /* SVt_PVAV */ |
100 | HashRef, /* SVt_PVHV */ |
101 | CodeRef, /* SVt_PVCV */ |
102 | Ref, |
103 | ScalarRef, |
104 | FileHandle, |
105 | RegexpRef, |
106 | Object, |
160f9ca7 |
107 | ClassName, |
4c6fbfb1 |
108 | /* complex checks */ |
109 | Role, |
4c6fbfb1 |
110 | Enum, |
de2f2e97 |
111 | } TC; |
112 | |
de2f2e97 |
113 | typedef enum { |
114 | tc_none = 0, |
115 | tc_type, |
160f9ca7 |
116 | tc_stash, |
de2f2e97 |
117 | tc_cv, |
de2f2e97 |
118 | tc_op, |
4c6fbfb1 |
119 | tc_fptr, |
de2f2e97 |
120 | } tc_kind; |
121 | |
122 | typedef union { |
4c6fbfb1 |
123 | TC type; |
160f9ca7 |
124 | HV *stash; |
4c6fbfb1 |
125 | CV *cv; |
126 | OP *op; |
4c6fbfb1 |
127 | bool (*fptr)(pTHX_ SV *type_constraint, SV *sv); |
128 | } TC_CHECK; |
129 | |
130 | typedef union { |
de2f2e97 |
131 | char *builder; |
132 | SV *value; |
133 | CV *sub; |
134 | OP *op; |
135 | U32 type; |
136 | } DEFAULT; |
137 | |
138 | typedef enum { |
139 | default_none = 0, |
140 | default_type, |
141 | default_builder, |
142 | default_value, |
143 | default_sub, |
144 | default_op, |
145 | } default_kind; |
146 | |
1ea12c91 |
147 | typedef struct { |
de2f2e97 |
148 | /* the meta instance struct */ |
149 | struct mi *mi; |
150 | |
151 | U32 flags; /* slot type, TC behavior, coerce, weaken, (no default | default, builder + lazy), auto_deref */ |
152 | |
153 | /* slot access fields */ |
154 | SV *slot_sv; /* value of the slot (slot name presumably) */ |
155 | U32 slot_u32; /* for optimized access (precomputed hash or otherr) */ |
156 | |
157 | DEFAULT def; /* cv, value or other, depending on flags */ |
158 | |
159 | TC_CHECK tc_check; /* cv, value or other, dependidng on flags */ |
160 | SV *type_constraint; /* meta attr */ |
161 | |
162 | CV *initializer; |
163 | CV *trigger; |
164 | |
f253044f |
165 | SV *meta_attr; /* the meta attr object */ |
de2f2e97 |
166 | AV *cvs; /* CVs which use this attr */ |
167 | } ATTR; |
168 | |
169 | /* slot flags: |
170 | * instance reading writing |
171 | * 00000000 00000000 00000000 00000000 |
172 | * ^ trigger |
173 | * ^ weak |
174 | * ^^^ tc_kind |
175 | * ^ coerce |
176 | * ^^^ default_kind |
177 | * ^ lazy |
178 | * ^ required |
179 | * ^^^^^^^ if 0 then nothing special (just hash)? FIXME TBD |
180 | */ |
181 | |
182 | #define ATTR_INSTANCE_MASK 0xff000000 |
183 | #define ATTR_READING_MASK 0x0000ff00 |
184 | #define ATTR_WRITING_MASK 0x000000ff |
185 | |
186 | #define ATTR_MASK_TYPE 0x7 |
187 | |
188 | #define ATTR_MASK_DEFAULT 0x700 |
189 | #define ATTR_SHIFT_DEAFULT 8 |
190 | |
191 | #define ATTR_LAZY 0x800 |
192 | |
193 | #define ATTR_COERCE 0x08 |
194 | #define ATTR_WEAK 0x10 |
195 | #define ATTR_TRIGGER 0x10 |
196 | |
197 | #define ATTR_ISWEAK(attr) ( attr->flags & ATTR_WEAK ) |
198 | #define ATTR_ISLAZY(attr) ( attr->flags & ATTR_LAZY ) |
199 | #define ATTR_ISCOERCE(attr) ( attr->flags & ATTR_COERCE ) |
1ea12c91 |
200 | |
de2f2e97 |
201 | #define ATTR_TYPE(f) ( attr->flags & 0x7 ) |
202 | #define ATTR_DEFAULT(f) ( ( attr->flags & ATTR_MASK_DEFAULT ) >> ATTR_SHIFT_DEFAULT ) |
1ea12c91 |
203 | |
de2f2e97 |
204 | #define ATTR_DUMB_READER(attr) !ATTR_IS_LAZY(attr) |
205 | #define ATTR_DUMB_WRITER(attr) ( ( attr->flags & ATTR_WRITING_MASK ) == 0 ) |
206 | #define ATTR_DUMB_INSTANCE(attr) ( ( attr->flags & ATTR_INSTANCE_MASK ) == 0 ) |
1ea12c91 |
207 | |
f253044f |
208 | #define dATTR ATTR *attr = (XSANY.any_i32 ? INT2PTR(ATTR *, (XSANY.any_i32)) : define_attr(aTHX_ cv)) |
de2f2e97 |
209 | |
210 | |
211 | /* FIXME define a vtable that does call_sv */ |
212 | typedef struct { |
213 | SV * (*get)(pTHX_ SV *self, ATTR *attr); |
214 | void (*set)(pTHX_ SV *self, ATTR *attr, SV *value); |
215 | bool * (*has)(pTHX_ SV *self, ATTR *attr); |
216 | SV * (*delete)(pTHX_ SV *self, ATTR *attr); |
217 | } instance_vtbl; |
218 | |
219 | |
220 | typedef enum { |
221 | hash = 0, |
222 | |
223 | /* these are not yet implemented */ |
224 | array, |
225 | fptr, |
226 | cv, |
227 | judy, |
228 | } instance_types; |
229 | |
230 | typedef struct mi { |
de2f2e97 |
231 | HV *stash; |
232 | |
233 | /* slot access method */ |
234 | instance_types type; |
235 | instance_vtbl *vtbl; |
236 | |
237 | /* attr descriptors */ |
238 | I32 num_attrs; |
239 | ATTR *attrs; |
240 | } MI; |
241 | |
242 | |
4c6fbfb1 |
243 | |
244 | |
245 | STATIC bool check_is_scalar_ref(SV *sv) { |
246 | if( SvROK(sv) ) { |
247 | switch (SvTYPE(SvRV(sv))) { |
248 | case SVt_IV: |
249 | case SVt_NV: |
250 | case SVt_PV: |
251 | case SVt_NULL: |
252 | return 1; |
253 | break; |
254 | default: |
255 | return 0; |
256 | } |
257 | } |
258 | return 0; |
259 | } |
260 | |
261 | STATIC bool check_reftype(TC type, SV *sv) { |
262 | int svt; |
263 | |
264 | if ( !SvROK(sv) ) |
265 | return 0; |
266 | |
267 | switch (type) { |
268 | case GlobRef: |
269 | svt = SVt_PVGV; |
270 | break; |
271 | case ArrayRef: |
272 | svt = SVt_PVAV; |
273 | break; |
274 | case HashRef: |
275 | svt = SVt_PVHV; |
276 | break; |
277 | case CodeRef: |
278 | svt = SVt_PVCV; |
279 | break; |
280 | } |
281 | |
160f9ca7 |
282 | return SvTYPE(SvRV(sv)) == svt; |
4c6fbfb1 |
283 | } |
284 | |
285 | STATIC bool check_sv_class (pTHX_ HV *stash, SV *sv) { |
286 | dSP; |
287 | bool ret; |
288 | |
289 | if (!sv) |
290 | return 0; |
291 | SvGETMAGIC(sv); |
292 | if (!SvROK(sv)) |
293 | return 0; |
294 | sv = (SV*)SvRV(sv); |
295 | if (!SvOBJECT(sv)) |
296 | return 0; |
297 | if (SvSTASH(sv) == stash) |
298 | return 1; |
299 | |
300 | ENTER; |
301 | SAVETMPS; |
302 | PUSHMARK(SP); |
303 | XPUSHs(sv); |
304 | XPUSHs(newSVpv(HvNAME_get(SvSTASH(sv)), 0)); |
305 | PUTBACK; |
306 | |
307 | call_method("isa", G_SCALAR); |
308 | |
309 | SPAGAIN; |
310 | ret = SvTRUE(TOPs); |
311 | |
312 | FREETMPS; |
313 | LEAVE; |
314 | |
315 | return ret; |
316 | } |
317 | |
318 | STATIC bool check_sv_type (TC type, SV *sv) { |
319 | if (!sv) |
320 | return 0; |
160f9ca7 |
321 | |
4c6fbfb1 |
322 | switch (type) { |
323 | case Any: |
324 | return 1; |
325 | break; |
326 | case Undef: |
327 | return !SvOK(sv); |
328 | break; |
329 | case Defined: |
330 | return SvOK(sv); |
331 | break; |
332 | case Str: |
333 | return (SvOK(sv) && !SvROK(sv)); |
160f9ca7 |
334 | case Num: |
335 | #if (PERL_VERSION < 8) || (PERL_VERSION == 8 && PERL_SUBVERSION <5) |
336 | if (!SvPOK(sv) && !SvPOKp(sv)) |
337 | return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); |
338 | else |
339 | #endif |
340 | return looks_like_number(sv); |
341 | break; |
342 | case Int: |
343 | if ( SvIOK(sv) ) { |
344 | return 1; |
345 | } else if ( SvPOK(sv) ) { |
346 | croak("todo"); |
347 | int i; |
348 | STRLEN len; |
349 | char *pv = SvPV(sv, len); |
350 | char *end = pv + len; |
351 | |
352 | errno = 0; |
353 | i = strtol(pv, &end, 0); |
354 | return !errno; |
355 | } |
356 | return 0; |
357 | break; |
4c6fbfb1 |
358 | case Ref: |
359 | return SvROK(sv); |
360 | break; |
361 | case ScalarRef: |
362 | return check_is_scalar_ref(sv); |
363 | break; |
364 | case ArrayRef: |
365 | case HashRef: |
366 | case CodeRef: |
367 | case GlobRef: |
368 | return check_reftype(type, sv); |
369 | break; |
370 | case Object: |
371 | return sv_isobject(sv); |
372 | break; |
160f9ca7 |
373 | case ClassName: |
374 | { |
375 | STRLEN len; |
376 | char *pv; |
377 | pv = SvPV(sv, len); |
378 | return ( gv_stashpvn(pv, len, 0) != NULL ); |
379 | break; |
380 | } |
4c6fbfb1 |
381 | case RegexpRef: |
382 | return sv_isa(sv, "Regexp"); |
383 | break; |
384 | case FileHandle: |
385 | croak("todo"); |
386 | break; |
387 | default: |
388 | croak("todo"); |
389 | } |
390 | |
391 | return 0; |
392 | } |
393 | |
160f9ca7 |
394 | STATIC bool check_type_constraint(pTHX_ tc_kind kind, TC_CHECK tc_check, SV *type_constraint, SV *sv) { |
4c6fbfb1 |
395 | switch (kind) { |
396 | case tc_none: |
397 | return 1; |
398 | break; |
399 | case tc_type: |
400 | return check_sv_type(tc_check.type, sv); |
401 | break; |
402 | case tc_stash: |
a812574b |
403 | return check_sv_class(aTHX_ tc_check.stash, sv); |
4c6fbfb1 |
404 | break; |
4c6fbfb1 |
405 | case tc_fptr: |
406 | return tc_check.fptr(aTHX_ type_constraint, sv); |
407 | break; |
408 | case tc_cv: |
409 | case tc_op: |
410 | croak("todo"); |
411 | break; |
412 | } |
413 | |
414 | croak("todo"); |
415 | return 0; |
416 | } |
417 | |
418 | |
160f9ca7 |
419 | STATIC void init_attr (MI *mi, ATTR *attr, AV *desc) { |
420 | U32 flags = 0; |
1ea12c91 |
421 | U32 hash; |
422 | STRLEN len; |
de2f2e97 |
423 | char *pv; |
160f9ca7 |
424 | I32 ix = av_len(desc); |
425 | SV **params = AvARRAY(desc); |
426 | SV *tc; |
427 | SV *key; |
de2f2e97 |
428 | |
429 | attr->mi = mi; |
430 | |
de2f2e97 |
431 | |
160f9ca7 |
432 | if ( ix != 12 ) |
433 | croak("wrong number of args (%d != 13)", ix + 1); |
de2f2e97 |
434 | |
160f9ca7 |
435 | for ( ; ix >= 0; ix-- ) { |
436 | if ( !params[ix] || params[ix] == &PL_sv_undef ) |
437 | croak("bad params"); |
438 | } |
439 | |
440 | if ( !SvROK(params[1]) || SvTYPE(SvRV(params[1])) != SVt_PVAV ) |
441 | croak("slots is not an array"); |
de2f2e97 |
442 | |
160f9ca7 |
443 | if ( av_len((AV *)SvRV(params[1])) != 0 ) |
444 | croak("Only unary slots are supported at the moment"); |
1ea12c91 |
445 | |
160f9ca7 |
446 | /* calculate a hash from the slot */ |
447 | /* FIXME arrays etc should also be supported */ |
448 | key = *av_fetch((AV *)SvRV(params[1]), 0, 0); |
449 | pv = SvPV(key, len); |
1ea12c91 |
450 | PERL_HASH(hash, pv, len); |
1ea12c91 |
451 | |
de2f2e97 |
452 | |
160f9ca7 |
453 | /* FIXME better organize these */ |
454 | if ( SvTRUE(params[2]) ) |
455 | flags |= ATTR_WEAK; |
456 | |
457 | if ( SvTRUE(params[3]) ) |
458 | flags |= ATTR_COERCE; |
de2f2e97 |
459 | |
160f9ca7 |
460 | if ( SvTRUE(params[4]) ) |
461 | flags |= ATTR_LAZY; |
de2f2e97 |
462 | |
160f9ca7 |
463 | tc = params[5]; |
de2f2e97 |
464 | |
160f9ca7 |
465 | if ( SvOK(tc) ) { |
466 | int tc_kind = SvIV(params[6]); |
467 | SV *data = params[7]; |
468 | |
469 | switch (tc_kind) { |
470 | case tc_stash: |
471 | attr->tc_check.stash = gv_stashsv(data, 0); |
472 | break; |
473 | case tc_type: |
474 | attr->tc_check.type = SvIV(data); |
475 | break; |
476 | case tc_cv: |
477 | attr->tc_check.cv = (CV *)SvRV(data); |
478 | if ( SvTYPE(attr->tc_check.cv) != SVt_PVCV ) |
479 | croak("compiled type constraint is not a coderef"); |
480 | break; |
481 | default: |
482 | croak("todo"); |
483 | } |
484 | |
485 | flags |= tc_kind; |
486 | } |
487 | |
488 | attr->flags = flags; /* FIXME default_kind */ |
489 | |
490 | attr->trigger = SvROK(params[6]) ? (CV *)SvRV(params[6]) : NULL; |
491 | if ( attr->trigger && SvTYPE(attr->trigger) != SVt_PVCV ) |
492 | croak("trigger is not a coderef"); |
493 | |
494 | attr->initializer = SvROK(params[7]) ? (CV *)SvRV(params[7]) : NULL; |
495 | if ( attr->initializer && SvTYPE(attr->initializer) != SVt_PVCV ) |
496 | croak("initializer is not a coderef"); |
497 | |
498 | /* copy refs */ |
499 | attr->meta_attr = newSVsv(params[0]); |
500 | attr->type_constraint = newSVsv(tc); |
501 | if ( attr->trigger ) SvREFCNT_inc(attr->trigger); |
502 | if ( attr->initializer ) SvREFCNT_inc(attr->initializer); |
503 | |
504 | attr->slot_sv = newSVpvn_share(pv, len, hash); |
505 | attr->slot_u32 = hash; |
506 | |
507 | attr->def.type = 0; |
de2f2e97 |
508 | |
509 | /* cross refs to CVs which use this struct */ |
510 | attr->cvs = newAV(); |
511 | } |
512 | |
f253044f |
513 | STATIC MI *new_mi (pTHX_ HV *stash, AV *attrs) { |
de2f2e97 |
514 | MI *mi; |
515 | I32 ix; |
516 | const I32 num = av_len(attrs) + 1; |
517 | |
518 | Newx(mi, 1, MI); |
519 | |
520 | SvREFCNT_inc_simple(stash); |
521 | mi->stash = stash; |
522 | |
de2f2e97 |
523 | mi->type = 0; /* nothing else implemented yet */ |
524 | |
525 | /* initialize attributes */ |
526 | mi->num_attrs = num; |
527 | Newx(mi->attrs, num, ATTR); |
f253044f |
528 | for ( ix = 0; ix < num; ix++ ) { |
de2f2e97 |
529 | SV **desc = av_fetch(attrs, ix, 0); |
530 | |
160f9ca7 |
531 | if ( !desc || !*desc || !SvROK(*desc) || !(SvTYPE(SvRV(*desc)) == SVt_PVAV) ) { |
de2f2e97 |
532 | croak("Attribute descriptor has to be a hash reference"); |
f253044f |
533 | } |
de2f2e97 |
534 | |
160f9ca7 |
535 | init_attr(mi, &mi->attrs[ix], (AV *)SvRV(*desc)); |
de2f2e97 |
536 | } |
537 | |
538 | return mi; |
539 | } |
540 | |
f253044f |
541 | STATIC SV *new_mi_obj (pTHX_ MI *mi) { |
035fd0c4 |
542 | HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0); |
543 | SV *obj = newRV_noinc(newSViv(PTR2IV(mi))); |
544 | sv_bless( obj, stash ); |
545 | return obj; |
f253044f |
546 | } |
de2f2e97 |
547 | |
f253044f |
548 | STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) { |
549 | dSP; |
550 | I32 count; |
551 | SV *mi; |
552 | |
553 | if ( !meta_attr ) |
554 | croak("No attr found in magic!"); |
555 | |
556 | ENTER; |
557 | SAVETMPS; |
558 | PUSHMARK(SP); |
559 | XPUSHs(meta_attr); |
560 | PUTBACK; |
561 | count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR); |
562 | |
563 | if ( count != 1 ) |
564 | croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count); |
565 | |
566 | SPAGAIN; |
567 | mi = POPs; |
568 | |
569 | SvREFCNT_inc(mi); |
570 | |
571 | PUTBACK; |
572 | FREETMPS; |
573 | LEAVE; |
574 | |
575 | return mi; |
576 | } |
577 | |
578 | STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) { |
579 | dSP; |
580 | I32 count; |
581 | MI *mi = NULL; |
582 | SV *class; |
583 | SV *attrs; |
584 | HV *stash; |
585 | |
586 | ENTER; |
587 | SAVETMPS; |
588 | PUSHMARK(SP); |
589 | XPUSHs(perl_mi); |
590 | PUTBACK; |
591 | count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY); |
592 | |
593 | if ( count != 2 ) |
594 | croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count); |
595 | |
596 | SPAGAIN; |
597 | attrs = POPs; |
598 | class = POPs; |
599 | |
600 | PUTBACK; |
601 | |
602 | stash = gv_stashsv(class, 0); |
603 | |
604 | mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs)); |
605 | |
606 | FREETMPS; |
607 | LEAVE; |
608 | |
609 | return new_mi_obj(aTHX_ mi); |
610 | } |
611 | |
612 | STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) { |
613 | I32 ix; |
614 | |
035fd0c4 |
615 | for ( ix = 0; ix < mi->num_attrs; ix++ ) { |
f253044f |
616 | if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) { |
617 | return &mi->attrs[ix]; |
de2f2e97 |
618 | } |
de2f2e97 |
619 | } |
620 | |
f253044f |
621 | sv_dump(meta_attr); |
622 | croak("Attr not found"); |
de2f2e97 |
623 | return NULL; |
624 | } |
625 | |
626 | STATIC ATTR *get_attr(pTHX_ CV *cv) { |
f253044f |
627 | SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv); |
628 | SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr); |
629 | SV *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi)); |
630 | MI *mi; |
de2f2e97 |
631 | |
f253044f |
632 | if (!c_mi) { |
633 | c_mi = perl_mi_to_c_mi(aTHX_ perl_mi); |
634 | stash_in_mg(aTHX_ perl_mi, c_mi); |
635 | } |
636 | |
637 | sv_2mortal(perl_mi); |
638 | |
639 | mi = INT2PTR(MI *, SvIV(SvRV(c_mi))); |
640 | |
641 | return mi_find_attr(mi, meta_attr); |
1ea12c91 |
642 | } |
643 | |
de2f2e97 |
644 | STATIC ATTR *define_attr (pTHX_ CV *cv) { |
645 | ATTR *attr = get_attr(aTHX_ cv); |
646 | assert(attr); |
647 | |
648 | XSANY.any_i32 = PTR2IV(attr); |
f253044f |
649 | |
650 | av_push( attr->cvs, (SV *)cv ); |
de2f2e97 |
651 | |
652 | return attr; |
653 | } |
654 | |
655 | STATIC void weaken(pTHX_ SV *sv) { |
1ea12c91 |
656 | #ifdef SvWEAKREF |
de2f2e97 |
657 | sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */ |
1ea12c91 |
658 | #else |
659 | croak("weak references are not implemented in this release of perl"); |
660 | #endif |
661 | } |
662 | |
663 | |
664 | /* meta instance protocol */ |
665 | |
de2f2e97 |
666 | STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) { |
1ea12c91 |
667 | HE *he; |
668 | |
669 | assert(self); |
670 | assert(SvROK(self)); |
671 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
672 | |
de2f2e97 |
673 | assert( ATTR_DUMB_INSTANCE(attr) ); |
674 | |
675 | if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32))) |
1ea12c91 |
676 | return HeVAL(he); |
677 | else |
678 | return NULL; |
679 | } |
680 | |
de2f2e97 |
681 | STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) { |
1ea12c91 |
682 | HE *he; |
4c6fbfb1 |
683 | SV *copy; |
1ea12c91 |
684 | |
685 | assert(self); |
686 | assert(SvROK(self)); |
687 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
688 | |
de2f2e97 |
689 | assert( ATTR_DUMB_INSTANCE(attr) ); |
690 | |
4c6fbfb1 |
691 | copy = newSVsv(value); |
692 | |
693 | he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32); |
1ea12c91 |
694 | |
1ea12c91 |
695 | if (he != NULL) { |
de2f2e97 |
696 | if ( ATTR_ISWEAK(attr) ) |
4c6fbfb1 |
697 | weaken(aTHX_ HeVAL(he)); |
1ea12c91 |
698 | } else { |
4c6fbfb1 |
699 | SvREFCNT_dec(copy); |
1ea12c91 |
700 | croak("Hash store failed."); |
701 | } |
702 | } |
703 | |
de2f2e97 |
704 | STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) { |
1ea12c91 |
705 | assert(self); |
706 | assert(SvROK(self)); |
707 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
708 | |
de2f2e97 |
709 | assert( ATTR_DUMB_INSTANCE(attr) ); |
710 | |
711 | return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32); |
712 | } |
713 | |
714 | STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) { |
715 | assert(self); |
716 | assert(SvROK(self)); |
717 | assert(SvTYPE(SvRV(self)) == SVt_PVHV); |
718 | |
719 | assert( ATTR_DUMB_INSTANCE(attr) ); |
720 | |
721 | return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32); |
1ea12c91 |
722 | } |
723 | |
160f9ca7 |
724 | STATIC SV *getter_common(pTHX_ SV *self, ATTR *attr) { |
725 | assert( ATTR_DUMB_READER(attr) ); |
726 | return get_slot_value(aTHX_ self, attr); |
727 | } |
728 | |
729 | STATIC void setter_common(pTHX_ SV *self, ATTR *attr, SV *value) { |
730 | if ( attr->flags & ATTR_MASK_TYPE ) { |
731 | if ( !check_type_constraint(aTHX_ attr->flags & ATTR_MASK_TYPE, attr->tc_check, attr->type_constraint, value) ) |
732 | croak("Bad param"); |
733 | } |
734 | |
735 | set_slot_value(aTHX_ self, attr, value); |
736 | } |
1ea12c91 |
737 | |
738 | /* simple high level api */ |
739 | |
de2f2e97 |
740 | STATIC XS(getter); |
741 | STATIC XS(getter) |
1ea12c91 |
742 | { |
743 | #ifdef dVAR |
744 | dVAR; |
745 | #endif |
746 | dXSARGS; |
de2f2e97 |
747 | dATTR; |
1ea12c91 |
748 | SV *value; |
749 | |
750 | if (items != 1) |
751 | Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); |
752 | |
753 | SP -= items; |
754 | |
160f9ca7 |
755 | value = getter_common(aTHX_ ST(0), attr); |
1ea12c91 |
756 | |
757 | if (value) { |
758 | ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */ |
759 | XSRETURN(1); |
760 | } else { |
761 | XSRETURN_UNDEF; |
762 | } |
763 | } |
764 | |
de2f2e97 |
765 | STATIC XS(setter); |
766 | STATIC XS(setter) |
1ea12c91 |
767 | { |
768 | #ifdef dVAR |
769 | dVAR; |
770 | #endif |
771 | dXSARGS; |
de2f2e97 |
772 | dATTR; |
1ea12c91 |
773 | |
774 | if (items != 2) |
775 | Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value"); |
776 | |
777 | SP -= items; |
778 | |
160f9ca7 |
779 | setter_common(aTHX_ ST(0), attr, ST(1)); |
1ea12c91 |
780 | |
781 | ST(0) = ST(1); /* return value */ |
782 | XSRETURN(1); |
783 | } |
784 | |
de2f2e97 |
785 | STATIC XS(accessor); |
786 | STATIC XS(accessor) |
1ea12c91 |
787 | { |
788 | #ifdef dVAR |
789 | dVAR; |
790 | #endif |
791 | dXSARGS; |
de2f2e97 |
792 | dATTR; |
1ea12c91 |
793 | |
794 | if (items < 1) |
795 | Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value"); |
796 | |
797 | SP -= items; |
798 | |
799 | if (items > 1) { |
160f9ca7 |
800 | setter_common(aTHX_ ST(0), attr, ST(1)); |
1ea12c91 |
801 | ST(0) = ST(1); /* return value */ |
802 | } else { |
160f9ca7 |
803 | SV *value = getter_common(aTHX_ ST(0), attr); |
1ea12c91 |
804 | if ( value ) { |
805 | ST(0) = value; |
806 | } else { |
807 | XSRETURN_UNDEF; |
808 | } |
809 | } |
810 | |
811 | XSRETURN(1); |
812 | } |
813 | |
814 | STATIC XS(predicate); |
815 | STATIC XS(predicate) |
816 | { |
817 | #ifdef dVAR |
818 | dVAR; |
819 | #endif |
820 | dXSARGS; |
de2f2e97 |
821 | dATTR; |
1ea12c91 |
822 | |
823 | if (items != 1) |
824 | Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self"); |
825 | |
826 | SP -= items; |
827 | |
de2f2e97 |
828 | if ( has_slot_value(aTHX_ ST(0), attr) ) |
1ea12c91 |
829 | XSRETURN_YES; |
830 | else |
831 | XSRETURN_NO; |
832 | } |
833 | |
834 | enum xs_body { |
de2f2e97 |
835 | xs_body_getter = 0, |
836 | xs_body_setter, |
837 | xs_body_accessor, |
1ea12c91 |
838 | xs_body_predicate, |
839 | max_xs_body |
840 | }; |
841 | |
842 | STATIC XSPROTO ((*xs_bodies[])) = { |
de2f2e97 |
843 | getter, |
844 | setter, |
845 | accessor, |
1ea12c91 |
846 | predicate, |
847 | }; |
848 | |
849 | MODULE = Moose PACKAGE = Moose::XS |
850 | |
851 | CV * |
de2f2e97 |
852 | new_sub(attr, name) |
1ea12c91 |
853 | INPUT: |
de2f2e97 |
854 | SV *attr; |
855 | SV *name; |
1ea12c91 |
856 | ALIAS: |
de2f2e97 |
857 | new_getter = xs_body_getter |
858 | new_setter = xs_body_setter |
859 | new_accessor = xs_body_accessor |
860 | new_predicate = xs_body_predicate |
1ea12c91 |
861 | PREINIT: |
862 | CV * cv; |
863 | CODE: |
864 | if ( ix >= max_xs_body ) |
865 | croak("Unknown Moose::XS body type"); |
866 | |
de2f2e97 |
867 | if ( !sv_isobject(attr) ) |
868 | croak("'attr' must be a Moose::Meta::Attribute"); |
869 | |
870 | cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__); |
1ea12c91 |
871 | |
872 | if (cv == NULL) |
873 | croak("Oi vey!"); |
874 | |
de2f2e97 |
875 | /* associate CV with meta attr */ |
f253044f |
876 | stash_in_mg(aTHX_ (SV *)cv, attr); |
de2f2e97 |
877 | |
878 | /* this will be set on first call */ |
879 | XSANY.any_i32 = 0; |
1ea12c91 |
880 | |
881 | RETVAL = cv; |
882 | OUTPUT: |
883 | RETVAL |
884 | |
885 | |
f253044f |
886 | MODULE = Moose PACKAGE = Moose::XS::Meta::Instance |
887 | |
888 | void |
889 | DESTROY(self) |
890 | INPUT: |
891 | SV *self; |
892 | PREINIT: |
893 | MI *mi = INT2PTR(MI *, SvIV(SvRV(self))); |
894 | CODE: |
895 | /* foreach attr ( delete cvs XSANY ), free attrs free mi */ |