projects / gitmo/Moose.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
rename getter/setter to reader/writer for consistency
[gitmo/Moose.git] / Moose.xs
CommitLineData
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
33STATIC 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 50STATIC 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
57STATIC 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 73typedef 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 95typedef 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
104typedef 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
111typedef union {
de2f2e97 112 char *builder;
fe0194bf 113 SV *sv;
de2f2e97 114 OP *op;
115 U32 type;
116} DEFAULT;
117
118typedef 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 126typedef 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 */
195typedef 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
203typedef enum {
204 hash = 0,
205
206 /* these are not yet implemented */
207 array,
208 fptr,
209 cv,
210 judy,
211} instance_types;
212
213typedef 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
228STATIC 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
244STATIC 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 268STATIC 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
302STATIC 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 387STATIC 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 409STATIC 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 436STATIC 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);
9be0171f 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 551STATIC 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 579STATIC 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-- ) {
6011a844 587 CV *cv = (CV *)cvs[j];
7ce1a351 588 XSANY.any_i32 = 0;
589 }
590
591 SvREFCNT_dec(attr->cvs);
592 SvREFCNT_dec(attr->slot_sv);
593 SvREFCNT_dec(attr->type_constraint);
9be0171f 594 if ( attr->flags & ATTR_TCREFCNT ) SvREFCNT_dec(attr->tc_check.sv);
595 if ( attr->flags & ATTR_DEFREFCNT ) SvREFCNT_dec(attr->def.sv);
7ce1a351 596 SvREFCNT_dec(attr->initializer);
597 SvREFCNT_dec(attr->trigger);
598 SvREFCNT_dec(attr->meta_attr);
599 }
600
601 Safefree(mi->attrs);
602 Safefree(mi);
603}
604
f253044f 605STATIC SV *new_mi_obj (pTHX_ MI *mi) {
035fd0c4 606 HV *stash = gv_stashpvs("Moose::XS::Meta::Instance",0);
607 SV *obj = newRV_noinc(newSViv(PTR2IV(mi)));
608 sv_bless( obj, stash );
609 return obj;
f253044f 610}
de2f2e97 611
f253044f 612STATIC SV *attr_to_meta_instance(pTHX_ SV *meta_attr) {
613 dSP;
614 I32 count;
615 SV *mi;
616
617 if ( !meta_attr )
618 croak("No attr found in magic!");
619
620 ENTER;
621 SAVETMPS;
622 PUSHMARK(SP);
623 XPUSHs(meta_attr);
624 PUTBACK;
625 count = call_pv("Moose::XS::attr_to_meta_instance", G_SCALAR);
626
627 if ( count != 1 )
628 croak("attr_to_meta_instance borked (%d args returned, expecting 1)", count);
629
630 SPAGAIN;
631 mi = POPs;
632
633 SvREFCNT_inc(mi);
634
635 PUTBACK;
636 FREETMPS;
637 LEAVE;
638
fe0194bf 639 return sv_2mortal(mi);
f253044f 640}
641
642STATIC SV *perl_mi_to_c_mi(pTHX_ SV *perl_mi) {
643 dSP;
644 I32 count;
645 MI *mi = NULL;
646 SV *class;
647 SV *attrs;
648 HV *stash;
649
650 ENTER;
651 SAVETMPS;
652 PUSHMARK(SP);
653 XPUSHs(perl_mi);
654 PUTBACK;
655 count = call_pv("Moose::XS::meta_instance_to_attr_descs", G_ARRAY);
656
657 if ( count != 2 )
658 croak("meta_instance_to_attr_descs borked (%d args returned, expecting 2)", count);
659
660 SPAGAIN;
661 attrs = POPs;
662 class = POPs;
663
664 PUTBACK;
665
666 stash = gv_stashsv(class, 0);
667
668 mi = new_mi(aTHX_ stash, (AV *)SvRV(attrs));
669
670 FREETMPS;
671 LEAVE;
672
673 return new_mi_obj(aTHX_ mi);
674}
675
676STATIC ATTR *mi_find_attr(MI *mi, SV *meta_attr) {
677 I32 ix;
678
035fd0c4 679 for ( ix = 0; ix < mi->num_attrs; ix++ ) {
f253044f 680 if ( SvRV(mi->attrs[ix].meta_attr) == SvRV(meta_attr) ) {
681 return &mi->attrs[ix];
de2f2e97 682 }
de2f2e97 683 }
684
f253044f 685 sv_dump(meta_attr);
686 croak("Attr not found");
de2f2e97 687 return NULL;
688}
689
690STATIC ATTR *get_attr(pTHX_ CV *cv) {
f253044f 691 SV *meta_attr = get_stashed_in_mg(aTHX_ (SV *)cv);
692 SV *perl_mi = attr_to_meta_instance(aTHX_ meta_attr);
693 SV *c_mi = get_stashed_in_mg(aTHX_ SvRV(perl_mi));
694 MI *mi;
de2f2e97 695
f253044f 696 if (!c_mi) {
697 c_mi = perl_mi_to_c_mi(aTHX_ perl_mi);
e10d45dc 698 stash_in_mg(aTHX_ SvRV(perl_mi), c_mi);
7ce1a351 699 SvREFCNT_dec(c_mi);
f253044f 700 }
701
f253044f 702 mi = INT2PTR(MI *, SvIV(SvRV(c_mi)));
703
704 return mi_find_attr(mi, meta_attr);
1ea12c91 705}
706
de2f2e97 707STATIC ATTR *define_attr (pTHX_ CV *cv) {
708 ATTR *attr = get_attr(aTHX_ cv);
709 assert(attr);
710
711 XSANY.any_i32 = PTR2IV(attr);
f253044f 712
7ce1a351 713 SvREFCNT_inc(cv);
f253044f 714 av_push( attr->cvs, (SV *)cv );
de2f2e97 715
716 return attr;
717}
718
719STATIC void weaken(pTHX_ SV *sv) {
1ea12c91 720#ifdef SvWEAKREF
de2f2e97 721 sv_rvweaken(sv); /* FIXME i think this might warn when weakening an already weak ref */
1ea12c91 722#else
723 croak("weak references are not implemented in this release of perl");
724#endif
725}
726
727
728/* meta instance protocol */
729
de2f2e97 730STATIC SV *get_slot_value(pTHX_ SV *self, ATTR *attr) {
1ea12c91 731 HE *he;
732
733 assert(self);
734 assert(SvROK(self));
735 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
736
de2f2e97 737 assert( ATTR_DUMB_INSTANCE(attr) );
738
739 if ((he = hv_fetch_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32)))
1ea12c91 740 return HeVAL(he);
741 else
742 return NULL;
743}
744
de2f2e97 745STATIC void set_slot_value(pTHX_ SV *self, ATTR *attr, SV *value) {
1ea12c91 746 HE *he;
4c6fbfb1 747 SV *copy;
1ea12c91 748
749 assert(self);
750 assert(SvROK(self));
751 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
752
de2f2e97 753 assert( ATTR_DUMB_INSTANCE(attr) );
754
4c6fbfb1 755 copy = newSVsv(value);
756
757 he = hv_store_ent((HV*)SvRV(self), attr->slot_sv, copy, attr->slot_u32);
1ea12c91 758
1ea12c91 759 if (he != NULL) {
de2f2e97 760 if ( ATTR_ISWEAK(attr) )
4c6fbfb1 761 weaken(aTHX_ HeVAL(he));
1ea12c91 762 } else {
4c6fbfb1 763 SvREFCNT_dec(copy);
1ea12c91 764 croak("Hash store failed.");
765 }
766}
767
de2f2e97 768STATIC bool has_slot_value(pTHX_ SV *self, ATTR *attr) {
1ea12c91 769 assert(self);
770 assert(SvROK(self));
771 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
772
de2f2e97 773 assert( ATTR_DUMB_INSTANCE(attr) );
774
775 return hv_exists_ent((HV *)SvRV(self), attr->slot_sv, attr->slot_u32);
776}
777
778STATIC SV *deinitialize_slot(pTHX_ SV *self, ATTR *attr) {
779 assert(self);
780 assert(SvROK(self));
781 assert(SvTYPE(SvRV(self)) == SVt_PVHV);
782
783 assert( ATTR_DUMB_INSTANCE(attr) );
784
785 return hv_delete_ent((HV *)SvRV(self), attr->slot_sv, 0, attr->slot_u32);
1ea12c91 786}
787
24a7a8c5 788STATIC void writer_common(pTHX_ SV *self, ATTR *attr, SV *value);
fe0194bf 789
790
791STATIC SV *get_default(pTHX_ SV *self, ATTR *attr) {
792 switch ( ATTR_DEFAULT(attr) ) {
793 case default_none:
794 return NULL;
795 break;
796 case default_builder:
797 {
798 SV *sv;
799 dSP;
800
801 ENTER;
802 SAVETMPS;
803 PUSHMARK(SP);
804 XPUSHs(self);
805 PUTBACK;
806
807 call_method(SvPV_nolen(attr->def.sv), G_SCALAR);
808
809 SPAGAIN;
810 sv = POPs;
811
812 SvREFCNT_inc(sv);
813
814 PUTBACK;
815 FREETMPS;
816 LEAVE;
817
818 return sv_2mortal(sv);
819 }
820 break;
821 case default_normal:
822 if ( SvROK(attr->def.sv) ) {
823 printf("CV default\n");
824 } else {
825 printf("simple value\n");
826 return attr->def.sv; /* will be copied by set for lazy, and by reader for both cases */
827 }
828 break;
829 case default_op:
830 case default_type:
831 croak("todo");
832 break;
833 }
834
835 return NULL;
836}
837
24a7a8c5 838STATIC SV *reader_common(pTHX_ SV *self, ATTR *attr) {
fe0194bf 839 SV *value = get_slot_value(aTHX_ self, attr);
840
841 if ( value ) {
842 return value;
843 } else if ( ATTR_ISLAZY(attr) ) {
844 value = get_default(aTHX_ self, attr);
24a7a8c5 845 writer_common(aTHX_ self, attr, value);
fe0194bf 846 return value;
847 }
848
849 return NULL;
160f9ca7 850}
851
24a7a8c5 852STATIC void writer_common(pTHX_ SV *self, ATTR *attr, SV *value) {
fe0194bf 853 if ( ATTR_TYPE(attr) ) {
854 if ( !check_type_constraint(aTHX_ ATTR_TYPE(attr), attr->tc_check, attr->type_constraint, value) )
160f9ca7 855 croak("Bad param");
856 }
857
858 set_slot_value(aTHX_ self, attr, value);
859}
1ea12c91 860
861/* simple high level api */
862
24a7a8c5 863STATIC XS(reader);
864STATIC XS(reader)
1ea12c91 865{
866#ifdef dVAR
867 dVAR;
868#endif
869 dXSARGS;
de2f2e97 870 dATTR;
1ea12c91 871 SV *value;
872
873 if (items != 1)
874 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
875
876 SP -= items;
877
24a7a8c5 878 value = reader_common(aTHX_ ST(0), attr);
1ea12c91 879
880 if (value) {
881 ST(0) = sv_mortalcopy(value); /* mortalcopy because $_ .= "blah" for $foo->bar */
882 XSRETURN(1);
883 } else {
884 XSRETURN_UNDEF;
885 }
886}
887
24a7a8c5 888STATIC XS(writer);
889STATIC XS(writer)
1ea12c91 890{
891#ifdef dVAR
892 dVAR;
893#endif
894 dXSARGS;
de2f2e97 895 dATTR;
1ea12c91 896
897 if (items != 2)
898 Perl_croak(aTHX_ "Usage: %s(%s, %s)", GvNAME(CvGV(cv)), "self", "value");
899
900 SP -= items;
901
24a7a8c5 902 writer_common(aTHX_ ST(0), attr, ST(1));
1ea12c91 903
904 ST(0) = ST(1); /* return value */
905 XSRETURN(1);
906}
907
de2f2e97 908STATIC XS(accessor);
909STATIC XS(accessor)
1ea12c91 910{
911#ifdef dVAR
912 dVAR;
913#endif
914 dXSARGS;
de2f2e97 915 dATTR;
1ea12c91 916
917 if (items < 1)
918 Perl_croak(aTHX_ "Usage: %s(%s, [ %s ])", GvNAME(CvGV(cv)), "self", "value");
919
920 SP -= items;
921
922 if (items > 1) {
24a7a8c5 923 writer_common(aTHX_ ST(0), attr, ST(1));
1ea12c91 924 ST(0) = ST(1); /* return value */
925 } else {
24a7a8c5 926 SV *value = reader_common(aTHX_ ST(0), attr);
1ea12c91 927 if ( value ) {
928 ST(0) = value;
929 } else {
930 XSRETURN_UNDEF;
931 }
932 }
933
934 XSRETURN(1);
935}
936
937STATIC XS(predicate);
938STATIC XS(predicate)
939{
940#ifdef dVAR
941 dVAR;
942#endif
943 dXSARGS;
de2f2e97 944 dATTR;
1ea12c91 945
946 if (items != 1)
947 Perl_croak(aTHX_ "Usage: %s(%s)", GvNAME(CvGV(cv)), "self");
948
949 SP -= items;
950
de2f2e97 951 if ( has_slot_value(aTHX_ ST(0), attr) )
1ea12c91 952 XSRETURN_YES;
953 else
954 XSRETURN_NO;
955}
956
957enum xs_body {
24a7a8c5 958 xs_body_reader = 0,
959 xs_body_writer,
de2f2e97 960 xs_body_accessor,
1ea12c91 961 xs_body_predicate,
962 max_xs_body
963};
964
965STATIC XSPROTO ((*xs_bodies[])) = {
24a7a8c5 966 reader,
967 writer,
de2f2e97 968 accessor,
1ea12c91 969 predicate,
970};
971
972MODULE = Moose PACKAGE = Moose::XS
973
974CV *
de2f2e97 975new_sub(attr, name)
1ea12c91 976 INPUT:
de2f2e97 977 SV *attr;
978 SV *name;
1ea12c91 979 ALIAS:
24a7a8c5 980 new_reader = xs_body_reader
981 new_writer = xs_body_writer
de2f2e97 982 new_accessor = xs_body_accessor
983 new_predicate = xs_body_predicate
1ea12c91 984 PREINIT:
985 CV * cv;
986 CODE:
987 if ( ix >= max_xs_body )
988 croak("Unknown Moose::XS body type");
989
de2f2e97 990 if ( !sv_isobject(attr) )
991 croak("'attr' must be a Moose::Meta::Attribute");
992
993 cv = newXS(SvOK(name) ? SvPV_nolen(name) : NULL, xs_bodies[ix], __FILE__);
1ea12c91 994
995 if (cv == NULL)
996 croak("Oi vey!");
997
de2f2e97 998 /* associate CV with meta attr */
f253044f 999 stash_in_mg(aTHX_ (SV *)cv, attr);
de2f2e97 1000
1001 /* this will be set on first call */
1002 XSANY.any_i32 = 0;
1ea12c91 1003
1004 RETVAL = cv;
1005 OUTPUT:
1006 RETVAL
1007
1008
f253044f 1009MODULE = Moose PACKAGE = Moose::XS::Meta::Instance
1010
1011void
1012DESTROY(self)
1013 INPUT:
1014 SV *self;
1015 PREINIT:
1016 MI *mi = INT2PTR(MI *, SvIV(SvRV(self)));
1017 CODE:
7ce1a351 1018 delete_mi(aTHX_ mi);
A Postmodern Object System for Perl5 - now lives at https://github.com/moose/Moose