Commit | Line | Data |
e7b69038 |
1 | /* There's a lot of cases of doubled parens in here like this: |
2 | |
3 | while ( (he = ...) ) { |
4 | |
5 | This shuts up warnings from gcc -Wall |
6 | */ |
7 | |
e0e4674a |
8 | #include "EXTERN.h" |
9 | #include "perl.h" |
10 | #include "XSUB.h" |
15273f3c |
11 | |
08f4716f |
12 | #define NEED_newRV_noinc |
599791aa |
13 | #define NEED_sv_2pv_flags |
15273f3c |
14 | #define NEED_sv_2pv_nolen |
b0e94057 |
15 | #include "ppport.h" |
e0e4674a |
16 | |
193bfdc0 |
17 | #define DECLARE_KEY(name) SV *key_##name; U32 hash_##name; |
18 | |
1654881c |
19 | #define PREHASH_KEY_WITH_VALUE(name, value) do { \ |
193bfdc0 |
20 | key_##name = newSVpvs(value); \ |
21 | PERL_HASH(hash_##name, value, sizeof(value) - 1); \ |
22 | } while (0) |
23 | |
1654881c |
24 | #define PREHASH_KEY(name) PREHASH_KEY_WITH_VALUE(name, #name) |
25 | |
193bfdc0 |
26 | DECLARE_KEY(name); |
27 | DECLARE_KEY(package); |
28 | DECLARE_KEY(package_name); |
29 | DECLARE_KEY(body); |
30 | DECLARE_KEY(package_cache_flag); |
31 | DECLARE_KEY(methods); |
32 | DECLARE_KEY(VERSION); |
33 | DECLARE_KEY(ISA); |
d508fabd |
34 | |
00c93f7a |
35 | SV *method_metaclass; |
36 | SV *associated_metaclass; |
37 | SV *wrap; |
c94afdc4 |
38 | |
39 | |
40 | #define check_package_cache_flag(stash) mop_check_package_cache_flag(aTHX_ stash) |
1d4cf2a9 |
41 | #if PERL_VERSION >= 10 |
c94afdc4 |
42 | |
43 | static UV |
44 | mop_check_package_cache_flag(pTHX_ HV* stash) { |
45 | assert(SvTYPE(stash) == SVt_PVHV); |
46 | |
1d4cf2a9 |
47 | /* here we're trying to implement a c version of mro::get_pkg_gen($stash), |
48 | * however the perl core doesn't make it easy for us. It doesn't provide an |
49 | * api that just does what we want. |
50 | * |
51 | * However, we know that the information we want is, inside the core, |
52 | * available using HvMROMETA(stash)->pkg_gen. Unfortunately, although the |
53 | * HvMROMETA macro is public, it is implemented using Perl_mro_meta_init, |
54 | * which is not public and only available inside the core, as the mro |
55 | * interface as well as the structure returned by mro_meta_init isn't |
56 | * considered to be stable yet. |
57 | * |
58 | * Perl_mro_meta_init isn't declared static, so we could just define it |
59 | * ourselfs if perls headers don't do that for us, except that won't work |
60 | * on platforms where symbols need to be explicitly exported when linking |
61 | * shared libraries. |
62 | * |
63 | * So our, hopefully temporary, solution is to be even more evil and |
64 | * basically reimplement HvMROMETA in a very fragile way that'll blow up |
65 | * when the relevant parts of the mro implementation in core change. |
66 | * |
67 | * :-( |
68 | * |
69 | */ |
70 | |
71 | return HvAUX(stash)->xhv_mro_meta |
72 | ? HvAUX(stash)->xhv_mro_meta->pkg_gen |
73 | : 0; |
c94afdc4 |
74 | } |
75 | |
76 | #else /* pre 5.10.0 */ |
77 | |
78 | static UV |
00c93f7a |
79 | mop_check_package_cache_flag(pTHX_ HV *stash) { |
c94afdc4 |
80 | PERL_UNUSED_ARG(stash); |
81 | assert(SvTYPE(stash) == SVt_PVHV); |
82 | |
83 | return PL_sub_generation; |
84 | } |
85 | #endif |
86 | |
87 | #define call0(s, m) mop_call0(aTHX_ s, m) |
00c93f7a |
88 | static SV * |
89 | mop_call0(pTHX_ SV *const self, SV *const method) { |
c94afdc4 |
90 | dSP; |
00c93f7a |
91 | SV *ret; |
c94afdc4 |
92 | |
93 | PUSHMARK(SP); |
94 | XPUSHs(self); |
95 | PUTBACK; |
96 | |
97 | call_sv(method, G_SCALAR | G_METHOD); |
98 | |
99 | SPAGAIN; |
100 | ret = POPs; |
101 | PUTBACK; |
102 | |
103 | return ret; |
104 | } |
105 | |
ee82a43e |
106 | static int |
0e0b5b8d |
107 | get_code_info (SV *coderef, char **pkg, char **name) |
108 | { |
109 | if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { |
110 | return 0; |
111 | } |
6bd19edb |
112 | |
0e0b5b8d |
113 | coderef = SvRV(coderef); |
114 | /* I think this only gets triggered with a mangled coderef, but if |
115 | we hit it without the guard, we segfault. The slightly odd return |
116 | value strikes me as an improvement (mst) |
117 | */ |
118 | #ifdef isGV_with_GP |
119 | if ( isGV_with_GP(CvGV(coderef)) ) { |
cb0ec494 |
120 | #endif |
0e0b5b8d |
121 | *pkg = HvNAME( GvSTASH(CvGV(coderef)) ); |
122 | *name = GvNAME( CvGV(coderef) ); |
123 | #ifdef isGV_with_GP |
124 | } else { |
125 | *pkg = "__UNKNOWN__"; |
126 | *name = "__ANON__"; |
c94afdc4 |
127 | } |
0e0b5b8d |
128 | #endif |
129 | |
130 | return 1; |
c94afdc4 |
131 | } |
132 | |
b49ee39f |
133 | typedef enum { |
134 | TYPE_FILTER_NONE, |
135 | TYPE_FILTER_CODE, |
136 | TYPE_FILTER_ARRAY, |
137 | TYPE_FILTER_IO, |
138 | TYPE_FILTER_HASH, |
139 | TYPE_FILTER_SCALAR, |
140 | } type_filter_t; |
141 | |
142 | static HV * |
143 | get_all_package_symbols(HV *stash, type_filter_t filter) |
144 | { |
145 | HE *he; |
146 | HV *ret = newHV(); |
147 | |
148 | (void)hv_iterinit(stash); |
149 | |
150 | if (filter == TYPE_FILTER_NONE) { |
151 | while ( (he = hv_iternext(stash)) ) { |
152 | STRLEN keylen; |
153 | char *key = HePV(he, keylen); |
7291ecef |
154 | if (!hv_store(ret, key, keylen, SvREFCNT_inc(HeVAL(he)), 0)) { |
155 | croak("failed to store glob ref"); |
156 | } |
b49ee39f |
157 | } |
158 | |
159 | return ret; |
160 | } |
161 | |
162 | while ( (he = hv_iternext(stash)) ) { |
163 | SV *const gv = HeVAL(he); |
164 | SV *sv = NULL; |
165 | char *key; |
166 | STRLEN keylen; |
167 | char *package; |
168 | SV *fq; |
169 | |
170 | switch( SvTYPE(gv) ) { |
171 | #ifndef SVt_RV |
172 | case SVt_RV: |
173 | #endif |
174 | case SVt_PV: |
175 | case SVt_IV: |
176 | /* expand the gv into a real typeglob if it |
177 | * contains stub functions and we were asked to |
178 | * return CODE symbols */ |
179 | if (filter == TYPE_FILTER_CODE) { |
180 | if (SvROK(gv)) { |
181 | /* we don't really care about the length, |
182 | but that's the API */ |
183 | key = HePV(he, keylen); |
184 | package = HvNAME(stash); |
185 | fq = newSVpvf("%s::%s", package, key); |
186 | sv = (SV *)get_cv(SvPV_nolen(fq), 0); |
187 | break; |
188 | } |
189 | |
190 | key = HePV(he, keylen); |
191 | gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI); |
192 | } |
193 | /* fall through */ |
194 | case SVt_PVGV: |
195 | switch (filter) { |
196 | case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break; |
197 | case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break; |
198 | case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break; |
199 | case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break; |
200 | case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break; |
201 | default: |
202 | croak("Unknown type"); |
203 | } |
204 | break; |
205 | default: |
206 | continue; |
207 | } |
208 | |
209 | if (sv) { |
210 | char *key = HePV(he, keylen); |
7291ecef |
211 | if (!hv_store(ret, key, keylen, newRV_inc(sv), 0)) { |
212 | croak("failed to store symbol ref"); |
213 | } |
b49ee39f |
214 | } |
215 | } |
216 | |
217 | return ret; |
218 | } |
c94afdc4 |
219 | |
0e0b5b8d |
220 | |
221 | static void |
00c93f7a |
222 | mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map) { |
223 | const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */ |
224 | SV *method_metaclass_name; |
225 | char *method_name; |
0e0b5b8d |
226 | I32 method_name_len; |
00c93f7a |
227 | SV *coderef; |
228 | HV *symbols; |
0e0b5b8d |
229 | dSP; |
230 | |
231 | symbols = get_all_package_symbols(stash, TYPE_FILTER_CODE); |
232 | |
233 | (void)hv_iterinit(symbols); |
234 | while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) { |
00c93f7a |
235 | CV *cv = (CV *)SvRV(coderef); |
236 | char *cvpkg_name; |
237 | char *cv_name; |
238 | SV *method_slot; |
239 | SV *method_object; |
0e0b5b8d |
240 | |
241 | if (!get_code_info(coderef, &cvpkg_name, &cv_name)) { |
242 | continue; |
243 | } |
244 | |
245 | /* this checks to see that the subroutine is actually from our package */ |
246 | if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) { |
247 | if ( strNE(cvpkg_name, class_name_pv) ) { |
248 | continue; |
249 | } |
250 | } |
251 | |
252 | method_slot = *hv_fetch(map, method_name, method_name_len, TRUE); |
253 | if ( SvOK(method_slot) ) { |
6d915932 |
254 | SV *const body = call0(method_slot, key_body); /* $method_object->body() */ |
00c93f7a |
255 | if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) { |
0e0b5b8d |
256 | continue; |
257 | } |
258 | } |
259 | |
260 | method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */ |
261 | |
262 | /* |
263 | $method_object = $method_metaclass->wrap( |
264 | $cv, |
265 | associated_metaclass => $self, |
266 | package_name => $class_name, |
267 | name => $method_name |
268 | ); |
269 | */ |
270 | ENTER; |
271 | SAVETMPS; |
272 | |
273 | PUSHMARK(SP); |
274 | EXTEND(SP, 8); |
275 | PUSHs(method_metaclass_name); /* invocant */ |
00c93f7a |
276 | mPUSHs(newRV_inc((SV *)cv)); |
0e0b5b8d |
277 | PUSHs(associated_metaclass); |
278 | PUSHs(self); |
279 | PUSHs(key_package_name); |
280 | PUSHs(class_name); |
281 | PUSHs(key_name); |
282 | mPUSHs(newSVpv(method_name, method_name_len)); |
283 | PUTBACK; |
284 | |
285 | call_sv(wrap, G_SCALAR | G_METHOD); |
286 | SPAGAIN; |
287 | method_object = POPs; |
288 | PUTBACK; |
289 | /* $map->{$method_name} = $method_object */ |
290 | sv_setsv(method_slot, method_object); |
291 | |
292 | FREETMPS; |
293 | LEAVE; |
294 | } |
295 | } |
296 | |
e0e4674a |
297 | /* |
e0e4674a |
298 | get_code_info: |
299 | Pass in a coderef, returns: |
300 | [ $pkg_name, $coderef_name ] ie: |
301 | [ 'Foo::Bar', 'new' ] |
302 | */ |
303 | |
304 | MODULE = Class::MOP PACKAGE = Class::MOP |
305 | |
cc856b56 |
306 | BOOT: |
1654881c |
307 | PREHASH_KEY(name); |
308 | PREHASH_KEY(body); |
309 | PREHASH_KEY(package); |
310 | PREHASH_KEY(package_name); |
311 | PREHASH_KEY(methods); |
312 | PREHASH_KEY(ISA); |
313 | PREHASH_KEY_WITH_VALUE(package_cache_flag, "_package_cache_flag"); |
314 | /* we can't stringify VERSION as it's a define already */ |
7d0839dc |
315 | PREHASH_KEY_WITH_VALUE(VERSION, "VERSION"); |
cc856b56 |
316 | |
c94afdc4 |
317 | method_metaclass = newSVpvs("method_metaclass"); |
318 | wrap = newSVpvs("wrap"); |
319 | associated_metaclass = newSVpvs("associated_metaclass"); |
320 | |
cc856b56 |
321 | |
d7bf3478 |
322 | PROTOTYPES: ENABLE |
323 | |
cc856b56 |
324 | |
e0e4674a |
325 | void |
326 | get_code_info(coderef) |
00c93f7a |
327 | SV *coderef |
0e0b5b8d |
328 | PREINIT: |
6d915932 |
329 | char *pkg = NULL; |
330 | char *name = NULL; |
0e0b5b8d |
331 | PPCODE: |
332 | if (get_code_info(coderef, &pkg, &name)) { |
333 | EXTEND(SP, 2); |
334 | PUSHs(newSVpv(pkg, 0)); |
335 | PUSHs(newSVpv(name, 0)); |
336 | } |
e0e4674a |
337 | |
863178c8 |
338 | PROTOTYPES: DISABLE |
339 | |
340 | void |
341 | is_class_loaded(klass=&PL_sv_undef) |
342 | SV *klass |
343 | PREINIT: |
344 | HV *stash; |
345 | char *key; |
346 | I32 keylen; |
347 | GV *gv; |
348 | PPCODE: |
349 | if (!SvPOK(klass) || !SvCUR(klass)) { |
350 | XSRETURN_NO; |
351 | } |
352 | |
353 | stash = gv_stashsv(klass, 0); |
354 | if (!stash) { |
355 | XSRETURN_NO; |
356 | } |
357 | |
d508fabd |
358 | if (hv_exists_ent (stash, key_VERSION, hash_VERSION)) { |
359 | HE *version = hv_fetch_ent(stash, key_VERSION, 0, hash_VERSION); |
360 | if (version && HeVAL(version) && GvSV(HeVAL(version))) { |
863178c8 |
361 | XSRETURN_YES; |
362 | } |
363 | } |
364 | |
d508fabd |
365 | if (hv_exists_ent (stash, key_ISA, hash_ISA)) { |
366 | HE *isa = hv_fetch_ent(stash, key_ISA, 0, hash_ISA); |
367 | if (isa && HeVAL(isa) && GvAV(HeVAL(isa))) { |
863178c8 |
368 | XSRETURN_YES; |
369 | } |
370 | } |
371 | |
372 | (void)hv_iterinit(stash); |
002254af |
373 | while ((gv = (GV *)hv_iternextsv(stash, &key, &keylen))) { |
863178c8 |
374 | if (keylen <= 0) { |
375 | continue; |
376 | } |
377 | |
378 | if (key[keylen - 1] == ':' && key[keylen - 2] == ':') { |
379 | continue; |
380 | } |
381 | |
382 | if (!isGV(gv) || GvCV(gv) || GvSV(gv) || GvAV(gv) || GvHV(gv) || GvIO(gv) || GvFORM(gv)) { |
383 | XSRETURN_YES; |
384 | } |
385 | } |
386 | |
387 | XSRETURN_NO; |
15273f3c |
388 | |
389 | MODULE = Class::MOP PACKAGE = Class::MOP::Package |
390 | |
863178c8 |
391 | PROTOTYPES: ENABLE |
392 | |
15273f3c |
393 | void |
b49ee39f |
394 | get_all_package_symbols(self, filter=TYPE_FILTER_NONE) |
cc856b56 |
395 | SV *self |
b49ee39f |
396 | type_filter_t filter |
15273f3c |
397 | PROTOTYPE: $;$ |
398 | PREINIT: |
cc856b56 |
399 | HV *stash = NULL; |
b49ee39f |
400 | HV *symbols = NULL; |
75705e60 |
401 | register HE *he; |
15273f3c |
402 | PPCODE: |
a7f711e5 |
403 | if ( ! SvROK(self) ) { |
988fb42e |
404 | die("Cannot call get_all_package_symbols as a class method"); |
405 | } |
15273f3c |
406 | |
b49ee39f |
407 | if (GIMME_V == G_VOID) { |
408 | XSRETURN_EMPTY; |
409 | } |
410 | |
15273f3c |
411 | |
15273f3c |
412 | PUTBACK; |
413 | |
b49ee39f |
414 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) { |
415 | stash = gv_stashsv(HeVAL(he), 0); |
416 | } |
15273f3c |
417 | |
15273f3c |
418 | |
b49ee39f |
419 | if (!stash) { |
6ccb3af5 |
420 | switch (GIMME_V) { |
421 | case G_SCALAR: XSRETURN_UNDEF; break; |
422 | case G_ARRAY: XSRETURN_EMPTY; break; |
423 | } |
b49ee39f |
424 | } |
15273f3c |
425 | |
b49ee39f |
426 | symbols = get_all_package_symbols(stash, filter); |
15273f3c |
427 | |
6ccb3af5 |
428 | switch (GIMME_V) { |
429 | case G_SCALAR: |
430 | PUSHs(sv_2mortal(newRV_inc((SV *)symbols))); |
431 | break; |
432 | case G_ARRAY: |
433 | warn("Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead."); |
434 | |
435 | EXTEND(SP, HvKEYS(symbols) * 2); |
436 | |
437 | while ((he = hv_iternext(symbols))) { |
438 | PUSHs(hv_iterkeysv(he)); |
439 | PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he)))); |
440 | } |
441 | |
442 | break; |
443 | default: |
444 | break; |
15273f3c |
445 | } |
446 | |
b49ee39f |
447 | SvREFCNT_dec((SV *)symbols); |
448 | |
e2c189ae |
449 | void |
cc856b56 |
450 | name(self) |
451 | SV *self |
452 | PREINIT: |
453 | register HE *he; |
454 | PPCODE: |
a7f711e5 |
455 | if ( ! SvROK(self) ) { |
988fb42e |
456 | die("Cannot call name as a class method"); |
457 | } |
458 | |
e7b69038 |
459 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) |
cc856b56 |
460 | XPUSHs(HeVAL(he)); |
461 | else |
462 | ST(0) = &PL_sv_undef; |
463 | |
dcbfe027 |
464 | MODULE = Class::MOP PACKAGE = Class::MOP::Attribute |
cc856b56 |
465 | |
e2c189ae |
466 | void |
cc856b56 |
467 | name(self) |
468 | SV *self |
469 | PREINIT: |
470 | register HE *he; |
471 | PPCODE: |
a7f711e5 |
472 | if ( ! SvROK(self) ) { |
988fb42e |
473 | die("Cannot call name as a class method"); |
474 | } |
475 | |
e7b69038 |
476 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) ) |
cc856b56 |
477 | XPUSHs(HeVAL(he)); |
478 | else |
479 | ST(0) = &PL_sv_undef; |
480 | |
dcbfe027 |
481 | MODULE = Class::MOP PACKAGE = Class::MOP::Method |
cc856b56 |
482 | |
e2c189ae |
483 | void |
da88f307 |
484 | name(self) |
485 | SV *self |
486 | PREINIT: |
487 | register HE *he; |
488 | PPCODE: |
a7f711e5 |
489 | if ( ! SvROK(self) ) { |
da88f307 |
490 | die("Cannot call name as a class method"); |
491 | } |
492 | |
e7b69038 |
493 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) ) |
da88f307 |
494 | XPUSHs(HeVAL(he)); |
495 | else |
496 | ST(0) = &PL_sv_undef; |
497 | |
e2c189ae |
498 | void |
da88f307 |
499 | package_name(self) |
500 | SV *self |
501 | PREINIT: |
502 | register HE *he; |
503 | PPCODE: |
a7f711e5 |
504 | if ( ! SvROK(self) ) { |
da88f307 |
505 | die("Cannot call package_name as a class method"); |
506 | } |
507 | |
e7b69038 |
508 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) ) |
da88f307 |
509 | XPUSHs(HeVAL(he)); |
510 | else |
511 | ST(0) = &PL_sv_undef; |
512 | |
e2c189ae |
513 | void |
cc856b56 |
514 | body(self) |
515 | SV *self |
516 | PREINIT: |
517 | register HE *he; |
518 | PPCODE: |
a7f711e5 |
519 | if ( ! SvROK(self) ) { |
da88f307 |
520 | die("Cannot call body as a class method"); |
521 | } |
522 | |
e7b69038 |
523 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) ) |
cc856b56 |
524 | XPUSHs(HeVAL(he)); |
525 | else |
526 | ST(0) = &PL_sv_undef; |
c94afdc4 |
527 | |
528 | |
529 | MODULE = Class::MOP PACKAGE = Class::MOP::Class |
530 | |
531 | void |
532 | get_method_map(self) |
00c93f7a |
533 | SV *self |
c200a770 |
534 | PREINIT: |
c686d0ed |
535 | HV *const obj = (HV *)SvRV(self); |
536 | SV *const class_name = HeVAL( hv_fetch_ent(obj, key_package, 0, hash_package) ); |
537 | HV *const stash = gv_stashsv(class_name, 0); |
c200a770 |
538 | UV const current = check_package_cache_flag(stash); |
c686d0ed |
539 | SV *const cache_flag = HeVAL( hv_fetch_ent(obj, key_package_cache_flag, TRUE, hash_package_cache_flag)); |
540 | SV *const map_ref = HeVAL( hv_fetch_ent(obj, key_methods, TRUE, hash_methods)); |
c200a770 |
541 | PPCODE: |
c200a770 |
542 | /* in $self->{methods} does not yet exist (or got deleted) */ |
c686d0ed |
543 | if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) { |
00c93f7a |
544 | SV *new_map_ref = newRV_noinc((SV *)newHV()); |
c200a770 |
545 | sv_2mortal(new_map_ref); |
546 | sv_setsv(map_ref, new_map_ref); |
547 | } |
c94afdc4 |
548 | |
c686d0ed |
549 | if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) { |
00c93f7a |
550 | mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref)); |
c200a770 |
551 | sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */ |
c200a770 |
552 | } |
553 | |
554 | XPUSHs(map_ref); |