This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove redundant call to mro_get_linear_isa
[perl5.git] / mro.c
CommitLineData
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
21These 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
30static const struct mro_alg dfs_alg =
31 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
3d76853f 32
fa60396f
NC
33SV *
34Perl_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
5844ac76
NC
40 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
41 which->name, which->length, which->kflags,
42 HV_FETCH_JUST_SV, NULL, which->hash);
fa60396f
NC
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)
3a6fa573 49 smeta->mro_linear_current = *data;
fa60396f
NC
50
51 return *data;
52}
53
54SV *
55Perl_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
9953ff72 60 if (!smeta->mro_linear_all) {
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. */
3a6fa573 65 smeta->mro_linear_current = data;
553e831a
NC
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;
9953ff72 71 smeta->mro_linear_all = hv;
553e831a 72
3a6fa573 73 if (smeta->mro_linear_current) {
553e831a
NC
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,
3a6fa573 77 smeta->mro_linear_current);
553e831a
NC
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. */
3a6fa573 88 smeta->mro_linear_current = data;
fa60396f
NC
89 }
90
9953ff72 91 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
fa60396f
NC
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
102const struct mro_alg *
103Perl_mro_get_from_name(pTHX_ SV *name) {
104 SV **data;
105
106 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
107
5844ac76
NC
108 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109 HV_FETCH_JUST_SV, NULL, 0);
a3e6e81e
NC
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
117void
118Perl_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
133struct mro_meta*
134Perl_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 */
153struct mro_meta*
154Perl_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
9953ff72
NC
163 if (newmeta->mro_linear_all) {
164 newmeta->mro_linear_all
a09252eb 165 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
553e831a
NC
166 /* This is just acting as a shortcut pointer, and will be automatically
167 updated on the first get. */
3a6fa573
NC
168 newmeta->mro_linear_current = NULL;
169 } else if (newmeta->mro_linear_current) {
553e831a 170 /* Only the current MRO is stored, so this owns the data. */
3a6fa573 171 newmeta->mro_linear_current
a09252eb 172 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
553e831a
NC
173 }
174
33e12d9d
NC
175 if (newmeta->mro_nextmethod)
176 newmeta->mro_nextmethod
a09252eb 177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
a49ba3fc
NC
178 if (newmeta->isa)
179 newmeta->isa
a09252eb 180 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
e1a479c5
BB
181
182 return newmeta;
183}
184
185#endif /* USE_ITHREADS */
186
187/*
188=for apidoc mro_get_linear_isa_dfs
189
190Returns the Depth-First Search linearization of @ISA
191the given stash. The return value is a read-only AV*.
192C<level> should be 0 (it is used internally in this
193function's recursion).
194
1c908217
RGS
195You are responsible for C<SvREFCNT_inc()> on the
196return value if you plan to store it anywhere
197semi-permanently (otherwise it might be deleted
198out from under you the next time the cache is
199invalidated).
200
e1a479c5
BB
201=cut
202*/
4befac30 203static AV*
94d1e706 204S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
e1a479c5
BB
205{
206 AV* retval;
207 GV** gvp;
208 GV* gv;
209 AV* av;
190d0b22 210 const HEK* stashhek;
e1a479c5 211 struct mro_meta* meta;
a49ba3fc 212 SV *our_name;
73519bd0 213 HV *stored = NULL;
e1a479c5 214
7918f24d 215 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
e1a479c5
BB
216 assert(HvAUX(stash));
217
00169e2c
FC
218 stashhek
219 = HvAUX(stash)->xhv_name && HvENAME_HEK_NN(stash)
220 ? HvENAME_HEK_NN(stash)
221 : HvNAME_HEK(stash);
222
190d0b22 223 if (!stashhek)
1e05feb3 224 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
225
226 if (level > 100)
227 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 228 HEK_KEY(stashhek));
e1a479c5
BB
229
230 meta = HvMROMETA(stash);
1c908217
RGS
231
232 /* return cache if valid */
a3e6e81e 233 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
e1a479c5
BB
234 return retval;
235 }
236
237 /* not in cache, make a new one */
1c908217 238
ad64d0ec 239 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
a49ba3fc
NC
240 /* We use this later in this function, but don't need a reference to it
241 beyond the end of this function, so reference count is fine. */
242 our_name = newSVhek(stashhek);
243 av_push(retval, our_name); /* add ourselves at the top */
e1a479c5 244
1c908217 245 /* fetch our @ISA */
e1a479c5
BB
246 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
247 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
248
a49ba3fc
NC
249 /* "stored" is used to keep track of all of the classnames we have added to
250 the MRO so far, so we can do a quick exists check and avoid adding
251 duplicate classnames to the MRO as we go.
252 It's then retained to be re-used as a fast lookup for ->isa(), by adding
253 our own name and "UNIVERSAL" to it. */
254
a49ba3fc 255 if(av && AvFILLp(av) >= 0) {
1c908217 256
ffd8da72
NC
257 SV **svp = AvARRAY(av);
258 I32 items = AvFILLp(av) + 1;
1c908217
RGS
259
260 /* foreach(@ISA) */
e1a479c5
BB
261 while (items--) {
262 SV* const sv = *svp++;
263 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
264 SV *const *subrv_p;
265 I32 subrv_items;
e1a479c5
BB
266
267 if (!basestash) {
1c908217
RGS
268 /* if no stash exists for this @ISA member,
269 simply add it to the MRO and move on */
ffd8da72
NC
270 subrv_p = &sv;
271 subrv_items = 1;
e1a479c5
BB
272 }
273 else {
1c908217 274 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
275 of this @ISA member, and append their MRO to ours.
276 The recursive call could throw an exception, which
277 has memory management implications here, hence the use of
278 the mortal. */
ffd8da72
NC
279 const AV *const subrv
280 = mro_get_linear_isa_dfs(basestash, level + 1);
281
282 subrv_p = AvARRAY(subrv);
283 subrv_items = AvFILLp(subrv) + 1;
284 }
73519bd0
NC
285 if (stored) {
286 while(subrv_items--) {
287 SV *const subsv = *subrv_p++;
288 /* LVALUE fetch will create a new undefined SV if necessary
289 */
290 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
291 assert(he);
292 if(HeVAL(he) != &PL_sv_undef) {
293 /* It was newly created. Steal it for our new SV, and
294 replace it in the hash with the "real" thing. */
295 SV *const val = HeVAL(he);
296 HEK *const key = HeKEY_hek(he);
297
298 HeVAL(he) = &PL_sv_undef;
299 /* Save copying by making a shared hash key scalar. We
300 inline this here rather than calling
301 Perl_newSVpvn_share because we already have the
302 scalar, and we already have the hash key. */
303 assert(SvTYPE(val) == SVt_NULL);
304 sv_upgrade(val, SVt_PV);
305 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
306 SvCUR_set(val, HEK_LEN(key));
307 SvREADONLY_on(val);
308 SvFAKE_on(val);
309 SvPOK_on(val);
310 if (HEK_UTF8(key))
311 SvUTF8_on(val);
312
313 av_push(retval, val);
314 }
ffd8da72 315 }
73519bd0
NC
316 } else {
317 /* We are the first (or only) parent. We can short cut the
318 complexity above, because our @ISA is simply us prepended
319 to our parent's @ISA, and our ->isa cache is simply our
320 parent's, with our name added. */
321 /* newSVsv() is slow. This code is only faster if we can avoid
322 it by ensuring that SVs in the arrays are shared hash key
323 scalar SVs, because we can "copy" them very efficiently.
324 Although to be fair, we can't *ensure* this, as a reference
325 to the internal array is returned by mro::get_linear_isa(),
326 so we'll have to be defensive just in case someone faffed
327 with it. */
328 if (basestash) {
329 SV **svp;
17eef65c 330 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
73519bd0
NC
331 av_extend(retval, subrv_items);
332 AvFILLp(retval) = subrv_items;
333 svp = AvARRAY(retval);
334 while(subrv_items--) {
335 SV *const val = *subrv_p++;
336 *++svp = SvIsCOW_shared_hash(val)
337 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
338 : newSVsv(val);
339 }
340 } else {
341 /* They have no stash. So create ourselves an ->isa cache
342 as if we'd copied it from what theirs should be. */
343 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
344 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
345 av_push(retval,
346 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
347 &PL_sv_undef, 0))));
348 }
349 }
e1a479c5 350 }
73519bd0
NC
351 } else {
352 /* We have no parents. */
353 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
354 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
e1a479c5
BB
355 }
356
ed09b296 357 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
ed09b296
NC
358
359 SvREFCNT_inc_simple_void_NN(stored);
360 SvTEMP_off(stored);
361 SvREADONLY_on(stored);
362
363 meta->isa = stored;
364
0fd7ece8
NC
365 /* now that we're past the exception dangers, grab our own reference to
366 the AV we're about to use for the result. The reference owned by the
367 mortals' stack will be released soon, so everything will balance. */
368 SvREFCNT_inc_simple_void_NN(retval);
369 SvTEMP_off(retval);
fdef73f9 370
1c908217
RGS
371 /* we don't want anyone modifying the cache entry but us,
372 and we do so by replacing it completely */
e1a479c5 373 SvREADONLY_on(retval);
1c908217 374
a3e6e81e 375 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
fa60396f 376 MUTABLE_SV(retval)));
e1a479c5
BB
377}
378
379/*
e1a479c5
BB
380=for apidoc mro_get_linear_isa
381
382Returns either C<mro_get_linear_isa_c3> or
383C<mro_get_linear_isa_dfs> for the given stash,
384dependant upon which MRO is in effect
385for that stash. The return value is a
386read-only AV*.
387
1c908217
RGS
388You are responsible for C<SvREFCNT_inc()> on the
389return value if you plan to store it anywhere
390semi-permanently (otherwise it might be deleted
391out from under you the next time the cache is
392invalidated).
393
e1a479c5
BB
394=cut
395*/
396AV*
397Perl_mro_get_linear_isa(pTHX_ HV *stash)
398{
399 struct mro_meta* meta;
7311f41d 400 AV *isa;
2c7f4b87 401
7918f24d 402 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
403 if(!SvOOK(stash))
404 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
405
406 meta = HvMROMETA(stash);
3d76853f 407 if (!meta->mro_which)
14f97ce6 408 Perl_croak(aTHX_ "panic: invalid MRO!");
7311f41d
FC
409 isa = meta->mro_which->resolve(aTHX_ stash, 0);
410
411 if (!meta->isa) {
412 HV *const isa_hash = newHV();
413 /* Linearisation didn't build it for us, so do it here. */
414 SV *const *svp = AvARRAY(isa);
415 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
416 const HEK *canon_name = HvENAME_HEK(stash);
417 if (!canon_name) canon_name = HvNAME_HEK(stash);
418
419 while (svp < svp_end) {
420 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
421 }
422
423 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
424 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
425 HV_FETCH_ISSTORE, &PL_sv_undef,
426 HEK_HASH(canon_name));
427 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
428
429 SvREADONLY_on(isa_hash);
430
431 meta->isa = isa_hash;
432 }
433
434 return isa;
e1a479c5
BB
435}
436
437/*
438=for apidoc mro_isa_changed_in
439
1c908217 440Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
441when the @ISA of the given package has changed. Invoked
442by the C<setisa> magic, should not need to invoke directly.
443
444=cut
445*/
446void
4df35a07 447Perl_mro_isa_changed_in(pTHX_ HV* stash)
e1a479c5
BB
448{
449 dVAR;
450 HV* isarev;
451 AV* linear_mro;
452 HE* iter;
453 SV** svp;
454 I32 items;
1e05feb3 455 bool is_universal;
4df35a07 456 struct mro_meta * meta;
80ebaca2 457 HV *isa = NULL;
e1a479c5 458
4df35a07
FC
459 const char * const stashname = HvENAME_get(stash);
460 const STRLEN stashname_len = HvENAMELEN_get(stash);
461
462 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
7918f24d 463
2c7f4b87
BB
464 if(!stashname)
465 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
466
4df35a07
FC
467
468 /* wipe out the cached linearizations for this stash */
469 meta = HvMROMETA(stash);
470 if (meta->mro_linear_all) {
9953ff72
NC
471 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
472 meta->mro_linear_all = NULL;
553e831a 473 /* This is just acting as a shortcut pointer. */
3a6fa573 474 meta->mro_linear_current = NULL;
4df35a07 475 } else if (meta->mro_linear_current) {
553e831a 476 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
477 SvREFCNT_dec(meta->mro_linear_current);
478 meta->mro_linear_current = NULL;
4df35a07
FC
479 }
480 if (meta->isa) {
80ebaca2
FC
481 /* Steal it for our own purposes. */
482 isa = (HV *)sv_2mortal((SV *)meta->isa);
5782d502 483 meta->isa = NULL;
6f86b615 484 }
70cd14a1 485
4df35a07
FC
486 /* Inc the package generation, since our @ISA changed */
487 meta->pkg_gen++;
488
e1a479c5
BB
489 /* Wipe the global method cache if this package
490 is UNIVERSAL or one of its parents */
dd69841b
BB
491
492 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 493 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
494
495 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
496 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 497 PL_sub_generation++;
dd69841b
BB
498 is_universal = TRUE;
499 }
1e05feb3 500 else { /* Wipe the local method cache otherwise */
4df35a07 501 meta->cache_gen++;
1e05feb3
AL
502 is_universal = FALSE;
503 }
e1a479c5
BB
504
505 /* wipe next::method cache too */
4df35a07 506 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 507
e1a479c5 508 /* Iterate the isarev (classes that are our children),
80ebaca2
FC
509 wiping out their linearization, method and isa caches
510 and upating PL_isarev. */
dd69841b 511 if(isarev) {
80ebaca2
FC
512 HV *isa_hashes = NULL;
513
514 /* We have to iterate through isarev twice to avoid a chicken and
515 * egg problem: if A inherits from B and both are in isarev, A might
516 * be processed before B and use B’s previous linearisation.
517 */
518
519 /* First iteration: Wipe everything, but stash away the isa hashes
520 * since we still need them for updating PL_isarev.
521 */
522
523 if(hv_iterinit(isarev)) {
524 /* Only create the hash if we need it; i.e., if isarev has
525 any elements. */
526 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
527 }
e1a479c5 528 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
529 I32 len;
530 const char* const revkey = hv_iterkey(iter, &len);
531 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
532 struct mro_meta* revmeta;
533
534 if(!revstash) continue;
535 revmeta = HvMROMETA(revstash);
9953ff72
NC
536 if (revmeta->mro_linear_all) {
537 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
538 revmeta->mro_linear_all = NULL;
553e831a 539 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
540 revmeta->mro_linear_current = NULL;
541 } else if (revmeta->mro_linear_current) {
553e831a 542 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
543 SvREFCNT_dec(revmeta->mro_linear_current);
544 revmeta->mro_linear_current = NULL;
553e831a 545 }
dd69841b
BB
546 if(!is_universal)
547 revmeta->cache_gen++;
e1a479c5
BB
548 if(revmeta->mro_nextmethod)
549 hv_clear(revmeta->mro_nextmethod);
80ebaca2
FC
550
551 (void)
552 hv_store(
553 isa_hashes, (const char*)&revstash, sizeof(HV *),
554 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
555 );
556 revmeta->isa = NULL;
557 }
558
559 /* Second pass: Update PL_isarev. We can just use isa_hashes to
560 * avoid another round of stash lookups. */
561
562 /* isarev might be deleted from PL_isarev during this loop, so hang
563 * on to it. */
564 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
565
566 if(isa_hashes) {
567 hv_iterinit(isa_hashes);
568 while((iter = hv_iternext(isa_hashes))) {
569 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
570 HV * const isa = (HV *)HeVAL(iter);
571 const HEK *namehek;
572
80ebaca2
FC
573 /* We're starting at the 2nd element, skipping revstash */
574 linear_mro = mro_get_linear_isa(revstash);
575 svp = AvARRAY(linear_mro) + 1;
576 items = AvFILLp(linear_mro);
577
578 namehek = HvENAME_HEK(revstash);
579 if (!namehek) namehek = HvNAME_HEK(revstash);
580
581 while (items--) {
582 SV* const sv = *svp++;
583 HV* mroisarev;
584
585 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
586
587 /* That fetch should not fail. But if it had to create
588 a new SV for us, then will need to upgrade it to an
589 HV (which sv_upgrade() can now do for us). */
590
591 mroisarev = MUTABLE_HV(HeVAL(he));
592
593 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
594
595 /* This hash only ever contains PL_sv_yes. Storing it
596 over itself is almost as cheap as calling hv_exists,
597 so on aggregate we expect to save time by not making
598 two calls to the common HV code for the case where
599 it doesn't exist. */
600
601 (void)
602 hv_store(
603 mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
604 &PL_sv_yes, 0
605 );
606 }
607
608 if((SV *)isa != &PL_sv_undef)
609 mro_clean_isarev(
610 isa, HEK_KEY(namehek), HEK_LEN(namehek),
611 HvMROMETA(revstash)->isa
612 );
613 }
e1a479c5
BB
614 }
615 }
616
c9143745
FC
617 /* Now iterate our MRO (parents), adding ourselves and everything from
618 our isarev to their isarev.
1c908217
RGS
619 */
620
621 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
622 linear_mro = mro_get_linear_isa(stash);
623 svp = AvARRAY(linear_mro) + 1;
624 items = AvFILLp(linear_mro);
1c908217 625
e1a479c5
BB
626 while (items--) {
627 SV* const sv = *svp++;
e1a479c5
BB
628 HV* mroisarev;
629
117b69ca
NC
630 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
631
632 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
633 us, then will need to upgrade it to an HV (which sv_upgrade() can
634 now do for us. */
117b69ca 635
85fbaab2 636 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 637
ad64d0ec 638 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 639
25270bc0
NC
640 /* This hash only ever contains PL_sv_yes. Storing it over itself is
641 almost as cheap as calling hv_exists, so on aggregate we expect to
642 save time by not making two calls to the common HV code for the
643 case where it doesn't exist. */
644
04fe65b0 645 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
80ebaca2
FC
646 }
647
80ebaca2
FC
648 /* Delete our name from our former parents’ isarevs. */
649 if(isa && HvARRAY(isa))
650 mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
651}
652
653/* Deletes name from all the isarev entries listed in isa */
654STATIC void
655S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
656 const STRLEN len, HV * const exceptions)
657{
658 HE* iter;
e1a479c5 659
80ebaca2
FC
660 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
661
662 /* Delete our name from our former parents’ isarevs. */
663 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
664 SV **svp;
665 while((iter = hv_iternext(isa))) {
666 I32 klen;
667 const char * const key = hv_iterkey(iter, &klen);
668 if(exceptions && hv_exists(exceptions, key, klen)) continue;
669 svp = hv_fetch(PL_isarev, key, klen, 0);
670 if(svp) {
671 HV * const isarev = (HV *)*svp;
672 (void)hv_delete(isarev, name, len, G_DISCARD);
673 if(!HvARRAY(isarev) || !HvKEYS(isarev))
674 (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
e1a479c5
BB
675 }
676 }
677 }
678}
679
680/*
c8bbf675
FC
681=for apidoc mro_package_moved
682
d056e33c
FC
683Call this function to signal to a stash that it has been assigned to
684another spot in the stash hierarchy. C<stash> is the stash that has been
685assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
686that is actually being assigned to. C<newname> and C<newname_len> are the
687full name of the GV. If these last two arguments are omitted, they can be
35759254 688inferred from C<gv>. C<gv> can be omitted if C<newname> is given.
d056e33c 689
35759254 690This can also be called with a null first argument to
d056e33c
FC
691indicate that C<oldstash> has been deleted.
692
693This function invalidates isa caches on the old stash, on all subpackages
694nested inside it, and on the subclasses of all those, including
695non-existent packages that have corresponding entries in C<stash>.
c8bbf675 696
80ebaca2
FC
697It also sets the effective names (C<HvENAME>) on all the stashes as
698appropriate.
699
c8bbf675
FC
700=cut
701*/
702void
35759254
FC
703Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
704 const GV *gv, const char *newname,
62c1e33f 705 I32 newname_len)
c8bbf675 706{
80ebaca2
FC
707 HV *stashes;
708 HE* iter;
62c1e33f 709
35759254 710 assert(stash || oldstash);
80ebaca2 711 assert(gv || newname);
35759254
FC
712
713 /* Determine the name of the location that stash was assigned to
714 * or from which oldstash was removed.
715 *
928eb066 716 * We cannot reliably use the name in oldstash, because it may have
35759254
FC
717 * been deleted from the location in the symbol table that its name
718 * suggests, as in this case:
719 *
720 * $globref = \*foo::bar::;
721 * Symbol::delete_package("foo");
722 * *$globref = \%baz::;
723 * *$globref = *frelp::;
724 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
725 *
726 * If newname is not null, then we trust that the caller gave us the
727 * right name. Otherwise, we get it from the gv. But if the gv is not
728 * in the symbol table, then we just return.
729 */
d056e33c
FC
730 if(!newname && gv) {
731 SV * const namesv = sv_newmortal();
62c1e33f 732 STRLEN len;
d056e33c 733 gv_fullname4(namesv, gv, NULL, 0);
35759254 734 if(gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv) return;
62c1e33f
FC
735 newname = SvPV_const(namesv, len);
736 newname_len = len - 2; /* skip trailing :: */
d056e33c 737 }
35759254 738 if(newname_len < 0) newname_len = -newname_len;
c8bbf675 739
80ebaca2
FC
740 /* Get a list of all the affected classes. */
741 /* We cannot simply pass them all to mro_isa_changed_in to avoid
742 the list, as that function assumes that only one package has
743 changed. It does not work with:
744
745 @foo::ISA = qw( B B::B );
746 *B:: = delete $::{"A::"};
747
748 as neither B nor B::B can be updated before the other, since they
749 will reset caches on foo, which will see either B or B::B with the
750 wrong name. The names must be set on *all* affected stashes before
751 we do anything else.
752 */
753 stashes = (HV *) sv_2mortal((SV *)newHV());
b89cdb22
FC
754 mro_gather_and_rename(
755 stashes, (HV *) sv_2mortal((SV *)newHV()),
756 stash, oldstash, newname, newname_len
757 );
80ebaca2
FC
758
759 /* Iterate through the stashes, wiping isa linearisations, but leaving
760 the isa hash (which mro_isa_changed_in needs for adjusting the
761 isarev hashes belonging to parent classes). */
762 hv_iterinit(stashes);
763 while((iter = hv_iternext(stashes))) {
90ba1f34
FC
764 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
765 if(HvENAME(stash)) {
80ebaca2 766 struct mro_meta* meta;
90ba1f34 767 meta = HvMROMETA(stash);
80ebaca2
FC
768 if (meta->mro_linear_all) {
769 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
770 meta->mro_linear_all = NULL;
771 /* This is just acting as a shortcut pointer. */
772 meta->mro_linear_current = NULL;
773 } else if (meta->mro_linear_current) {
774 /* Only the current MRO is stored, so this owns the data. */
775 SvREFCNT_dec(meta->mro_linear_current);
776 meta->mro_linear_current = NULL;
777 }
778 }
779 }
780
781 /* Once the caches have been wiped on all the classes, call
782 mro_isa_changed_in on each. */
783 hv_iterinit(stashes);
784 while((iter = hv_iternext(stashes))) {
90ba1f34
FC
785 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
786 if(HvENAME(stash)) {
787 /* We have to restore the original meta->isa (that
788 mro_gather_and_rename set aside for us) this way, in case
789 one class in this list is a superclass of a another class
790 that we have already encountered. In such a case, meta->isa
791 will have been overwritten without old entries being deleted
792 from PL_isarev. */
793 struct mro_meta * const meta = HvMROMETA(stash);
794 if(meta->isa != (HV *)HeVAL(iter)){
795 SvREFCNT_dec(meta->isa);
796 meta->isa
797 = HeVAL(iter) == &PL_sv_yes
798 ? NULL
799 : (HV *)HeVAL(iter);
800 HeVAL(iter) = NULL; /* We donated our reference count. */
801 }
802 mro_isa_changed_in(stash);
803 }
80ebaca2
FC
804 }
805}
806
807void
b89cdb22
FC
808S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
809 HV *stash, HV *oldstash, const char *name,
810 I32 namlen)
80ebaca2
FC
811{
812 register XPVHV* xhv;
813 register HE *entry;
814 I32 riter = -1;
815 const bool stash_had_name = stash && HvENAME(stash);
816 HV *seen = NULL;
817 HV *isarev = NULL;
818 SV **svp;
819
820 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
821
b89cdb22
FC
822 /* We use the seen_stashes hash to keep track of which packages have
823 been encountered so far. This must be separate from the main list of
824 stashes, as we need to distinguish between stashes being assigned
825 and stashes being replaced/deleted. (A nested stash can be on both
826 sides of an assignment. We cannot simply skip iterating through a
827 stash on the right if we have seen it on the left, as it will not
828 get its ename assigned to it.)
829
830 To avoid allocating extra SVs, instead of a bitfield we can make
831 bizarre use of immortals:
832
833 &PL_sv_undef: seen on the left (oldstash)
834 &PL_sv_no : seen on the right (stash)
835 &PL_sv_yes : seen on both sides
836
837 */
838
80ebaca2
FC
839 if(oldstash) {
840 /* Add to the big list. */
90ba1f34 841 struct mro_meta * meta;
80ebaca2
FC
842 HE * const entry
843 = (HE *)
844 hv_common(
b89cdb22 845 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
df5f182b 846 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2 847 );
b89cdb22 848 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
80ebaca2
FC
849 oldstash = NULL;
850 goto check_stash;
851 }
b89cdb22
FC
852 HeVAL(entry)
853 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
90ba1f34 854 meta = HvMROMETA(oldstash);
b89cdb22
FC
855 (void)
856 hv_store(
857 stashes, (const char *)&oldstash, sizeof(HV *),
90ba1f34
FC
858 meta->isa
859 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
860 : &PL_sv_yes,
861 0
b89cdb22 862 );
80ebaca2
FC
863
864 /* Update the effective name. */
865 if(HvENAME_get(oldstash)) {
866 const HEK * const enamehek = HvENAME_HEK(oldstash);
867 if(PL_stashcache)
d7fbb1de 868 (void)
80ebaca2
FC
869 hv_delete(PL_stashcache, name, namlen, G_DISCARD);
870 hv_ename_delete(oldstash, name, namlen);
871
872 /* If the name deletion caused a name change, then we are not
873 * going to call mro_isa_changed_in with this name (and not at all
874 * if it has become anonymous) so we need to delete old isarev
875 * entries here, both those in the superclasses and this class’s
876 * own list of subclasses. We simply delete the latter from
877 * from PL_isarev, since we still need it. hv_delete mortifies it
878 * for us, so sv_2mortal is not necessary. */
879 if(HvENAME_HEK(oldstash) != enamehek) {
80ebaca2
FC
880 if(meta->isa && HvARRAY(meta->isa))
881 mro_clean_isarev(meta->isa, name, namlen, NULL);
882 isarev = (HV *)hv_delete(PL_isarev, name, namlen, 0);
883 }
884 }
d7fbb1de 885 }
80ebaca2 886 check_stash:
8b9e80a3 887 if(stash) {
80ebaca2
FC
888 hv_ename_add(stash, name, namlen);
889
b89cdb22
FC
890 /* Add it to the big list if it needs
891 * mro_isa_changed_in called on it. That happens if it was
80ebaca2
FC
892 * detached from the symbol table (so it had no HvENAME) before
893 * being assigned to the spot named by the ‘name’ variable, because
894 * its cached isa linerisation is now stale (the effective name
895 * having changed), and subclasses will then use that cache when
896 * mro_package_moved calls mro_isa_changed_in. (See
8b9e80a3 897 * [perl #77358].)
80ebaca2 898 *
8b9e80a3 899 * If it did have a name, then its previous name is still
80ebaca2
FC
900 * used in isa caches, and there is no need for
901 * mro_package_moved to call mro_isa_changed_in.
8b9e80a3 902 */
80ebaca2
FC
903
904 entry
905 = (HE *)
906 hv_common(
b89cdb22 907 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
df5f182b 908 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2 909 );
b89cdb22 910 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
80ebaca2 911 stash = NULL;
b89cdb22
FC
912 else {
913 HeVAL(entry)
914 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
915 if(!stash_had_name)
90ba1f34
FC
916 {
917 struct mro_meta * const meta = HvMROMETA(stash);
b89cdb22
FC
918 (void)
919 hv_store(
920 stashes, (const char *)&stash, sizeof(HV *),
90ba1f34
FC
921 meta->isa
922 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
923 : &PL_sv_yes,
924 0
b89cdb22 925 );
90ba1f34 926 }
b89cdb22 927 }
8b9e80a3 928 }
d7fbb1de 929
80ebaca2
FC
930 if(!stash && !oldstash)
931 /* Both stashes have been encountered already. */
932 return;
933
934 /* Add all the subclasses to the big list. */
935 if(
936 isarev
937 || (
938 (svp = hv_fetch(PL_isarev, name, namlen, 0))
939 && (isarev = MUTABLE_HV(*svp))
940 )
941 ) {
942 HE *iter;
943 hv_iterinit(isarev);
944 while((iter = hv_iternext(isarev))) {
945 I32 len;
946 const char* const revkey = hv_iterkey(iter, &len);
947 HV* revstash = gv_stashpvn(revkey, len, 0);
90ba1f34 948 struct mro_meta * meta;
80ebaca2
FC
949
950 if(!revstash) continue;
90ba1f34 951 meta = HvMROMETA(revstash);
b89cdb22
FC
952 (void)
953 hv_store(
954 stashes, (const char *)&revstash, sizeof(HV *),
90ba1f34
FC
955 meta->isa
956 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
957 : &PL_sv_yes,
958 0
b89cdb22 959 );
80ebaca2
FC
960 }
961 }
d056e33c
FC
962
963 if(
964 (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
d7fbb1de 965 ) return;
c8bbf675
FC
966
967 /* This is partly based on code in hv_iternext_flags. We are not call-
968 ing that here, as we want to avoid resetting the hash iterator. */
969
d056e33c
FC
970 /* Skip the entire loop if the hash is empty. */
971 if(oldstash && HvUSEDKEYS(oldstash)) {
972 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 973 seen = (HV *) sv_2mortal((SV *)newHV());
d056e33c 974
80ebaca2
FC
975 /* Iterate through entries in the oldstash, adding them to the
976 list, meanwhile doing the equivalent of $seen{$key} = 1.
d056e33c
FC
977 */
978
979 while (++riter <= (I32)xhv->xhv_max) {
980 entry = (HvARRAY(oldstash))[riter];
981
982 /* Iterate through the entries in this list */
983 for(; entry; entry = HeNEXT(entry)) {
984 const char* key;
985 I32 len;
986
987 /* If this entry is not a glob, ignore it.
988 Try the next. */
989 if (!isGV(HeVAL(entry))) continue;
990
991 key = hv_iterkey(entry, &len);
992 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
993 HV * const oldsubstash = GvHV(HeVAL(entry));
994 SV ** const stashentry
995 = stash ? hv_fetch(stash, key, len, 0) : NULL;
35759254 996 HV *substash = NULL;
62c1e33f
FC
997
998 /* Avoid main::main::main::... */
999 if(oldsubstash == oldstash) continue;
1000
d056e33c 1001 if(
35759254
FC
1002 (
1003 stashentry && *stashentry
1004 && (substash = GvHV(*stashentry))
1005 )
00169e2c 1006 || (oldsubstash && HvENAME_get(oldsubstash))
d056e33c 1007 )
35759254
FC
1008 {
1009 /* Add :: and the key (minus the trailing ::)
1010 to newname. */
1011 SV *namesv
80ebaca2
FC
1012 = newSVpvn_flags(name, namlen, SVs_TEMP);
1013 {
1014 const char *name;
1015 STRLEN namlen;
1016 sv_catpvs(namesv, "::");
1017 sv_catpvn(namesv, key, len-2);
1018 name = SvPV_const(namesv, namlen);
1019 mro_gather_and_rename(
b89cdb22
FC
1020 stashes, seen_stashes,
1021 substash, oldsubstash, name, namlen
80ebaca2
FC
1022 );
1023 }
35759254 1024 }
d056e33c
FC
1025
1026 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
1027 }
1028 }
1029 }
1030 }
c8bbf675
FC
1031
1032 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
1033 if (stash && HvUSEDKEYS(stash)) {
1034 xhv = (XPVHV*)SvANY(stash);
b89cdb22 1035 riter = -1;
d056e33c
FC
1036
1037 /* Iterate through the new stash, skipping $seen{$key} items,
b89cdb22 1038 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
c8bbf675
FC
1039 while (++riter <= (I32)xhv->xhv_max) {
1040 entry = (HvARRAY(stash))[riter];
1041
1042 /* Iterate through the entries in this list */
1043 for(; entry; entry = HeNEXT(entry)) {
1044 const char* key;
1045 I32 len;
1046
1047 /* If this entry is not a glob, ignore it.
1048 Try the next. */
1049 if (!isGV(HeVAL(entry))) continue;
1050
1051 key = hv_iterkey(entry, &len);
1052 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
d056e33c
FC
1053 HV *substash;
1054
1055 /* If this entry was seen when we iterated through the
1056 oldstash, skip it. */
1057 if(seen && hv_exists(seen, key, len)) continue;
1058
1059 /* We get here only if this stash has no corresponding
1060 entry in the stash being replaced. */
1061
1062 substash = GvHV(HeVAL(entry));
35759254 1063 if(substash) {
62c1e33f 1064 SV *namesv;
80ebaca2
FC
1065 const char *subname;
1066 STRLEN subnamlen;
62c1e33f
FC
1067
1068 /* Avoid checking main::main::main::... */
1069 if(substash == stash) continue;
1070
d056e33c
FC
1071 /* Add :: and the key (minus the trailing ::)
1072 to newname. */
62c1e33f 1073 namesv
80ebaca2 1074 = newSVpvn_flags(name, namlen, SVs_TEMP);
d056e33c
FC
1075 sv_catpvs(namesv, "::");
1076 sv_catpvn(namesv, key, len-2);
80ebaca2
FC
1077 subname = SvPV_const(namesv, subnamlen);
1078 mro_gather_and_rename(
b89cdb22
FC
1079 stashes, seen_stashes,
1080 substash, NULL, subname, subnamlen
d056e33c
FC
1081 );
1082 }
c8bbf675
FC
1083 }
1084 }
1085 }
1086 }
1087}
1088
1089/*
e1a479c5
BB
1090=for apidoc mro_method_changed_in
1091
47c9dd14
BB
1092Invalidates method caching on any child classes
1093of the given stash, so that they might notice
1094the changes in this one.
e1a479c5
BB
1095
1096Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
1097perl source outside of C<mro.c> should be
1098replaced by calls to this.
1099
1100Perl automatically handles most of the common
1101ways a method might be redefined. However, there
1102are a few ways you could change a method in a stash
1103without the cache code noticing, in which case you
1104need to call this method afterwards:
e1a479c5 1105
dd69841b
BB
11061) Directly manipulating the stash HV entries from
1107XS code.
e1a479c5 1108
dd69841b
BB
11092) Assigning a reference to a readonly scalar
1110constant into a stash entry in order to create
1111a constant subroutine (like constant.pm
1112does).
1113
1114This same method is available from pure perl
1115via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
1116
1117=cut
1118*/
1119void
1120Perl_mro_method_changed_in(pTHX_ HV *stash)
1121{
00169e2c
FC
1122 const char * const stashname = HvENAME_get(stash);
1123 const STRLEN stashname_len = HvENAMELEN_get(stash);
dd69841b 1124
1e05feb3 1125 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 1126 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 1127
7918f24d
NC
1128 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1129
2c7f4b87
BB
1130 if(!stashname)
1131 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1132
70cd14a1
CB
1133 /* Inc the package generation, since a local method changed */
1134 HvMROMETA(stash)->pkg_gen++;
1135
e1a479c5
BB
1136 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1137 invalidate all method caches globally */
dd69841b
BB
1138 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1139 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
1140 PL_sub_generation++;
1141 return;
1142 }
1143
1144 /* else, invalidate the method caches of all child classes,
1145 but not itself */
dd69841b 1146 if(isarev) {
1e05feb3
AL
1147 HE* iter;
1148
e1a479c5
BB
1149 hv_iterinit(isarev);
1150 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
1151 I32 len;
1152 const char* const revkey = hv_iterkey(iter, &len);
1153 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
1154 struct mro_meta* mrometa;
1155
1156 if(!revstash) continue;
1157 mrometa = HvMROMETA(revstash);
dd69841b 1158 mrometa->cache_gen++;
e1a479c5
BB
1159 if(mrometa->mro_nextmethod)
1160 hv_clear(mrometa->mro_nextmethod);
1161 }
1162 }
1163}
1164
31b9005d
NC
1165void
1166Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1167{
1168 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1169
1170 PERL_ARGS_ASSERT_MRO_SET_MRO;
1171
1172 if (!which)
1173 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1174
1175 if(meta->mro_which != which) {
9953ff72 1176 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
1177 /* If we were storing something directly, put it in the hash before
1178 we lose it. */
1179 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 1180 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
1181 }
1182 meta->mro_which = which;
1183 /* Scrub our cached pointer to the private data. */
3a6fa573 1184 meta->mro_linear_current = NULL;
31b9005d
NC
1185 /* Only affects local method cache, not
1186 even child classes */
1187 meta->cache_gen++;
1188 if(meta->mro_nextmethod)
1189 hv_clear(meta->mro_nextmethod);
1190 }
1191}
1192
e1a479c5
BB
1193#include "XSUB.h"
1194
e1a479c5 1195XS(XS_mro_method_changed_in);
e1a479c5
BB
1196
1197void
1198Perl_boot_core_mro(pTHX)
1199{
1200 dVAR;
1201 static const char file[] = __FILE__;
1202
a3e6e81e 1203 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 1204
e1a479c5 1205 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
1206}
1207
e1a479c5
BB
1208XS(XS_mro_method_changed_in)
1209{
1210 dVAR;
1211 dXSARGS;
1212 SV* classname;
1213 HV* class_stash;
1214
e1a479c5 1215 if(items != 1)
afa74d42 1216 croak_xs_usage(cv, "classname");
e1a479c5
BB
1217
1218 classname = ST(0);
1219
1220 class_stash = gv_stashsv(classname, 0);
1221 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1222
1223 mro_method_changed_in(class_stash);
1224
1225 XSRETURN_EMPTY;
1226}
1227
e1a479c5
BB
1228/*
1229 * Local variables:
1230 * c-indentation-style: bsd
1231 * c-basic-offset: 4
1232 * indent-tabs-mode: t
1233 * End:
1234 *
1235 * ex: set ts=8 sts=4 sw=4 noet:
1236 */