Test execution of stub meta methods after the stub functions got defined.
[gitmo/Class-MOP.git] / MOP.xs
CommitLineData
e7b69038 1/* There's a lot of cases of doubled parens in here like this:
2
3 while ( (he = ...) ) {
4
5This shuts up warnings from gcc -Wall
6*/
7
e0e4674a 8#include "EXTERN.h"
9#include "perl.h"
10#include "XSUB.h"
15273f3c 11
599791aa 12#define NEED_sv_2pv_flags
15273f3c 13#define NEED_sv_2pv_nolen
b0e94057 14#include "ppport.h"
e0e4674a 15
cc856b56 16SV *key_name;
17U32 hash_name;
18
19SV *key_package;
20U32 hash_package;
21
da88f307 22SV *key_package_name;
23U32 hash_package_name;
24
cc856b56 25SV *key_body;
26U32 hash_body;
27
c94afdc4 28SV* method_metaclass;
29SV* associated_metaclass;
30SV* wrap;
31
32
33#define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash)
34#ifdef HvMROMETA /* 5.10.0 */
35
36#ifndef mro_meta_init
37#define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */
38#endif /* !mro_meta_init */
39
40static UV
41mop_check_package_cache_flag(pTHX_ HV* stash) {
42 assert(SvTYPE(stash) == SVt_PVHV);
43
44 return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */
45}
46
47#else /* pre 5.10.0 */
48
49static UV
50mop_check_package_cache_flag(pTHX_ HV* stash) {
51 PERL_UNUSED_ARG(stash);
52 assert(SvTYPE(stash) == SVt_PVHV);
53
54 return PL_sub_generation;
55}
56#endif
57
58#define call0(s, m) mop_call0(aTHX_ s, m)
59static SV*
60mop_call0(pTHX_ SV* const self, SV* const method) {
61 dSP;
62 SV* ret;
63
64 PUSHMARK(SP);
65 XPUSHs(self);
66 PUTBACK;
67
68 call_sv(method, G_SCALAR | G_METHOD);
69
70 SPAGAIN;
71 ret = POPs;
72 PUTBACK;
73
74 return ret;
75}
76
77static void
78mop_update_method_map(pTHX_ SV* const self, SV* const class_name, HV* const stash, HV* const map) {
79 const char* const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */
80 SV* method_metaclass_name;
81 char* method_name;
82 I32 method_name_len;
83 GV* gv;
84 dSP;
49bbf9e5 85
6bd19edb 86 /* this function massivly overlaps with the xs version of
87 * get_all_package_symbols. a common c function to walk the symbol table
88 * should be factored out and used by both. --rafl */
89
c94afdc4 90 hv_iterinit(stash);
e7b69038 91 while ( (gv = (GV*)hv_iternextsv(stash, &method_name, &method_name_len)) ) {
c94afdc4 92 CV* cv;
6bd19edb 93 switch (SvTYPE (gv)) {
94 case SVt_RV:
95 if (!SvROK(gv)) {
96 break;
97 }
98 /* fall through */
99 case SVt_IV:
100 case SVt_PV:
101 /* rafl says that this wastes memory savings that GvSVs have
102 in 5.8.9 and 5.10.x. But without it some tests fail. rafl
103 says the right thing to do is to handle GvSVs differently
104 here. */
105 gv_init((GV*)gv, stash, method_name, method_name_len, GV_ADDMULTI);
106 /* fall through */
c94afdc4 107 }
108
109 if ( SvTYPE(gv) == SVt_PVGV && (cv = GvCVu(gv)) ) {
110 GV* const cvgv = CvGV(cv);
111 /* ($cvpkg_name, $cv_name) = get_code_info($cv) */
112 const char* const cvpkg_name = HvNAME(GvSTASH(cvgv));
113 const char* const cv_name = GvNAME(cvgv);
114 SV* method_slot;
115 SV* method_object;
116
117 /* this checks to see that the subroutine is actually from our package */
118 if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) {
119 if ( strNE(cvpkg_name, class_name_pv) ) {
120 continue;
121 }
122 }
123
124 method_slot = *hv_fetch(map, method_name, method_name_len, TRUE);
125 if ( SvOK(method_slot) ) {
126 SV* const body = call0(method_slot, key_body); /* $method_object->body() */
127 if ( SvROK(body) && ((CV*) SvRV(body)) == cv ) {
128 continue;
129 }
130 }
131
132 method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */
133
134 /*
135 $method_object = $method_metaclass->wrap(
136 $cv,
137 associated_metaclass => $self,
138 package_name => $class_name,
139 name => $method_name
140 );
141 */
142 ENTER;
143 SAVETMPS;
144
145 PUSHMARK(SP);
146 EXTEND(SP, 8);
147 PUSHs(method_metaclass_name); /* invocant */
148 mPUSHs(newRV_inc((SV*)cv));
149 PUSHs(associated_metaclass);
150 PUSHs(self);
151 PUSHs(key_package_name);
152 PUSHs(class_name);
153 PUSHs(key_name);
154 mPUSHs(newSVpv(method_name, method_name_len));
155 PUTBACK;
156
157 call_sv(wrap, G_SCALAR | G_METHOD);
158 SPAGAIN;
159 method_object = POPs;
160 PUTBACK;
161 /* $map->{$method_name} = $method_object */
162 sv_setsv(method_slot, method_object);
163
164 FREETMPS;
165 LEAVE;
166 }
167 }
168}
169
170
e0e4674a 171/*
e0e4674a 172get_code_info:
173 Pass in a coderef, returns:
174 [ $pkg_name, $coderef_name ] ie:
175 [ 'Foo::Bar', 'new' ]
176*/
177
178MODULE = Class::MOP PACKAGE = Class::MOP
179
cc856b56 180BOOT:
181 key_name = newSVpvs("name");
182 key_body = newSVpvs("body");
183 key_package = newSVpvs("package");
da88f307 184 key_package_name = newSVpvs("package_name");
cc856b56 185
186 PERL_HASH(hash_name, "name", 4);
187 PERL_HASH(hash_body, "body", 4);
188 PERL_HASH(hash_package, "package", 7);
da88f307 189 PERL_HASH(hash_package_name, "package_name", 12);
cc856b56 190
c94afdc4 191 method_metaclass = newSVpvs("method_metaclass");
192 wrap = newSVpvs("wrap");
193 associated_metaclass = newSVpvs("associated_metaclass");
194
cc856b56 195
d7bf3478 196PROTOTYPES: ENABLE
197
cc856b56 198
e0e4674a 199void
200get_code_info(coderef)
201 SV* coderef
202 PREINIT:
203 char* name;
204 char* pkg;
205 PPCODE:
a7f711e5 206 if ( SvOK(coderef) && SvROK(coderef) && SvTYPE(SvRV(coderef)) == SVt_PVCV ) {
e0e4674a 207 coderef = SvRV(coderef);
7b62d87f 208 /* I think this only gets triggered with a mangled coderef, but if
209 we hit it without the guard, we segfault. The slightly odd return
210 value strikes me as an improvement (mst)
211 */
a4f4221a 212#ifdef isGV_with_GP
a7f711e5 213 if ( isGV_with_GP(CvGV(coderef)) ) {
a4f4221a 214#endif
7b62d87f 215 pkg = HvNAME( GvSTASH(CvGV(coderef)) );
216 name = GvNAME( CvGV(coderef) );
a4f4221a 217#ifdef isGV_with_GP
218 } else {
219 pkg = "__UNKNOWN__";
220 name = "__ANON__";
221 }
222#endif
e0e4674a 223
224 EXTEND(SP, 2);
225 PUSHs(newSVpvn(pkg, strlen(pkg)));
226 PUSHs(newSVpvn(name, strlen(name)));
227 }
228
15273f3c 229
230MODULE = Class::MOP PACKAGE = Class::MOP::Package
231
232void
cc856b56 233get_all_package_symbols(self, ...)
234 SV *self
15273f3c 235 PROTOTYPE: $;$
236 PREINIT:
cc856b56 237 HV *stash = NULL;
15273f3c 238 SV *type_filter = NULL;
75705e60 239 register HE *he;
15273f3c 240 PPCODE:
a7f711e5 241 if ( ! SvROK(self) ) {
988fb42e 242 die("Cannot call get_all_package_symbols as a class method");
243 }
15273f3c 244
a7f711e5 245 switch (GIMME_V) {
15273f3c 246 case G_VOID: return; break;
247 case G_SCALAR: ST(0) = &PL_sv_undef; return; break;
248 }
249
250 if ( items > 1 ) type_filter = ST(1);
251
252 PUTBACK;
253
a7f711e5 254 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
75705e60 255 stash = gv_stashsv(HeVAL(he),0);
15273f3c 256
a7f711e5 257 if (stash) {
15273f3c 258
259 (void)hv_iterinit(stash);
260
261 if ( type_filter && SvPOK(type_filter) ) {
262 const char *const type = SvPV_nolen(type_filter);
263
a7f711e5 264 while ( (he = hv_iternext(stash)) ) {
75705e60 265 SV *const gv = HeVAL(he);
a88898eb 266 SV *sv = NULL;
75705e60 267 char *key;
268 STRLEN keylen;
9457b596 269 char *package;
fd27f6e9 270 SV *fq;
15273f3c 271
15273f3c 272 switch( SvTYPE(gv) ) {
15b55537 273 case SVt_PV:
274 case SVt_IV:
275 /* expand the gv into a real typeglob if it
276 * contains stub functions and we were asked to
277 * return CODE symbols */
278 if (*type == 'C') {
279 key = HePV(he, keylen);
280 gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI);
281 }
282 /* fall through */
15273f3c 283 case SVt_PVGV:
284 switch (*type) {
285 case 'C': sv = (SV *)GvCVu(gv); break; /* CODE */
286 case 'A': sv = (SV *)GvAV(gv); break; /* ARRAY */
287 case 'I': sv = (SV *)GvIO(gv); break; /* IO */
288 case 'H': sv = (SV *)GvHV(gv); break; /* HASH */
289 case 'S': sv = (SV *)GvSV(gv); break; /* SCALAR */
290 default:
291 croak("Unknown type %s\n", type);
292 }
293 break;
294 case SVt_RV:
295 /* BAH! constants are horrible */
fd27f6e9 296
a7f711e5 297 if ( ! SvROK(gv) ) {
fd8c46e5 298 continue;
299 }
300
fd27f6e9 301 /* we don't really care about the length,
302 but that's the API */
75705e60 303 key = HePV(he, keylen);
9457b596 304 package = HvNAME(stash);
fd27f6e9 305 fq = newSVpvf("%s::%s", package, key);
8babf00a 306 sv = (SV*)get_cv(SvPV_nolen(fq), 0);
15273f3c 307 break;
308 default:
309 continue;
310 }
311
a7f711e5 312 if (sv) {
75705e60 313 SV *key = hv_iterkeysv(he);
15273f3c 314 SPAGAIN;
315 EXTEND(SP, 2);
316 PUSHs(key);
66af67fe 317 PUSHs(sv_2mortal(newRV_inc(sv)));
15273f3c 318 PUTBACK;
319 }
320 }
321 } else {
322 EXTEND(SP, HvKEYS(stash) * 2);
323
e7b69038 324 while ( (he = hv_iternext(stash)) ) {
75705e60 325 SV *key = hv_iterkeysv(he);
599791aa 326 SV *sv = HeVAL(he);
15273f3c 327 SPAGAIN;
0eb2957d 328 PUSHs(key);
15273f3c 329 PUSHs(sv);
330 PUTBACK;
331 }
332 }
333
334 }
335
e2c189ae 336void
cc856b56 337name(self)
338 SV *self
339 PREINIT:
340 register HE *he;
341 PPCODE:
a7f711e5 342 if ( ! SvROK(self) ) {
988fb42e 343 die("Cannot call name as a class method");
344 }
345
e7b69038 346 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) )
cc856b56 347 XPUSHs(HeVAL(he));
348 else
349 ST(0) = &PL_sv_undef;
350
dcbfe027 351MODULE = Class::MOP PACKAGE = Class::MOP::Attribute
cc856b56 352
e2c189ae 353void
cc856b56 354name(self)
355 SV *self
356 PREINIT:
357 register HE *he;
358 PPCODE:
a7f711e5 359 if ( ! SvROK(self) ) {
988fb42e 360 die("Cannot call name as a class method");
361 }
362
e7b69038 363 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
cc856b56 364 XPUSHs(HeVAL(he));
365 else
366 ST(0) = &PL_sv_undef;
367
dcbfe027 368MODULE = Class::MOP PACKAGE = Class::MOP::Method
cc856b56 369
e2c189ae 370void
da88f307 371name(self)
372 SV *self
373 PREINIT:
374 register HE *he;
375 PPCODE:
a7f711e5 376 if ( ! SvROK(self) ) {
da88f307 377 die("Cannot call name as a class method");
378 }
379
e7b69038 380 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) )
da88f307 381 XPUSHs(HeVAL(he));
382 else
383 ST(0) = &PL_sv_undef;
384
e2c189ae 385void
da88f307 386package_name(self)
387 SV *self
388 PREINIT:
389 register HE *he;
390 PPCODE:
a7f711e5 391 if ( ! SvROK(self) ) {
da88f307 392 die("Cannot call package_name as a class method");
393 }
394
e7b69038 395 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) )
da88f307 396 XPUSHs(HeVAL(he));
397 else
398 ST(0) = &PL_sv_undef;
399
e2c189ae 400void
cc856b56 401body(self)
402 SV *self
403 PREINIT:
404 register HE *he;
405 PPCODE:
a7f711e5 406 if ( ! SvROK(self) ) {
da88f307 407 die("Cannot call body as a class method");
408 }
409
e7b69038 410 if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) )
cc856b56 411 XPUSHs(HeVAL(he));
412 else
413 ST(0) = &PL_sv_undef;
c94afdc4 414
415
416MODULE = Class::MOP PACKAGE = Class::MOP::Class
417
418void
419get_method_map(self)
420 SV* self
c200a770 421 PREINIT:
b69838b1 422 SV* const class_name = HeVAL( hv_fetch_ent((HV*)SvRV(self), key_package, TRUE, hash_package) );
c200a770 423 HV* const stash = gv_stashsv(class_name, TRUE);
424 UV const current = check_package_cache_flag(stash);
425 SV* const cache_flag = *hv_fetchs((HV*)SvRV(self), "_package_cache_flag", TRUE);
426 SV* const map_ref = *hv_fetchs((HV*)SvRV(self), "methods", TRUE);
427 PPCODE:
428 if ( ! SvRV(self) ) {
429 die("Cannot call get_method_map as a class method");
430 }
c94afdc4 431
c200a770 432 /* in $self->{methods} does not yet exist (or got deleted) */
433 if ( ! (SvROK(map_ref) && SvTYPE(SvRV(map_ref)) == SVt_PVHV) ) {
434 SV* new_map_ref = newRV_noinc((SV*)newHV());
435 sv_2mortal(new_map_ref);
436 sv_setsv(map_ref, new_map_ref);
437 }
c94afdc4 438
c200a770 439 if ( ! (SvOK(cache_flag) && SvUV(cache_flag) == current) ) {
440 ENTER;
441 SAVETMPS;
442
443 mop_update_method_map(aTHX_ self, class_name, stash, (HV*)SvRV(map_ref));
444 sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */
445
446 FREETMPS;
447 LEAVE;
448 }
449
450 XPUSHs(map_ref);
c94afdc4 451