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