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 | |
cc856b56 |
17 | SV *key_name; |
18 | U32 hash_name; |
19 | |
20 | SV *key_package; |
21 | U32 hash_package; |
22 | |
da88f307 |
23 | SV *key_package_name; |
24 | U32 hash_package_name; |
25 | |
cc856b56 |
26 | SV *key_body; |
27 | U32 hash_body; |
28 | |
c686d0ed |
29 | SV *key_package_cache_flag; |
30 | U32 hash_package_cache_flag; |
31 | |
32 | SV *key_methods; |
33 | U32 hash_methods; |
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) |
41 | #ifdef HvMROMETA /* 5.10.0 */ |
42 | |
43 | #ifndef mro_meta_init |
44 | #define mro_meta_init(stash) Perl_mro_meta_init(aTHX_ stash) /* used in HvMROMETA macro */ |
45 | #endif /* !mro_meta_init */ |
46 | |
47 | static UV |
48 | mop_check_package_cache_flag(pTHX_ HV* stash) { |
49 | assert(SvTYPE(stash) == SVt_PVHV); |
50 | |
51 | return HvMROMETA(stash)->pkg_gen; /* mro::get_pkg_gen($pkg) */ |
52 | } |
53 | |
54 | #else /* pre 5.10.0 */ |
55 | |
56 | static UV |
00c93f7a |
57 | mop_check_package_cache_flag(pTHX_ HV *stash) { |
c94afdc4 |
58 | PERL_UNUSED_ARG(stash); |
59 | assert(SvTYPE(stash) == SVt_PVHV); |
60 | |
61 | return PL_sub_generation; |
62 | } |
63 | #endif |
64 | |
65 | #define call0(s, m) mop_call0(aTHX_ s, m) |
00c93f7a |
66 | static SV * |
67 | mop_call0(pTHX_ SV *const self, SV *const method) { |
c94afdc4 |
68 | dSP; |
00c93f7a |
69 | SV *ret; |
c94afdc4 |
70 | |
71 | PUSHMARK(SP); |
72 | XPUSHs(self); |
73 | PUTBACK; |
74 | |
75 | call_sv(method, G_SCALAR | G_METHOD); |
76 | |
77 | SPAGAIN; |
78 | ret = POPs; |
79 | PUTBACK; |
80 | |
81 | return ret; |
82 | } |
83 | |
ee82a43e |
84 | static int |
0e0b5b8d |
85 | get_code_info (SV *coderef, char **pkg, char **name) |
86 | { |
87 | if (!SvOK(coderef) || !SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) { |
88 | return 0; |
89 | } |
6bd19edb |
90 | |
0e0b5b8d |
91 | coderef = SvRV(coderef); |
92 | /* I think this only gets triggered with a mangled coderef, but if |
93 | we hit it without the guard, we segfault. The slightly odd return |
94 | value strikes me as an improvement (mst) |
95 | */ |
96 | #ifdef isGV_with_GP |
97 | if ( isGV_with_GP(CvGV(coderef)) ) { |
cb0ec494 |
98 | #endif |
0e0b5b8d |
99 | *pkg = HvNAME( GvSTASH(CvGV(coderef)) ); |
100 | *name = GvNAME( CvGV(coderef) ); |
101 | #ifdef isGV_with_GP |
102 | } else { |
103 | *pkg = "__UNKNOWN__"; |
104 | *name = "__ANON__"; |
c94afdc4 |
105 | } |
0e0b5b8d |
106 | #endif |
107 | |
108 | return 1; |
c94afdc4 |
109 | } |
110 | |
b49ee39f |
111 | typedef enum { |
112 | TYPE_FILTER_NONE, |
113 | TYPE_FILTER_CODE, |
114 | TYPE_FILTER_ARRAY, |
115 | TYPE_FILTER_IO, |
116 | TYPE_FILTER_HASH, |
117 | TYPE_FILTER_SCALAR, |
118 | } type_filter_t; |
119 | |
120 | static HV * |
121 | get_all_package_symbols(HV *stash, type_filter_t filter) |
122 | { |
123 | HE *he; |
124 | HV *ret = newHV(); |
125 | |
126 | (void)hv_iterinit(stash); |
127 | |
128 | if (filter == TYPE_FILTER_NONE) { |
129 | while ( (he = hv_iternext(stash)) ) { |
130 | STRLEN keylen; |
131 | char *key = HePV(he, keylen); |
7291ecef |
132 | if (!hv_store(ret, key, keylen, SvREFCNT_inc(HeVAL(he)), 0)) { |
133 | croak("failed to store glob ref"); |
134 | } |
b49ee39f |
135 | } |
136 | |
137 | return ret; |
138 | } |
139 | |
140 | while ( (he = hv_iternext(stash)) ) { |
141 | SV *const gv = HeVAL(he); |
142 | SV *sv = NULL; |
143 | char *key; |
144 | STRLEN keylen; |
145 | char *package; |
146 | SV *fq; |
147 | |
148 | switch( SvTYPE(gv) ) { |
149 | #ifndef SVt_RV |
150 | case SVt_RV: |
151 | #endif |
152 | case SVt_PV: |
153 | case SVt_IV: |
154 | /* expand the gv into a real typeglob if it |
155 | * contains stub functions and we were asked to |
156 | * return CODE symbols */ |
157 | if (filter == TYPE_FILTER_CODE) { |
158 | if (SvROK(gv)) { |
159 | /* we don't really care about the length, |
160 | but that's the API */ |
161 | key = HePV(he, keylen); |
162 | package = HvNAME(stash); |
163 | fq = newSVpvf("%s::%s", package, key); |
164 | sv = (SV *)get_cv(SvPV_nolen(fq), 0); |
165 | break; |
166 | } |
167 | |
168 | key = HePV(he, keylen); |
169 | gv_init((GV *)gv, stash, key, keylen, GV_ADDMULTI); |
170 | } |
171 | /* fall through */ |
172 | case SVt_PVGV: |
173 | switch (filter) { |
174 | case TYPE_FILTER_CODE: sv = (SV *)GvCVu(gv); break; |
175 | case TYPE_FILTER_ARRAY: sv = (SV *)GvAV(gv); break; |
176 | case TYPE_FILTER_IO: sv = (SV *)GvIO(gv); break; |
177 | case TYPE_FILTER_HASH: sv = (SV *)GvHV(gv); break; |
178 | case TYPE_FILTER_SCALAR: sv = (SV *)GvSV(gv); break; |
179 | default: |
180 | croak("Unknown type"); |
181 | } |
182 | break; |
183 | default: |
184 | continue; |
185 | } |
186 | |
187 | if (sv) { |
188 | char *key = HePV(he, keylen); |
7291ecef |
189 | if (!hv_store(ret, key, keylen, newRV_inc(sv), 0)) { |
190 | croak("failed to store symbol ref"); |
191 | } |
b49ee39f |
192 | } |
193 | } |
194 | |
195 | return ret; |
196 | } |
c94afdc4 |
197 | |
0e0b5b8d |
198 | |
199 | static void |
00c93f7a |
200 | mop_update_method_map(pTHX_ SV *const self, SV *const class_name, HV *const stash, HV *const map) { |
201 | const char *const class_name_pv = HvNAME(stash); /* must be HvNAME(stash), not SvPV_nolen_const(class_name) */ |
202 | SV *method_metaclass_name; |
203 | char *method_name; |
0e0b5b8d |
204 | I32 method_name_len; |
00c93f7a |
205 | SV *coderef; |
206 | HV *symbols; |
0e0b5b8d |
207 | dSP; |
208 | |
209 | symbols = get_all_package_symbols(stash, TYPE_FILTER_CODE); |
210 | |
211 | (void)hv_iterinit(symbols); |
212 | while ( (coderef = hv_iternextsv(symbols, &method_name, &method_name_len)) ) { |
00c93f7a |
213 | CV *cv = (CV *)SvRV(coderef); |
214 | char *cvpkg_name; |
215 | char *cv_name; |
216 | SV *method_slot; |
217 | SV *method_object; |
0e0b5b8d |
218 | |
219 | if (!get_code_info(coderef, &cvpkg_name, &cv_name)) { |
220 | continue; |
221 | } |
222 | |
223 | /* this checks to see that the subroutine is actually from our package */ |
224 | if ( !(strEQ(cvpkg_name, "constant") && strEQ(cv_name, "__ANON__")) ) { |
225 | if ( strNE(cvpkg_name, class_name_pv) ) { |
226 | continue; |
227 | } |
228 | } |
229 | |
230 | method_slot = *hv_fetch(map, method_name, method_name_len, TRUE); |
231 | if ( SvOK(method_slot) ) { |
6d915932 |
232 | SV *const body = call0(method_slot, key_body); /* $method_object->body() */ |
00c93f7a |
233 | if ( SvROK(body) && ((CV *) SvRV(body)) == cv ) { |
0e0b5b8d |
234 | continue; |
235 | } |
236 | } |
237 | |
238 | method_metaclass_name = call0(self, method_metaclass); /* $self->method_metaclass() */ |
239 | |
240 | /* |
241 | $method_object = $method_metaclass->wrap( |
242 | $cv, |
243 | associated_metaclass => $self, |
244 | package_name => $class_name, |
245 | name => $method_name |
246 | ); |
247 | */ |
248 | ENTER; |
249 | SAVETMPS; |
250 | |
251 | PUSHMARK(SP); |
252 | EXTEND(SP, 8); |
253 | PUSHs(method_metaclass_name); /* invocant */ |
00c93f7a |
254 | mPUSHs(newRV_inc((SV *)cv)); |
0e0b5b8d |
255 | PUSHs(associated_metaclass); |
256 | PUSHs(self); |
257 | PUSHs(key_package_name); |
258 | PUSHs(class_name); |
259 | PUSHs(key_name); |
260 | mPUSHs(newSVpv(method_name, method_name_len)); |
261 | PUTBACK; |
262 | |
263 | call_sv(wrap, G_SCALAR | G_METHOD); |
264 | SPAGAIN; |
265 | method_object = POPs; |
266 | PUTBACK; |
267 | /* $map->{$method_name} = $method_object */ |
268 | sv_setsv(method_slot, method_object); |
269 | |
270 | FREETMPS; |
271 | LEAVE; |
272 | } |
273 | } |
274 | |
e0e4674a |
275 | /* |
e0e4674a |
276 | get_code_info: |
277 | Pass in a coderef, returns: |
278 | [ $pkg_name, $coderef_name ] ie: |
279 | [ 'Foo::Bar', 'new' ] |
280 | */ |
281 | |
282 | MODULE = Class::MOP PACKAGE = Class::MOP |
283 | |
cc856b56 |
284 | BOOT: |
285 | key_name = newSVpvs("name"); |
286 | key_body = newSVpvs("body"); |
287 | key_package = newSVpvs("package"); |
da88f307 |
288 | key_package_name = newSVpvs("package_name"); |
c686d0ed |
289 | key_package_cache_flag = newSVpvs("_package_cache_flag"); |
290 | key_methods = newSVpvs("methods"); |
cc856b56 |
291 | |
292 | PERL_HASH(hash_name, "name", 4); |
293 | PERL_HASH(hash_body, "body", 4); |
294 | PERL_HASH(hash_package, "package", 7); |
da88f307 |
295 | PERL_HASH(hash_package_name, "package_name", 12); |
c686d0ed |
296 | PERL_HASH(hash_package_cache_flag, "_package_cache_flag", 19); |
297 | PERL_HASH(hash_methods, "methods", 7); |
cc856b56 |
298 | |
c94afdc4 |
299 | method_metaclass = newSVpvs("method_metaclass"); |
300 | wrap = newSVpvs("wrap"); |
301 | associated_metaclass = newSVpvs("associated_metaclass"); |
302 | |
cc856b56 |
303 | |
d7bf3478 |
304 | PROTOTYPES: ENABLE |
305 | |
cc856b56 |
306 | |
e0e4674a |
307 | void |
308 | get_code_info(coderef) |
00c93f7a |
309 | SV *coderef |
0e0b5b8d |
310 | PREINIT: |
6d915932 |
311 | char *pkg = NULL; |
312 | char *name = NULL; |
0e0b5b8d |
313 | PPCODE: |
314 | if (get_code_info(coderef, &pkg, &name)) { |
315 | EXTEND(SP, 2); |
316 | PUSHs(newSVpv(pkg, 0)); |
317 | PUSHs(newSVpv(name, 0)); |
318 | } |
e0e4674a |
319 | |
15273f3c |
320 | |
321 | MODULE = Class::MOP PACKAGE = Class::MOP::Package |
322 | |
323 | void |
b49ee39f |
324 | get_all_package_symbols(self, filter=TYPE_FILTER_NONE) |
cc856b56 |
325 | SV *self |
b49ee39f |
326 | type_filter_t filter |
15273f3c |
327 | PROTOTYPE: $;$ |
328 | PREINIT: |
cc856b56 |
329 | HV *stash = NULL; |
b49ee39f |
330 | HV *symbols = NULL; |
75705e60 |
331 | register HE *he; |
15273f3c |
332 | PPCODE: |
a7f711e5 |
333 | if ( ! SvROK(self) ) { |
988fb42e |
334 | die("Cannot call get_all_package_symbols as a class method"); |
335 | } |
15273f3c |
336 | |
b49ee39f |
337 | if (GIMME_V == G_VOID) { |
338 | XSRETURN_EMPTY; |
339 | } |
340 | |
15273f3c |
341 | |
15273f3c |
342 | PUTBACK; |
343 | |
b49ee39f |
344 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) { |
345 | stash = gv_stashsv(HeVAL(he), 0); |
346 | } |
15273f3c |
347 | |
15273f3c |
348 | |
b49ee39f |
349 | if (!stash) { |
6ccb3af5 |
350 | switch (GIMME_V) { |
351 | case G_SCALAR: XSRETURN_UNDEF; break; |
352 | case G_ARRAY: XSRETURN_EMPTY; break; |
353 | } |
b49ee39f |
354 | } |
15273f3c |
355 | |
b49ee39f |
356 | symbols = get_all_package_symbols(stash, filter); |
15273f3c |
357 | |
6ccb3af5 |
358 | switch (GIMME_V) { |
359 | case G_SCALAR: |
360 | PUSHs(sv_2mortal(newRV_inc((SV *)symbols))); |
361 | break; |
362 | case G_ARRAY: |
363 | warn("Class::MOP::Package::get_all_package_symbols in list context is deprecated. use scalar context instead."); |
364 | |
365 | EXTEND(SP, HvKEYS(symbols) * 2); |
366 | |
367 | while ((he = hv_iternext(symbols))) { |
368 | PUSHs(hv_iterkeysv(he)); |
369 | PUSHs(sv_2mortal(SvREFCNT_inc(HeVAL(he)))); |
370 | } |
371 | |
372 | break; |
373 | default: |
374 | break; |
15273f3c |
375 | } |
376 | |
b49ee39f |
377 | SvREFCNT_dec((SV *)symbols); |
378 | |
e2c189ae |
379 | void |
cc856b56 |
380 | name(self) |
381 | SV *self |
382 | PREINIT: |
383 | register HE *he; |
384 | PPCODE: |
a7f711e5 |
385 | if ( ! SvROK(self) ) { |
988fb42e |
386 | die("Cannot call name as a class method"); |
387 | } |
388 | |
e7b69038 |
389 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package, 0, hash_package)) ) |
cc856b56 |
390 | XPUSHs(HeVAL(he)); |
391 | else |
392 | ST(0) = &PL_sv_undef; |
393 | |
dcbfe027 |
394 | MODULE = Class::MOP PACKAGE = Class::MOP::Attribute |
cc856b56 |
395 | |
e2c189ae |
396 | void |
cc856b56 |
397 | name(self) |
398 | SV *self |
399 | PREINIT: |
400 | register HE *he; |
401 | PPCODE: |
a7f711e5 |
402 | if ( ! SvROK(self) ) { |
988fb42e |
403 | die("Cannot call name as a class method"); |
404 | } |
405 | |
e7b69038 |
406 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) ) |
cc856b56 |
407 | XPUSHs(HeVAL(he)); |
408 | else |
409 | ST(0) = &PL_sv_undef; |
410 | |
dcbfe027 |
411 | MODULE = Class::MOP PACKAGE = Class::MOP::Method |
cc856b56 |
412 | |
e2c189ae |
413 | void |
da88f307 |
414 | name(self) |
415 | SV *self |
416 | PREINIT: |
417 | register HE *he; |
418 | PPCODE: |
a7f711e5 |
419 | if ( ! SvROK(self) ) { |
da88f307 |
420 | die("Cannot call name as a class method"); |
421 | } |
422 | |
e7b69038 |
423 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_name, 0, hash_name)) ) |
da88f307 |
424 | XPUSHs(HeVAL(he)); |
425 | else |
426 | ST(0) = &PL_sv_undef; |
427 | |
e2c189ae |
428 | void |
da88f307 |
429 | package_name(self) |
430 | SV *self |
431 | PREINIT: |
432 | register HE *he; |
433 | PPCODE: |
a7f711e5 |
434 | if ( ! SvROK(self) ) { |
da88f307 |
435 | die("Cannot call package_name as a class method"); |
436 | } |
437 | |
e7b69038 |
438 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_package_name, 0, hash_package_name)) ) |
da88f307 |
439 | XPUSHs(HeVAL(he)); |
440 | else |
441 | ST(0) = &PL_sv_undef; |
442 | |
e2c189ae |
443 | void |
cc856b56 |
444 | body(self) |
445 | SV *self |
446 | PREINIT: |
447 | register HE *he; |
448 | PPCODE: |
a7f711e5 |
449 | if ( ! SvROK(self) ) { |
da88f307 |
450 | die("Cannot call body as a class method"); |
451 | } |
452 | |
e7b69038 |
453 | if ( (he = hv_fetch_ent((HV *)SvRV(self), key_body, 0, hash_body)) ) |
cc856b56 |
454 | XPUSHs(HeVAL(he)); |
455 | else |
456 | ST(0) = &PL_sv_undef; |
c94afdc4 |
457 | |
458 | |
459 | MODULE = Class::MOP PACKAGE = Class::MOP::Class |
460 | |
461 | void |
462 | get_method_map(self) |
00c93f7a |
463 | SV *self |
c200a770 |
464 | PREINIT: |
c686d0ed |
465 | HV *const obj = (HV *)SvRV(self); |
466 | SV *const class_name = HeVAL( hv_fetch_ent(obj, key_package, 0, hash_package) ); |
467 | HV *const stash = gv_stashsv(class_name, 0); |
c200a770 |
468 | UV const current = check_package_cache_flag(stash); |
c686d0ed |
469 | SV *const cache_flag = HeVAL( hv_fetch_ent(obj, key_package_cache_flag, TRUE, hash_package_cache_flag)); |
470 | SV *const map_ref = HeVAL( hv_fetch_ent(obj, key_methods, TRUE, hash_methods)); |
c200a770 |
471 | PPCODE: |
c200a770 |
472 | /* in $self->{methods} does not yet exist (or got deleted) */ |
c686d0ed |
473 | if ( !SvROK(map_ref) || SvTYPE(SvRV(map_ref)) != SVt_PVHV ) { |
00c93f7a |
474 | SV *new_map_ref = newRV_noinc((SV *)newHV()); |
c200a770 |
475 | sv_2mortal(new_map_ref); |
476 | sv_setsv(map_ref, new_map_ref); |
477 | } |
c94afdc4 |
478 | |
c686d0ed |
479 | if ( !SvOK(cache_flag) || SvUV(cache_flag) != current ) { |
00c93f7a |
480 | mop_update_method_map(aTHX_ self, class_name, stash, (HV *)SvRV(map_ref)); |
c200a770 |
481 | sv_setuv(cache_flag, check_package_cache_flag(stash)); /* update_cache_flag() */ |
c200a770 |
482 | } |
483 | |
484 | XPUSHs(map_ref); |