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