Commit | Line | Data |
---|---|---|
e1a479c5 BB |
1 | /* mro.c |
2 | * | |
3 | * Copyright (c) 2007 Brandon L Black | |
1129b882 | 4 | * Copyright (c) 2007, 2008 Larry Wall and others |
e1a479c5 BB |
5 | * |
6 | * You may distribute under the terms of either the GNU General Public | |
7 | * License or the Artistic License, as specified in the README file. | |
8 | * | |
9 | */ | |
10 | ||
11 | /* | |
4ac71550 TC |
12 | * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first? |
13 | * You'll be last either way, Master Peregrin.' | |
14 | * | |
15 | * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"] | |
cac98860 RGS |
16 | */ |
17 | ||
18 | /* | |
e1a479c5 BB |
19 | =head1 MRO Functions |
20 | ||
21 | These functions are related to the method resolution order of perl classes | |
22 | ||
23 | =cut | |
24 | */ | |
25 | ||
26 | #include "EXTERN.h" | |
4befac30 | 27 | #define PERL_IN_MRO_C |
e1a479c5 BB |
28 | #include "perl.h" |
29 | ||
a3e6e81e NC |
30 | static const struct mro_alg dfs_alg = |
31 | {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0}; | |
3d76853f | 32 | |
fa60396f NC |
33 | SV * |
34 | Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta, | |
35 | const struct mro_alg *const which) | |
36 | { | |
37 | SV **data; | |
38 | PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA; | |
39 | ||
40 | data = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL, | |
41 | which->name, which->length, which->kflags, | |
42 | HV_FETCH_JUST_SV, NULL, which->hash); | |
43 | if (!data) | |
44 | return NULL; | |
45 | ||
46 | /* If we've been asked to look up the private data for the current MRO, then | |
47 | cache it. */ | |
48 | if (smeta->mro_which == which) | |
49 | smeta->mro_linear_c3 = MUTABLE_AV(*data); | |
50 | ||
51 | return *data; | |
52 | } | |
53 | ||
54 | SV * | |
55 | Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta, | |
56 | const struct mro_alg *const which, SV *const data) | |
57 | { | |
58 | PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA; | |
59 | ||
fa60396f | 60 | if (!smeta->mro_linear_dfs) { |
553e831a NC |
61 | if (smeta->mro_which == which) { |
62 | /* If all we need to store is the current MRO's data, then don't use | |
63 | memory on a hash with 1 element - store it direct, and signal | |
64 | this by leaving the would-be-hash NULL. */ | |
65 | smeta->mro_linear_c3 = MUTABLE_AV(data); | |
66 | return data; | |
67 | } else { | |
68 | HV *const hv = newHV(); | |
69 | /* Start with 2 buckets. It's unlikely we'll need more. */ | |
70 | HvMAX(hv) = 1; | |
71 | smeta->mro_linear_dfs = MUTABLE_AV(hv); | |
72 | ||
73 | if (smeta->mro_linear_c3) { | |
74 | /* If we were storing something directly, put it in the hash | |
75 | before we lose it. */ | |
76 | Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, | |
77 | MUTABLE_SV(smeta->mro_linear_c3)); | |
78 | } | |
79 | } | |
80 | } | |
81 | ||
82 | /* We get here if we're storing more than one linearisation for this stash, | |
83 | or the linearisation we are storing is not that if its current MRO. */ | |
84 | ||
85 | if (smeta->mro_which == which) { | |
86 | /* If we've been asked to store the private data for the current MRO, | |
87 | then cache it. */ | |
88 | smeta->mro_linear_c3 = MUTABLE_AV(data); | |
fa60396f NC |
89 | } |
90 | ||
91 | if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL, | |
92 | which->name, which->length, which->kflags, | |
93 | HV_FETCH_ISSTORE, data, which->hash)) { | |
94 | Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() " | |
95 | "for '%.*s' %d", (int) which->length, which->name, | |
96 | which->kflags); | |
97 | } | |
98 | ||
99 | return data; | |
100 | } | |
101 | ||
a3e6e81e NC |
102 | const struct mro_alg * |
103 | Perl_mro_get_from_name(pTHX_ SV *name) { | |
104 | SV **data; | |
105 | ||
106 | PERL_ARGS_ASSERT_MRO_GET_FROM_NAME; | |
107 | ||
108 | data = Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0, | |
109 | HV_FETCH_JUST_SV, NULL, 0); | |
110 | if (!data) | |
111 | return NULL; | |
112 | assert(SvTYPE(*data) == SVt_IV); | |
113 | assert(SvIOK(*data)); | |
114 | return INT2PTR(const struct mro_alg *, SvUVX(*data)); | |
115 | } | |
116 | ||
117 | void | |
118 | Perl_mro_register(pTHX_ const struct mro_alg *mro) { | |
119 | SV *wrapper = newSVuv(PTR2UV(mro)); | |
120 | ||
121 | PERL_ARGS_ASSERT_MRO_REGISTER; | |
122 | ||
123 | ||
124 | if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL, | |
125 | mro->name, mro->length, mro->kflags, | |
126 | HV_FETCH_ISSTORE, wrapper, mro->hash)) { | |
127 | SvREFCNT_dec(wrapper); | |
128 | Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() " | |
129 | "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags); | |
3d76853f | 130 | } |
3d76853f NC |
131 | } |
132 | ||
e1a479c5 BB |
133 | struct mro_meta* |
134 | Perl_mro_meta_init(pTHX_ HV* stash) | |
135 | { | |
9fe4aecf | 136 | struct mro_meta* newmeta; |
e1a479c5 | 137 | |
7918f24d | 138 | PERL_ARGS_ASSERT_MRO_META_INIT; |
e1a479c5 BB |
139 | assert(HvAUX(stash)); |
140 | assert(!(HvAUX(stash)->xhv_mro_meta)); | |
183086be | 141 | Newxz(newmeta, 1, struct mro_meta); |
9fe4aecf | 142 | HvAUX(stash)->xhv_mro_meta = newmeta; |
dd69841b | 143 | newmeta->cache_gen = 1; |
70cd14a1 | 144 | newmeta->pkg_gen = 1; |
a3e6e81e | 145 | newmeta->mro_which = &dfs_alg; |
e1a479c5 BB |
146 | |
147 | return newmeta; | |
148 | } | |
149 | ||
150 | #if defined(USE_ITHREADS) | |
151 | ||
152 | /* for sv_dup on new threads */ | |
153 | struct mro_meta* | |
154 | Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param) | |
155 | { | |
e1a479c5 BB |
156 | struct mro_meta* newmeta; |
157 | ||
7918f24d | 158 | PERL_ARGS_ASSERT_MRO_META_DUP; |
e1a479c5 | 159 | |
33e12d9d NC |
160 | Newx(newmeta, 1, struct mro_meta); |
161 | Copy(smeta, newmeta, 1, struct mro_meta); | |
162 | ||
553e831a | 163 | if (newmeta->mro_linear_dfs) { |
33e12d9d | 164 | newmeta->mro_linear_dfs |
ad64d0ec | 165 | = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param))); |
553e831a NC |
166 | /* This is just acting as a shortcut pointer, and will be automatically |
167 | updated on the first get. */ | |
168 | newmeta->mro_linear_c3 = NULL; | |
169 | } else if (newmeta->mro_linear_c3) { | |
170 | /* Only the current MRO is stored, so this owns the data. */ | |
171 | newmeta->mro_linear_c3 | |
172 | = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_c3, param))); | |
173 | } | |
174 | ||
33e12d9d NC |
175 | if (newmeta->mro_nextmethod) |
176 | newmeta->mro_nextmethod | |
ad64d0ec | 177 | = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param))); |
a49ba3fc NC |
178 | if (newmeta->isa) |
179 | newmeta->isa | |
ad64d0ec | 180 | = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param))); |
e1a479c5 BB |
181 | |
182 | return newmeta; | |
183 | } | |
184 | ||
185 | #endif /* USE_ITHREADS */ | |
186 | ||
a49ba3fc NC |
187 | HV * |
188 | Perl_get_isa_hash(pTHX_ HV *const stash) | |
189 | { | |
190 | dVAR; | |
191 | struct mro_meta *const meta = HvMROMETA(stash); | |
192 | ||
193 | PERL_ARGS_ASSERT_GET_ISA_HASH; | |
194 | ||
6e4aef59 NC |
195 | if (!meta->isa) { |
196 | AV *const isa = mro_get_linear_isa(stash); | |
197 | if (!meta->isa) { | |
198 | HV *const isa_hash = newHV(); | |
199 | /* Linearisation didn't build it for us, so do it here. */ | |
200 | SV *const *svp = AvARRAY(isa); | |
201 | SV *const *const svp_end = svp + AvFILLp(isa) + 1; | |
202 | const HEK *const canon_name = HvNAME_HEK(stash); | |
203 | ||
204 | while (svp < svp_end) { | |
205 | (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); | |
206 | } | |
207 | ||
208 | (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), | |
209 | HEK_LEN(canon_name), HEK_FLAGS(canon_name), | |
210 | HV_FETCH_ISSTORE, &PL_sv_undef, | |
211 | HEK_HASH(canon_name)); | |
212 | (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0); | |
213 | ||
ed09b296 NC |
214 | SvREADONLY_on(isa_hash); |
215 | ||
6e4aef59 NC |
216 | meta->isa = isa_hash; |
217 | } | |
218 | } | |
a49ba3fc NC |
219 | return meta->isa; |
220 | } | |
221 | ||
e1a479c5 BB |
222 | /* |
223 | =for apidoc mro_get_linear_isa_dfs | |
224 | ||
225 | Returns the Depth-First Search linearization of @ISA | |
226 | the given stash. The return value is a read-only AV*. | |
227 | C<level> should be 0 (it is used internally in this | |
228 | function's recursion). | |
229 | ||
1c908217 RGS |
230 | You are responsible for C<SvREFCNT_inc()> on the |
231 | return value if you plan to store it anywhere | |
232 | semi-permanently (otherwise it might be deleted | |
233 | out from under you the next time the cache is | |
234 | invalidated). | |
235 | ||
e1a479c5 BB |
236 | =cut |
237 | */ | |
4befac30 | 238 | static AV* |
94d1e706 | 239 | S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level) |
e1a479c5 BB |
240 | { |
241 | AV* retval; | |
242 | GV** gvp; | |
243 | GV* gv; | |
244 | AV* av; | |
190d0b22 | 245 | const HEK* stashhek; |
e1a479c5 | 246 | struct mro_meta* meta; |
a49ba3fc NC |
247 | SV *our_name; |
248 | HV *stored; | |
e1a479c5 | 249 | |
7918f24d | 250 | PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS; |
e1a479c5 BB |
251 | assert(HvAUX(stash)); |
252 | ||
190d0b22 NC |
253 | stashhek = HvNAME_HEK(stash); |
254 | if (!stashhek) | |
1e05feb3 | 255 | Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); |
e1a479c5 BB |
256 | |
257 | if (level > 100) | |
258 | Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", | |
190d0b22 | 259 | HEK_KEY(stashhek)); |
e1a479c5 BB |
260 | |
261 | meta = HvMROMETA(stash); | |
1c908217 RGS |
262 | |
263 | /* return cache if valid */ | |
a3e6e81e | 264 | if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) { |
e1a479c5 BB |
265 | return retval; |
266 | } | |
267 | ||
268 | /* not in cache, make a new one */ | |
1c908217 | 269 | |
ad64d0ec | 270 | retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV()))); |
a49ba3fc NC |
271 | /* We use this later in this function, but don't need a reference to it |
272 | beyond the end of this function, so reference count is fine. */ | |
273 | our_name = newSVhek(stashhek); | |
274 | av_push(retval, our_name); /* add ourselves at the top */ | |
e1a479c5 | 275 | |
1c908217 | 276 | /* fetch our @ISA */ |
e1a479c5 BB |
277 | gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); |
278 | av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL; | |
279 | ||
a49ba3fc NC |
280 | /* "stored" is used to keep track of all of the classnames we have added to |
281 | the MRO so far, so we can do a quick exists check and avoid adding | |
282 | duplicate classnames to the MRO as we go. | |
283 | It's then retained to be re-used as a fast lookup for ->isa(), by adding | |
284 | our own name and "UNIVERSAL" to it. */ | |
285 | ||
ad64d0ec | 286 | stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV()))); |
1c908217 | 287 | |
a49ba3fc | 288 | if(av && AvFILLp(av) >= 0) { |
1c908217 | 289 | |
ffd8da72 NC |
290 | SV **svp = AvARRAY(av); |
291 | I32 items = AvFILLp(av) + 1; | |
1c908217 RGS |
292 | |
293 | /* foreach(@ISA) */ | |
e1a479c5 BB |
294 | while (items--) { |
295 | SV* const sv = *svp++; | |
296 | HV* const basestash = gv_stashsv(sv, 0); | |
ffd8da72 NC |
297 | SV *const *subrv_p; |
298 | I32 subrv_items; | |
e1a479c5 BB |
299 | |
300 | if (!basestash) { | |
1c908217 RGS |
301 | /* if no stash exists for this @ISA member, |
302 | simply add it to the MRO and move on */ | |
ffd8da72 NC |
303 | subrv_p = &sv; |
304 | subrv_items = 1; | |
e1a479c5 BB |
305 | } |
306 | else { | |
1c908217 | 307 | /* otherwise, recurse into ourselves for the MRO |
b1d0c68a NC |
308 | of this @ISA member, and append their MRO to ours. |
309 | The recursive call could throw an exception, which | |
310 | has memory management implications here, hence the use of | |
311 | the mortal. */ | |
ffd8da72 NC |
312 | const AV *const subrv |
313 | = mro_get_linear_isa_dfs(basestash, level + 1); | |
314 | ||
315 | subrv_p = AvARRAY(subrv); | |
316 | subrv_items = AvFILLp(subrv) + 1; | |
317 | } | |
318 | while(subrv_items--) { | |
319 | SV *const subsv = *subrv_p++; | |
8e45cc2b NC |
320 | /* LVALUE fetch will create a new undefined SV if necessary |
321 | */ | |
322 | HE *const he = hv_fetch_ent(stored, subsv, 1, 0); | |
323 | assert(he); | |
324 | if(HeVAL(he) != &PL_sv_undef) { | |
325 | /* It was newly created. Steal it for our new SV, and | |
326 | replace it in the hash with the "real" thing. */ | |
327 | SV *const val = HeVAL(he); | |
f46ee248 | 328 | HEK *const key = HeKEY_hek(he); |
8e45cc2b NC |
329 | |
330 | HeVAL(he) = &PL_sv_undef; | |
f46ee248 NC |
331 | /* Save copying by making a shared hash key scalar. We |
332 | inline this here rather than calling Perl_newSVpvn_share | |
333 | because we already have the scalar, and we already have | |
334 | the hash key. */ | |
335 | assert(SvTYPE(val) == SVt_NULL); | |
336 | sv_upgrade(val, SVt_PV); | |
337 | SvPV_set(val, HEK_KEY(share_hek_hek(key))); | |
338 | SvCUR_set(val, HEK_LEN(key)); | |
339 | SvREADONLY_on(val); | |
340 | SvFAKE_on(val); | |
341 | SvPOK_on(val); | |
342 | if (HEK_UTF8(key)) | |
343 | SvUTF8_on(val); | |
344 | ||
8e45cc2b | 345 | av_push(retval, val); |
ffd8da72 | 346 | } |
e1a479c5 BB |
347 | } |
348 | } | |
349 | } | |
350 | ||
ed09b296 NC |
351 | (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0); |
352 | (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0); | |
353 | ||
354 | SvREFCNT_inc_simple_void_NN(stored); | |
355 | SvTEMP_off(stored); | |
356 | SvREADONLY_on(stored); | |
357 | ||
358 | meta->isa = stored; | |
359 | ||
0fd7ece8 NC |
360 | /* now that we're past the exception dangers, grab our own reference to |
361 | the AV we're about to use for the result. The reference owned by the | |
362 | mortals' stack will be released soon, so everything will balance. */ | |
363 | SvREFCNT_inc_simple_void_NN(retval); | |
364 | SvTEMP_off(retval); | |
fdef73f9 | 365 | |
1c908217 RGS |
366 | /* we don't want anyone modifying the cache entry but us, |
367 | and we do so by replacing it completely */ | |
e1a479c5 | 368 | SvREADONLY_on(retval); |
1c908217 | 369 | |
a3e6e81e | 370 | return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg, |
fa60396f | 371 | MUTABLE_SV(retval))); |
e1a479c5 BB |
372 | } |
373 | ||
374 | /* | |
e1a479c5 BB |
375 | =for apidoc mro_get_linear_isa |
376 | ||
377 | Returns either C<mro_get_linear_isa_c3> or | |
378 | C<mro_get_linear_isa_dfs> for the given stash, | |
379 | dependant upon which MRO is in effect | |
380 | for that stash. The return value is a | |
381 | read-only AV*. | |
382 | ||
1c908217 RGS |
383 | You are responsible for C<SvREFCNT_inc()> on the |
384 | return value if you plan to store it anywhere | |
385 | semi-permanently (otherwise it might be deleted | |
386 | out from under you the next time the cache is | |
387 | invalidated). | |
388 | ||
e1a479c5 BB |
389 | =cut |
390 | */ | |
391 | AV* | |
392 | Perl_mro_get_linear_isa(pTHX_ HV *stash) | |
393 | { | |
394 | struct mro_meta* meta; | |
2c7f4b87 | 395 | |
7918f24d | 396 | PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA; |
2c7f4b87 BB |
397 | if(!SvOOK(stash)) |
398 | Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); | |
e1a479c5 BB |
399 | |
400 | meta = HvMROMETA(stash); | |
3d76853f | 401 | if (!meta->mro_which) |
14f97ce6 | 402 | Perl_croak(aTHX_ "panic: invalid MRO!"); |
3d76853f | 403 | return meta->mro_which->resolve(aTHX_ stash, 0); |
e1a479c5 BB |
404 | } |
405 | ||
406 | /* | |
407 | =for apidoc mro_isa_changed_in | |
408 | ||
1c908217 | 409 | Takes the necessary steps (cache invalidations, mostly) |
e1a479c5 BB |
410 | when the @ISA of the given package has changed. Invoked |
411 | by the C<setisa> magic, should not need to invoke directly. | |
412 | ||
413 | =cut | |
414 | */ | |
415 | void | |
416 | Perl_mro_isa_changed_in(pTHX_ HV* stash) | |
417 | { | |
418 | dVAR; | |
419 | HV* isarev; | |
420 | AV* linear_mro; | |
421 | HE* iter; | |
422 | SV** svp; | |
423 | I32 items; | |
1e05feb3 | 424 | bool is_universal; |
2c7f4b87 | 425 | struct mro_meta * meta; |
e1a479c5 | 426 | |
0fa56319 RGS |
427 | const char * const stashname = HvNAME_get(stash); |
428 | const STRLEN stashname_len = HvNAMELEN_get(stash); | |
e1a479c5 | 429 | |
7918f24d NC |
430 | PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN; |
431 | ||
2c7f4b87 BB |
432 | if(!stashname) |
433 | Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table"); | |
434 | ||
e1a479c5 | 435 | /* wipe out the cached linearizations for this stash */ |
2c7f4b87 | 436 | meta = HvMROMETA(stash); |
553e831a NC |
437 | if (meta->mro_linear_dfs) { |
438 | SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs)); | |
439 | meta->mro_linear_dfs = NULL; | |
440 | /* This is just acting as a shortcut pointer. */ | |
441 | meta->mro_linear_c3 = NULL; | |
442 | } else if (meta->mro_linear_c3) { | |
443 | /* Only the current MRO is stored, so this owns the data. */ | |
444 | SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3)); | |
445 | meta->mro_linear_c3 = NULL; | |
446 | } | |
5782d502 NC |
447 | if (meta->isa) { |
448 | SvREFCNT_dec(meta->isa); | |
449 | meta->isa = NULL; | |
450 | } | |
e1a479c5 | 451 | |
70cd14a1 CB |
452 | /* Inc the package generation, since our @ISA changed */ |
453 | meta->pkg_gen++; | |
454 | ||
e1a479c5 BB |
455 | /* Wipe the global method cache if this package |
456 | is UNIVERSAL or one of its parents */ | |
dd69841b BB |
457 | |
458 | svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); | |
85fbaab2 | 459 | isarev = svp ? MUTABLE_HV(*svp) : NULL; |
dd69841b BB |
460 | |
461 | if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) | |
462 | || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { | |
e1a479c5 | 463 | PL_sub_generation++; |
dd69841b BB |
464 | is_universal = TRUE; |
465 | } | |
1e05feb3 | 466 | else { /* Wipe the local method cache otherwise */ |
dd69841b | 467 | meta->cache_gen++; |
1e05feb3 AL |
468 | is_universal = FALSE; |
469 | } | |
e1a479c5 BB |
470 | |
471 | /* wipe next::method cache too */ | |
472 | if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod); | |
1e05feb3 | 473 | |
e1a479c5 BB |
474 | /* Iterate the isarev (classes that are our children), |
475 | wiping out their linearization and method caches */ | |
dd69841b | 476 | if(isarev) { |
e1a479c5 BB |
477 | hv_iterinit(isarev); |
478 | while((iter = hv_iternext(isarev))) { | |
ec49eb61 NC |
479 | I32 len; |
480 | const char* const revkey = hv_iterkey(iter, &len); | |
481 | HV* revstash = gv_stashpvn(revkey, len, 0); | |
bc2cbbac BB |
482 | struct mro_meta* revmeta; |
483 | ||
484 | if(!revstash) continue; | |
485 | revmeta = HvMROMETA(revstash); | |
553e831a NC |
486 | if (revmeta->mro_linear_dfs) { |
487 | SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs)); | |
488 | revmeta->mro_linear_dfs = NULL; | |
489 | /* This is just acting as a shortcut pointer. */ | |
490 | revmeta->mro_linear_c3 = NULL; | |
491 | } else if (revmeta->mro_linear_c3) { | |
492 | /* Only the current MRO is stored, so this owns the data. */ | |
493 | SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3)); | |
494 | revmeta->mro_linear_c3 = NULL; | |
495 | } | |
dd69841b BB |
496 | if(!is_universal) |
497 | revmeta->cache_gen++; | |
e1a479c5 BB |
498 | if(revmeta->mro_nextmethod) |
499 | hv_clear(revmeta->mro_nextmethod); | |
500 | } | |
501 | } | |
502 | ||
1c908217 RGS |
503 | /* Now iterate our MRO (parents), and do a few things: |
504 | 1) instantiate with the "fake" flag if they don't exist | |
505 | 2) flag them as universal if we are universal | |
506 | 3) Add everything from our isarev to their isarev | |
507 | */ | |
508 | ||
509 | /* We're starting at the 2nd element, skipping ourselves here */ | |
e1a479c5 BB |
510 | linear_mro = mro_get_linear_isa(stash); |
511 | svp = AvARRAY(linear_mro) + 1; | |
512 | items = AvFILLp(linear_mro); | |
1c908217 | 513 | |
e1a479c5 BB |
514 | while (items--) { |
515 | SV* const sv = *svp++; | |
e1a479c5 BB |
516 | HV* mroisarev; |
517 | ||
117b69ca NC |
518 | HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0); |
519 | ||
520 | /* That fetch should not fail. But if it had to create a new SV for | |
4ea50411 NC |
521 | us, then will need to upgrade it to an HV (which sv_upgrade() can |
522 | now do for us. */ | |
117b69ca | 523 | |
85fbaab2 | 524 | mroisarev = MUTABLE_HV(HeVAL(he)); |
e1a479c5 | 525 | |
ad64d0ec | 526 | SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV); |
117b69ca | 527 | |
25270bc0 NC |
528 | /* This hash only ever contains PL_sv_yes. Storing it over itself is |
529 | almost as cheap as calling hv_exists, so on aggregate we expect to | |
530 | save time by not making two calls to the common HV code for the | |
531 | case where it doesn't exist. */ | |
532 | ||
04fe65b0 | 533 | (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0); |
e1a479c5 BB |
534 | |
535 | if(isarev) { | |
536 | hv_iterinit(isarev); | |
537 | while((iter = hv_iternext(isarev))) { | |
dd69841b | 538 | I32 revkeylen; |
1e05feb3 | 539 | char* const revkey = hv_iterkey(iter, &revkeylen); |
04fe65b0 | 540 | (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0); |
e1a479c5 BB |
541 | } |
542 | } | |
543 | } | |
544 | } | |
545 | ||
546 | /* | |
547 | =for apidoc mro_method_changed_in | |
548 | ||
47c9dd14 BB |
549 | Invalidates method caching on any child classes |
550 | of the given stash, so that they might notice | |
551 | the changes in this one. | |
e1a479c5 BB |
552 | |
553 | Ideally, all instances of C<PL_sub_generation++> in | |
dd69841b BB |
554 | perl source outside of C<mro.c> should be |
555 | replaced by calls to this. | |
556 | ||
557 | Perl automatically handles most of the common | |
558 | ways a method might be redefined. However, there | |
559 | are a few ways you could change a method in a stash | |
560 | without the cache code noticing, in which case you | |
561 | need to call this method afterwards: | |
e1a479c5 | 562 | |
dd69841b BB |
563 | 1) Directly manipulating the stash HV entries from |
564 | XS code. | |
e1a479c5 | 565 | |
dd69841b BB |
566 | 2) Assigning a reference to a readonly scalar |
567 | constant into a stash entry in order to create | |
568 | a constant subroutine (like constant.pm | |
569 | does). | |
570 | ||
571 | This same method is available from pure perl | |
572 | via, C<mro::method_changed_in(classname)>. | |
e1a479c5 BB |
573 | |
574 | =cut | |
575 | */ | |
576 | void | |
577 | Perl_mro_method_changed_in(pTHX_ HV *stash) | |
578 | { | |
1e05feb3 AL |
579 | const char * const stashname = HvNAME_get(stash); |
580 | const STRLEN stashname_len = HvNAMELEN_get(stash); | |
dd69841b | 581 | |
1e05feb3 | 582 | SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0); |
85fbaab2 | 583 | HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL; |
e1a479c5 | 584 | |
7918f24d NC |
585 | PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN; |
586 | ||
2c7f4b87 BB |
587 | if(!stashname) |
588 | Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table"); | |
589 | ||
70cd14a1 CB |
590 | /* Inc the package generation, since a local method changed */ |
591 | HvMROMETA(stash)->pkg_gen++; | |
592 | ||
e1a479c5 BB |
593 | /* If stash is UNIVERSAL, or one of UNIVERSAL's parents, |
594 | invalidate all method caches globally */ | |
dd69841b BB |
595 | if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL")) |
596 | || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) { | |
e1a479c5 BB |
597 | PL_sub_generation++; |
598 | return; | |
599 | } | |
600 | ||
601 | /* else, invalidate the method caches of all child classes, | |
602 | but not itself */ | |
dd69841b | 603 | if(isarev) { |
1e05feb3 AL |
604 | HE* iter; |
605 | ||
e1a479c5 BB |
606 | hv_iterinit(isarev); |
607 | while((iter = hv_iternext(isarev))) { | |
ec49eb61 NC |
608 | I32 len; |
609 | const char* const revkey = hv_iterkey(iter, &len); | |
610 | HV* const revstash = gv_stashpvn(revkey, len, 0); | |
bc2cbbac BB |
611 | struct mro_meta* mrometa; |
612 | ||
613 | if(!revstash) continue; | |
614 | mrometa = HvMROMETA(revstash); | |
dd69841b | 615 | mrometa->cache_gen++; |
e1a479c5 BB |
616 | if(mrometa->mro_nextmethod) |
617 | hv_clear(mrometa->mro_nextmethod); | |
618 | } | |
619 | } | |
620 | } | |
621 | ||
31b9005d NC |
622 | void |
623 | Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name) | |
624 | { | |
625 | const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name); | |
626 | ||
627 | PERL_ARGS_ASSERT_MRO_SET_MRO; | |
628 | ||
629 | if (!which) | |
630 | Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name); | |
631 | ||
632 | if(meta->mro_which != which) { | |
633 | if (meta->mro_linear_c3 && !meta->mro_linear_dfs) { | |
634 | /* If we were storing something directly, put it in the hash before | |
635 | we lose it. */ | |
636 | Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, | |
637 | MUTABLE_SV(meta->mro_linear_c3)); | |
638 | } | |
639 | meta->mro_which = which; | |
640 | /* Scrub our cached pointer to the private data. */ | |
641 | meta->mro_linear_c3 = NULL; | |
642 | /* Only affects local method cache, not | |
643 | even child classes */ | |
644 | meta->cache_gen++; | |
645 | if(meta->mro_nextmethod) | |
646 | hv_clear(meta->mro_nextmethod); | |
647 | } | |
648 | } | |
649 | ||
e1a479c5 BB |
650 | #include "XSUB.h" |
651 | ||
652 | XS(XS_mro_get_linear_isa); | |
653 | XS(XS_mro_set_mro); | |
654 | XS(XS_mro_get_mro); | |
655 | XS(XS_mro_get_isarev); | |
656 | XS(XS_mro_is_universal); | |
c5860d66 | 657 | XS(XS_mro_invalidate_method_caches); |
e1a479c5 | 658 | XS(XS_mro_method_changed_in); |
70cd14a1 | 659 | XS(XS_mro_get_pkg_gen); |
e1a479c5 BB |
660 | |
661 | void | |
662 | Perl_boot_core_mro(pTHX) | |
663 | { | |
664 | dVAR; | |
665 | static const char file[] = __FILE__; | |
666 | ||
a3e6e81e | 667 | Perl_mro_register(aTHX_ &dfs_alg); |
a3e6e81e | 668 | |
e1a479c5 BB |
669 | newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$"); |
670 | newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$"); | |
671 | newXSproto("mro::get_mro", XS_mro_get_mro, file, "$"); | |
672 | newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$"); | |
673 | newXSproto("mro::is_universal", XS_mro_is_universal, file, "$"); | |
c5860d66 | 674 | newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, ""); |
e1a479c5 | 675 | newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$"); |
70cd14a1 | 676 | newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$"); |
e1a479c5 BB |
677 | } |
678 | ||
679 | XS(XS_mro_get_linear_isa) { | |
680 | dVAR; | |
681 | dXSARGS; | |
682 | AV* RETVAL; | |
683 | HV* class_stash; | |
684 | SV* classname; | |
685 | ||
e1a479c5 | 686 | if(items < 1 || items > 2) |
afa74d42 | 687 | croak_xs_usage(cv, "classname [, type ]"); |
e1a479c5 BB |
688 | |
689 | classname = ST(0); | |
690 | class_stash = gv_stashsv(classname, 0); | |
e1a479c5 | 691 | |
70cd14a1 CB |
692 | if(!class_stash) { |
693 | /* No stash exists yet, give them just the classname */ | |
694 | AV* isalin = newAV(); | |
695 | av_push(isalin, newSVsv(classname)); | |
ad64d0ec | 696 | ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin))); |
70cd14a1 CB |
697 | XSRETURN(1); |
698 | } | |
699 | else if(items > 1) { | |
a3e6e81e | 700 | const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1)); |
3d76853f | 701 | if (!algo) |
a3e6e81e | 702 | Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1)); |
84dccb35 | 703 | RETVAL = algo->resolve(aTHX_ class_stash, 0); |
e1a479c5 BB |
704 | } |
705 | else { | |
706 | RETVAL = mro_get_linear_isa(class_stash); | |
707 | } | |
708 | ||
ad64d0ec | 709 | ST(0) = newRV_inc(MUTABLE_SV(RETVAL)); |
e1a479c5 BB |
710 | sv_2mortal(ST(0)); |
711 | XSRETURN(1); | |
712 | } | |
713 | ||
714 | XS(XS_mro_set_mro) | |
715 | { | |
716 | dVAR; | |
717 | dXSARGS; | |
718 | SV* classname; | |
e1a479c5 BB |
719 | HV* class_stash; |
720 | struct mro_meta* meta; | |
721 | ||
e1a479c5 | 722 | if (items != 2) |
afa74d42 | 723 | croak_xs_usage(cv, "classname, type"); |
e1a479c5 BB |
724 | |
725 | classname = ST(0); | |
e1a479c5 BB |
726 | class_stash = gv_stashsv(classname, GV_ADD); |
727 | if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname)); | |
728 | meta = HvMROMETA(class_stash); | |
729 | ||
31b9005d | 730 | Perl_mro_set_mro(aTHX_ meta, ST(1)); |
e1a479c5 BB |
731 | |
732 | XSRETURN_EMPTY; | |
733 | } | |
734 | ||
735 | ||
736 | XS(XS_mro_get_mro) | |
737 | { | |
738 | dVAR; | |
739 | dXSARGS; | |
740 | SV* classname; | |
741 | HV* class_stash; | |
e1a479c5 | 742 | |
e1a479c5 | 743 | if (items != 1) |
afa74d42 | 744 | croak_xs_usage(cv, "classname"); |
e1a479c5 BB |
745 | |
746 | classname = ST(0); | |
747 | class_stash = gv_stashsv(classname, 0); | |
e1a479c5 | 748 | |
3d76853f NC |
749 | ST(0) = sv_2mortal(newSVpv(class_stash |
750 | ? HvMROMETA(class_stash)->mro_which->name | |
751 | : "dfs", 0)); | |
e1a479c5 BB |
752 | XSRETURN(1); |
753 | } | |
754 | ||
755 | XS(XS_mro_get_isarev) | |
756 | { | |
757 | dVAR; | |
758 | dXSARGS; | |
759 | SV* classname; | |
73968c7a | 760 | HE* he; |
e1a479c5 | 761 | HV* isarev; |
70cd14a1 | 762 | AV* ret_array; |
e1a479c5 | 763 | |
e1a479c5 | 764 | if (items != 1) |
afa74d42 | 765 | croak_xs_usage(cv, "classname"); |
e1a479c5 BB |
766 | |
767 | classname = ST(0); | |
768 | ||
e1a479c5 | 769 | SP -= items; |
dd69841b | 770 | |
70cd14a1 | 771 | |
73968c7a | 772 | he = hv_fetch_ent(PL_isarev, classname, 0, 0); |
85fbaab2 | 773 | isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; |
70cd14a1 CB |
774 | |
775 | ret_array = newAV(); | |
dd69841b | 776 | if(isarev) { |
e1a479c5 BB |
777 | HE* iter; |
778 | hv_iterinit(isarev); | |
779 | while((iter = hv_iternext(isarev))) | |
70cd14a1 | 780 | av_push(ret_array, newSVsv(hv_iterkeysv(iter))); |
e1a479c5 | 781 | } |
ad64d0ec | 782 | mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array))); |
e1a479c5 BB |
783 | |
784 | PUTBACK; | |
785 | return; | |
786 | } | |
787 | ||
788 | XS(XS_mro_is_universal) | |
789 | { | |
790 | dVAR; | |
791 | dXSARGS; | |
792 | SV* classname; | |
dd69841b | 793 | HV* isarev; |
70cd14a1 CB |
794 | char* classname_pv; |
795 | STRLEN classname_len; | |
73968c7a | 796 | HE* he; |
e1a479c5 | 797 | |
e1a479c5 | 798 | if (items != 1) |
afa74d42 | 799 | croak_xs_usage(cv, "classname"); |
e1a479c5 BB |
800 | |
801 | classname = ST(0); | |
e1a479c5 | 802 | |
cfff9797 | 803 | classname_pv = SvPV(classname,classname_len); |
dd69841b | 804 | |
73968c7a | 805 | he = hv_fetch_ent(PL_isarev, classname, 0, 0); |
85fbaab2 | 806 | isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL; |
dd69841b | 807 | |
70cd14a1 | 808 | if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL")) |
dd69841b | 809 | || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) |
9edc5bb8 RGS |
810 | XSRETURN_YES; |
811 | else | |
812 | XSRETURN_NO; | |
e1a479c5 BB |
813 | } |
814 | ||
c5860d66 | 815 | XS(XS_mro_invalidate_method_caches) |
e1a479c5 BB |
816 | { |
817 | dVAR; | |
818 | dXSARGS; | |
819 | ||
e1a479c5 | 820 | if (items != 0) |
afa74d42 | 821 | croak_xs_usage(cv, ""); |
e1a479c5 BB |
822 | |
823 | PL_sub_generation++; | |
824 | ||
825 | XSRETURN_EMPTY; | |
826 | } | |
827 | ||
e1a479c5 BB |
828 | XS(XS_mro_method_changed_in) |
829 | { | |
830 | dVAR; | |
831 | dXSARGS; | |
832 | SV* classname; | |
833 | HV* class_stash; | |
834 | ||
e1a479c5 | 835 | if(items != 1) |
afa74d42 | 836 | croak_xs_usage(cv, "classname"); |
e1a479c5 BB |
837 | |
838 | classname = ST(0); | |
839 | ||
840 | class_stash = gv_stashsv(classname, 0); | |
841 | if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname)); | |
842 | ||
843 | mro_method_changed_in(class_stash); | |
844 | ||
845 | XSRETURN_EMPTY; | |
846 | } | |
847 | ||
70cd14a1 CB |
848 | XS(XS_mro_get_pkg_gen) |
849 | { | |
850 | dVAR; | |
851 | dXSARGS; | |
852 | SV* classname; | |
853 | HV* class_stash; | |
854 | ||
70cd14a1 | 855 | if(items != 1) |
afa74d42 | 856 | croak_xs_usage(cv, "classname"); |
70cd14a1 CB |
857 | |
858 | classname = ST(0); | |
859 | ||
860 | class_stash = gv_stashsv(classname, 0); | |
861 | ||
862 | SP -= items; | |
863 | ||
6e449a3a | 864 | mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0); |
70cd14a1 CB |
865 | |
866 | PUTBACK; | |
867 | return; | |
868 | } | |
869 | ||
e1a479c5 BB |
870 | /* |
871 | * Local variables: | |
872 | * c-indentation-style: bsd | |
873 | * c-basic-offset: 4 | |
874 | * indent-tabs-mode: t | |
875 | * End: | |
876 | * | |
877 | * ex: set ts=8 sts=4 sw=4 noet: | |
878 | */ |