This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mro.c: Assert that the previous commit is correct
[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 218 stashhek
15d9236d 219 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
00169e2c
FC
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*/
f7afb547 446
beeda143 447/* Macro to avoid repeating the code five times. */
f7afb547
FC
448#define CLEAR_LINEAR(mEta) \
449 if (mEta->mro_linear_all) { \
450 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
451 mEta->mro_linear_all = NULL; \
452 /* This is just acting as a shortcut pointer. */ \
453 mEta->mro_linear_current = NULL; \
454 } else if (mEta->mro_linear_current) { \
455 /* Only the current MRO is stored, so this owns the data. */ \
456 SvREFCNT_dec(mEta->mro_linear_current); \
457 mEta->mro_linear_current = NULL; \
458 }
459
e1a479c5 460void
4df35a07 461Perl_mro_isa_changed_in(pTHX_ HV* stash)
e1a479c5
BB
462{
463 dVAR;
464 HV* isarev;
465 AV* linear_mro;
466 HE* iter;
467 SV** svp;
468 I32 items;
1e05feb3 469 bool is_universal;
4df35a07 470 struct mro_meta * meta;
80ebaca2 471 HV *isa = NULL;
e1a479c5 472
4df35a07
FC
473 const char * const stashname = HvENAME_get(stash);
474 const STRLEN stashname_len = HvENAMELEN_get(stash);
475
476 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
7918f24d 477
2c7f4b87
BB
478 if(!stashname)
479 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
480
4df35a07
FC
481
482 /* wipe out the cached linearizations for this stash */
483 meta = HvMROMETA(stash);
f7afb547 484 CLEAR_LINEAR(meta);
4df35a07 485 if (meta->isa) {
80ebaca2
FC
486 /* Steal it for our own purposes. */
487 isa = (HV *)sv_2mortal((SV *)meta->isa);
5782d502 488 meta->isa = NULL;
6f86b615 489 }
70cd14a1 490
4df35a07
FC
491 /* Inc the package generation, since our @ISA changed */
492 meta->pkg_gen++;
493
e1a479c5
BB
494 /* Wipe the global method cache if this package
495 is UNIVERSAL or one of its parents */
dd69841b
BB
496
497 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 498 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
499
500 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
501 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 502 PL_sub_generation++;
dd69841b
BB
503 is_universal = TRUE;
504 }
1e05feb3 505 else { /* Wipe the local method cache otherwise */
4df35a07 506 meta->cache_gen++;
1e05feb3
AL
507 is_universal = FALSE;
508 }
e1a479c5
BB
509
510 /* wipe next::method cache too */
4df35a07 511 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 512
e1a479c5 513 /* Iterate the isarev (classes that are our children),
80ebaca2
FC
514 wiping out their linearization, method and isa caches
515 and upating PL_isarev. */
dd69841b 516 if(isarev) {
80ebaca2
FC
517 HV *isa_hashes = NULL;
518
519 /* We have to iterate through isarev twice to avoid a chicken and
520 * egg problem: if A inherits from B and both are in isarev, A might
521 * be processed before B and use B’s previous linearisation.
522 */
523
524 /* First iteration: Wipe everything, but stash away the isa hashes
525 * since we still need them for updating PL_isarev.
526 */
527
528 if(hv_iterinit(isarev)) {
529 /* Only create the hash if we need it; i.e., if isarev has
530 any elements. */
531 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
532 }
e1a479c5 533 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
534 I32 len;
535 const char* const revkey = hv_iterkey(iter, &len);
536 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
537 struct mro_meta* revmeta;
538
539 if(!revstash) continue;
540 revmeta = HvMROMETA(revstash);
f7afb547 541 CLEAR_LINEAR(revmeta);
dd69841b
BB
542 if(!is_universal)
543 revmeta->cache_gen++;
e1a479c5
BB
544 if(revmeta->mro_nextmethod)
545 hv_clear(revmeta->mro_nextmethod);
80ebaca2
FC
546
547 (void)
548 hv_store(
549 isa_hashes, (const char*)&revstash, sizeof(HV *),
550 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
551 );
552 revmeta->isa = NULL;
553 }
554
555 /* Second pass: Update PL_isarev. We can just use isa_hashes to
556 * avoid another round of stash lookups. */
557
558 /* isarev might be deleted from PL_isarev during this loop, so hang
559 * on to it. */
560 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
561
562 if(isa_hashes) {
563 hv_iterinit(isa_hashes);
564 while((iter = hv_iternext(isa_hashes))) {
565 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
566 HV * const isa = (HV *)HeVAL(iter);
567 const HEK *namehek;
568
80ebaca2
FC
569 /* We're starting at the 2nd element, skipping revstash */
570 linear_mro = mro_get_linear_isa(revstash);
571 svp = AvARRAY(linear_mro) + 1;
572 items = AvFILLp(linear_mro);
573
574 namehek = HvENAME_HEK(revstash);
575 if (!namehek) namehek = HvNAME_HEK(revstash);
576
577 while (items--) {
578 SV* const sv = *svp++;
579 HV* mroisarev;
580
581 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
582
583 /* That fetch should not fail. But if it had to create
584 a new SV for us, then will need to upgrade it to an
585 HV (which sv_upgrade() can now do for us). */
586
587 mroisarev = MUTABLE_HV(HeVAL(he));
588
589 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
590
591 /* This hash only ever contains PL_sv_yes. Storing it
592 over itself is almost as cheap as calling hv_exists,
593 so on aggregate we expect to save time by not making
594 two calls to the common HV code for the case where
595 it doesn't exist. */
596
597 (void)
598 hv_store(
599 mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
600 &PL_sv_yes, 0
601 );
602 }
603
604 if((SV *)isa != &PL_sv_undef)
605 mro_clean_isarev(
606 isa, HEK_KEY(namehek), HEK_LEN(namehek),
607 HvMROMETA(revstash)->isa
608 );
609 }
e1a479c5
BB
610 }
611 }
612
c9143745
FC
613 /* Now iterate our MRO (parents), adding ourselves and everything from
614 our isarev to their isarev.
1c908217
RGS
615 */
616
617 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
618 linear_mro = mro_get_linear_isa(stash);
619 svp = AvARRAY(linear_mro) + 1;
620 items = AvFILLp(linear_mro);
1c908217 621
e1a479c5
BB
622 while (items--) {
623 SV* const sv = *svp++;
e1a479c5
BB
624 HV* mroisarev;
625
117b69ca
NC
626 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
627
628 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
629 us, then will need to upgrade it to an HV (which sv_upgrade() can
630 now do for us. */
117b69ca 631
85fbaab2 632 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 633
ad64d0ec 634 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 635
25270bc0
NC
636 /* This hash only ever contains PL_sv_yes. Storing it over itself is
637 almost as cheap as calling hv_exists, so on aggregate we expect to
638 save time by not making two calls to the common HV code for the
639 case where it doesn't exist. */
640
04fe65b0 641 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
80ebaca2
FC
642 }
643
80ebaca2
FC
644 /* Delete our name from our former parents’ isarevs. */
645 if(isa && HvARRAY(isa))
646 mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
647}
648
649/* Deletes name from all the isarev entries listed in isa */
650STATIC void
651S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
652 const STRLEN len, HV * const exceptions)
653{
654 HE* iter;
e1a479c5 655
80ebaca2
FC
656 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
657
658 /* Delete our name from our former parents’ isarevs. */
659 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
660 SV **svp;
661 while((iter = hv_iternext(isa))) {
662 I32 klen;
663 const char * const key = hv_iterkey(iter, &klen);
664 if(exceptions && hv_exists(exceptions, key, klen)) continue;
665 svp = hv_fetch(PL_isarev, key, klen, 0);
666 if(svp) {
667 HV * const isarev = (HV *)*svp;
668 (void)hv_delete(isarev, name, len, G_DISCARD);
669 if(!HvARRAY(isarev) || !HvKEYS(isarev))
670 (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
e1a479c5
BB
671 }
672 }
673 }
674}
675
676/*
c8bbf675
FC
677=for apidoc mro_package_moved
678
d056e33c
FC
679Call this function to signal to a stash that it has been assigned to
680another spot in the stash hierarchy. C<stash> is the stash that has been
681assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
afdbe55d 682that is actually being assigned to.
d056e33c 683
35759254 684This can also be called with a null first argument to
d056e33c
FC
685indicate that C<oldstash> has been deleted.
686
687This function invalidates isa caches on the old stash, on all subpackages
688nested inside it, and on the subclasses of all those, including
689non-existent packages that have corresponding entries in C<stash>.
c8bbf675 690
80ebaca2
FC
691It also sets the effective names (C<HvENAME>) on all the stashes as
692appropriate.
693
0290c710 694If the C<gv> is present and is not in the symbol table, then this function
afdbe55d 695simply returns. This checked will be skipped if C<flags & 1>.
0290c710 696
c8bbf675
FC
697=cut
698*/
699void
35759254 700Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
afdbe55d 701 const GV * const gv, U32 flags)
c8bbf675 702{
d7879cf0
FC
703 SV *namesv;
704 HEK **namep;
705 I32 name_count;
80ebaca2
FC
706 HV *stashes;
707 HE* iter;
62c1e33f 708
afdbe55d 709 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
35759254 710 assert(stash || oldstash);
35759254 711
d7879cf0 712 /* Determine the name(s) of the location that stash was assigned to
35759254
FC
713 * or from which oldstash was removed.
714 *
928eb066 715 * We cannot reliably use the name in oldstash, because it may have
35759254
FC
716 * been deleted from the location in the symbol table that its name
717 * suggests, as in this case:
718 *
719 * $globref = \*foo::bar::;
720 * Symbol::delete_package("foo");
721 * *$globref = \%baz::;
722 * *$globref = *frelp::;
723 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
724 *
d7879cf0
FC
725 * So we get it from the gv. But, since the gv may no longer be in the
726 * symbol table, we check that first. The only reliable way to tell is
727 * to see whether its stash has an effective name and whether the gv
728 * resides in that stash under its name. That effective name may be
729 * different from what gv_fullname4 would use.
730 * If flags & 1, the caller has asked us to skip the check.
35759254 731 */
d7879cf0
FC
732 if(!(flags & 1)) {
733 SV **svp;
734 if(
735 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
736 !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), 0)) ||
737 *svp != (SV *)gv
738 ) return;
739 }
740 assert(SvOOK(GvSTASH(gv)));
741 assert(GvNAMELEN(gv) > 1);
742 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
743 assert(GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
744 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
745 if (!name_count) {
746 name_count = 1;
15d9236d 747 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
d7879cf0
FC
748 }
749 else {
15d9236d 750 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
d7879cf0
FC
751 if (name_count < 0) ++namep, name_count = -name_count - 1;
752 }
753 if (name_count == 1) {
754 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
a3179684 755 namesv = newSVpvs_flags("", SVs_TEMP);
d7879cf0
FC
756 }
757 else {
758 namesv = sv_2mortal(newSVhek(*namep));
759 sv_catpvs(namesv, "::");
760 }
761 sv_catpvn(namesv, GvNAME(gv), GvNAMELEN(gv) - 2);
762 /* skip trailing :: */
763 }
764 else {
765 SV *aname;
766 namesv = sv_2mortal((SV *)newAV());
767 while (name_count--) {
768 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
769 aname = newSVpvs(""); namep++;
770 }
771 else {
772 aname = newSVhek(*namep++);
773 sv_catpvs(aname, "::");
774 }
775 sv_catpvn(aname, GvNAME(gv), GvNAMELEN(gv) - 2);
776 /* skip trailing :: */
777 av_push((AV *)namesv, aname);
778 }
779 }
c8bbf675 780
80ebaca2
FC
781 /* Get a list of all the affected classes. */
782 /* We cannot simply pass them all to mro_isa_changed_in to avoid
783 the list, as that function assumes that only one package has
784 changed. It does not work with:
785
786 @foo::ISA = qw( B B::B );
787 *B:: = delete $::{"A::"};
788
789 as neither B nor B::B can be updated before the other, since they
790 will reset caches on foo, which will see either B or B::B with the
791 wrong name. The names must be set on *all* affected stashes before
beeda143 792 we do anything else. (And linearisations must be cleared, too.)
80ebaca2
FC
793 */
794 stashes = (HV *) sv_2mortal((SV *)newHV());
b89cdb22
FC
795 mro_gather_and_rename(
796 stashes, (HV *) sv_2mortal((SV *)newHV()),
d7879cf0 797 stash, oldstash, namesv
b89cdb22 798 );
80ebaca2 799
80ebaca2
FC
800 /* Once the caches have been wiped on all the classes, call
801 mro_isa_changed_in on each. */
802 hv_iterinit(stashes);
803 while((iter = hv_iternext(stashes))) {
90ba1f34
FC
804 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
805 if(HvENAME(stash)) {
806 /* We have to restore the original meta->isa (that
807 mro_gather_and_rename set aside for us) this way, in case
808 one class in this list is a superclass of a another class
809 that we have already encountered. In such a case, meta->isa
810 will have been overwritten without old entries being deleted
811 from PL_isarev. */
812 struct mro_meta * const meta = HvMROMETA(stash);
813 if(meta->isa != (HV *)HeVAL(iter)){
814 SvREFCNT_dec(meta->isa);
815 meta->isa
816 = HeVAL(iter) == &PL_sv_yes
817 ? NULL
818 : (HV *)HeVAL(iter);
819 HeVAL(iter) = NULL; /* We donated our reference count. */
820 }
821 mro_isa_changed_in(stash);
822 }
80ebaca2
FC
823 }
824}
825
826void
b89cdb22 827S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
d7879cf0 828 HV *stash, HV *oldstash, SV *namesv)
80ebaca2
FC
829{
830 register XPVHV* xhv;
831 register HE *entry;
832 I32 riter = -1;
d7879cf0 833 I32 items;
80ebaca2 834 const bool stash_had_name = stash && HvENAME(stash);
d7879cf0 835 bool fetched_isarev = FALSE;
80ebaca2
FC
836 HV *seen = NULL;
837 HV *isarev = NULL;
d7879cf0 838 SV **svp = NULL;
80ebaca2
FC
839
840 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
841
b89cdb22
FC
842 /* We use the seen_stashes hash to keep track of which packages have
843 been encountered so far. This must be separate from the main list of
844 stashes, as we need to distinguish between stashes being assigned
845 and stashes being replaced/deleted. (A nested stash can be on both
846 sides of an assignment. We cannot simply skip iterating through a
847 stash on the right if we have seen it on the left, as it will not
848 get its ename assigned to it.)
849
850 To avoid allocating extra SVs, instead of a bitfield we can make
851 bizarre use of immortals:
852
853 &PL_sv_undef: seen on the left (oldstash)
854 &PL_sv_no : seen on the right (stash)
855 &PL_sv_yes : seen on both sides
856
857 */
858
80ebaca2
FC
859 if(oldstash) {
860 /* Add to the big list. */
90ba1f34 861 struct mro_meta * meta;
80ebaca2
FC
862 HE * const entry
863 = (HE *)
864 hv_common(
b89cdb22 865 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
df5f182b 866 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2 867 );
b89cdb22 868 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
80ebaca2
FC
869 oldstash = NULL;
870 goto check_stash;
871 }
b89cdb22
FC
872 HeVAL(entry)
873 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
90ba1f34 874 meta = HvMROMETA(oldstash);
b89cdb22
FC
875 (void)
876 hv_store(
877 stashes, (const char *)&oldstash, sizeof(HV *),
90ba1f34
FC
878 meta->isa
879 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
880 : &PL_sv_yes,
881 0
b89cdb22 882 );
beeda143 883 CLEAR_LINEAR(meta);
80ebaca2
FC
884
885 /* Update the effective name. */
886 if(HvENAME_get(oldstash)) {
d7879cf0
FC
887 const HEK * const enamehek = HvENAME_HEK(oldstash);
888 if(SvTYPE(namesv) == SVt_PVAV) {
889 items = AvFILLp((AV *)namesv) + 1;
890 svp = AvARRAY((AV *)namesv);
891 }
892 else {
893 items = 1;
894 svp = &namesv;
895 }
896 while (items--) {
897 STRLEN len;
898 const char *name = SvPVx_const(*svp++, len);
899 if(PL_stashcache)
900 (void)hv_delete(PL_stashcache, name, len, G_DISCARD);
901 hv_ename_delete(oldstash, name, len, 0);
902
903 if (!fetched_isarev) {
904 /* If the name deletion caused a name change, then we
905 * are not going to call mro_isa_changed_in with this
906 * name (and not at all if it has become anonymous) so
907 * we need to delete old isarev entries here, both
908 * those in the superclasses and this class’s own list
909 * of subclasses. We simply delete the latter from
910 * PL_isarev, since we still need it. hv_delete morti-
911 * fies it for us, so sv_2mortal is not necessary. */
912 if(HvENAME_HEK(oldstash) != enamehek) {
913 if(meta->isa && HvARRAY(meta->isa))
914 mro_clean_isarev(meta->isa, name, len, NULL);
915 isarev = (HV *)hv_delete(PL_isarev, name, len, 0);
916 fetched_isarev=TRUE;
917 }
918 }
919 }
80ebaca2 920 }
d7fbb1de 921 }
80ebaca2 922 check_stash:
8b9e80a3 923 if(stash) {
d7879cf0
FC
924 if(SvTYPE(namesv) == SVt_PVAV) {
925 items = AvFILLp((AV *)namesv) + 1;
926 svp = AvARRAY((AV *)namesv);
927 }
928 else {
929 items = 1;
930 svp = &namesv;
931 }
932 while (items--) {
933 STRLEN len;
934 const char *name = SvPVx_const(*svp++, len);
935 hv_ename_add(stash, name, len, 0);
936 }
80ebaca2 937
b89cdb22
FC
938 /* Add it to the big list if it needs
939 * mro_isa_changed_in called on it. That happens if it was
80ebaca2
FC
940 * detached from the symbol table (so it had no HvENAME) before
941 * being assigned to the spot named by the ‘name’ variable, because
942 * its cached isa linerisation is now stale (the effective name
943 * having changed), and subclasses will then use that cache when
944 * mro_package_moved calls mro_isa_changed_in. (See
8b9e80a3 945 * [perl #77358].)
80ebaca2 946 *
8b9e80a3 947 * If it did have a name, then its previous name is still
80ebaca2
FC
948 * used in isa caches, and there is no need for
949 * mro_package_moved to call mro_isa_changed_in.
8b9e80a3 950 */
80ebaca2
FC
951
952 entry
953 = (HE *)
954 hv_common(
b89cdb22 955 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
df5f182b 956 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2 957 );
b89cdb22 958 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
80ebaca2 959 stash = NULL;
b89cdb22
FC
960 else {
961 HeVAL(entry)
962 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
963 if(!stash_had_name)
90ba1f34
FC
964 {
965 struct mro_meta * const meta = HvMROMETA(stash);
b89cdb22
FC
966 (void)
967 hv_store(
968 stashes, (const char *)&stash, sizeof(HV *),
90ba1f34
FC
969 meta->isa
970 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
971 : &PL_sv_yes,
972 0
b89cdb22 973 );
beeda143 974 CLEAR_LINEAR(meta);
90ba1f34 975 }
b89cdb22 976 }
8b9e80a3 977 }
d7fbb1de 978
80ebaca2
FC
979 if(!stash && !oldstash)
980 /* Both stashes have been encountered already. */
981 return;
982
983 /* Add all the subclasses to the big list. */
d7879cf0
FC
984 if(!fetched_isarev) {
985 /* If oldstash is not null, then we can use its HvENAME to look up
986 the isarev hash, since all its subclasses will be listed there.
06f3ce86
FC
987 It will always have an HvENAME. It the HvENAME was removed
988 above, then fetch_isarev will be true, and this code will not be
989 reached.
990
991 If oldstash is null, then this is an empty spot with no stash in
992 it, so subclasses could be listed in isarev hashes belonging to
993 any of the names, so we have to check all of them.
994 */
e0aa2606 995 assert(!oldstash || HvENAME(oldstash));
06f3ce86
FC
996 if (oldstash) {
997 /* Extra variable to avoid a compiler warning */
998 char * const hvename = HvENAME(oldstash);
d7879cf0 999 fetched_isarev = TRUE;
a51ee39b 1000 svp = hv_fetch(PL_isarev, hvename, HvENAMELEN_get(oldstash), 0);
d7879cf0
FC
1001 if (svp) isarev = MUTABLE_HV(*svp);
1002 }
1003 else if(SvTYPE(namesv) == SVt_PVAV) {
1004 items = AvFILLp((AV *)namesv) + 1;
1005 svp = AvARRAY((AV *)namesv);
1006 }
1007 else {
1008 items = 1;
1009 svp = &namesv;
1010 }
1011 }
80ebaca2 1012 if(
d7879cf0 1013 isarev || !fetched_isarev
80ebaca2 1014 ) {
d7879cf0 1015 while (fetched_isarev || items--) {
80ebaca2 1016 HE *iter;
d7879cf0
FC
1017
1018 if (!fetched_isarev) {
1019 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1020 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1021 }
1022
80ebaca2
FC
1023 hv_iterinit(isarev);
1024 while((iter = hv_iternext(isarev))) {
1025 I32 len;
1026 const char* const revkey = hv_iterkey(iter, &len);
1027 HV* revstash = gv_stashpvn(revkey, len, 0);
90ba1f34 1028 struct mro_meta * meta;
80ebaca2
FC
1029
1030 if(!revstash) continue;
90ba1f34 1031 meta = HvMROMETA(revstash);
b89cdb22
FC
1032 (void)
1033 hv_store(
1034 stashes, (const char *)&revstash, sizeof(HV *),
90ba1f34
FC
1035 meta->isa
1036 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1037 : &PL_sv_yes,
1038 0
b89cdb22 1039 );
beeda143 1040 CLEAR_LINEAR(meta);
80ebaca2 1041 }
d7879cf0
FC
1042
1043 if (fetched_isarev) break;
1044 }
80ebaca2 1045 }
d056e33c 1046
c8bbf675
FC
1047 /* This is partly based on code in hv_iternext_flags. We are not call-
1048 ing that here, as we want to avoid resetting the hash iterator. */
1049
d056e33c
FC
1050 /* Skip the entire loop if the hash is empty. */
1051 if(oldstash && HvUSEDKEYS(oldstash)) {
1052 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 1053 seen = (HV *) sv_2mortal((SV *)newHV());
d056e33c 1054
80ebaca2
FC
1055 /* Iterate through entries in the oldstash, adding them to the
1056 list, meanwhile doing the equivalent of $seen{$key} = 1.
d056e33c
FC
1057 */
1058
1059 while (++riter <= (I32)xhv->xhv_max) {
1060 entry = (HvARRAY(oldstash))[riter];
1061
1062 /* Iterate through the entries in this list */
1063 for(; entry; entry = HeNEXT(entry)) {
1064 const char* key;
1065 I32 len;
1066
1067 /* If this entry is not a glob, ignore it.
1068 Try the next. */
1069 if (!isGV(HeVAL(entry))) continue;
1070
1071 key = hv_iterkey(entry, &len);
1072 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
1073 HV * const oldsubstash = GvHV(HeVAL(entry));
1074 SV ** const stashentry
1075 = stash ? hv_fetch(stash, key, len, 0) : NULL;
35759254 1076 HV *substash = NULL;
62c1e33f
FC
1077
1078 /* Avoid main::main::main::... */
1079 if(oldsubstash == oldstash) continue;
1080
d056e33c 1081 if(
35759254
FC
1082 (
1083 stashentry && *stashentry
1084 && (substash = GvHV(*stashentry))
1085 )
00169e2c 1086 || (oldsubstash && HvENAME_get(oldsubstash))
d056e33c 1087 )
35759254
FC
1088 {
1089 /* Add :: and the key (minus the trailing ::)
d7879cf0
FC
1090 to each name. */
1091 SV *subname;
1092 if(SvTYPE(namesv) == SVt_PVAV) {
1093 SV *aname;
1094 items = AvFILLp((AV *)namesv) + 1;
1095 svp = AvARRAY((AV *)namesv);
1096 subname = sv_2mortal((SV *)newAV());
1097 while (items--) {
1098 aname = newSVsv(*svp++);
1099 sv_catpvs(aname, "::");
1100 sv_catpvn(aname, key, len-2);
1101 av_push((AV *)subname, aname);
1102 }
80ebaca2 1103 }
d7879cf0
FC
1104 else {
1105 subname = sv_2mortal(newSVsv(namesv));
1106 sv_catpvs(subname, "::");
1107 sv_catpvn(subname, key, len-2);
1108 }
1109 mro_gather_and_rename(
1110 stashes, seen_stashes,
1111 substash, oldsubstash, subname
1112 );
35759254 1113 }
d056e33c
FC
1114
1115 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
1116 }
1117 }
1118 }
1119 }
c8bbf675
FC
1120
1121 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
1122 if (stash && HvUSEDKEYS(stash)) {
1123 xhv = (XPVHV*)SvANY(stash);
b89cdb22 1124 riter = -1;
d056e33c
FC
1125
1126 /* Iterate through the new stash, skipping $seen{$key} items,
b89cdb22 1127 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
c8bbf675
FC
1128 while (++riter <= (I32)xhv->xhv_max) {
1129 entry = (HvARRAY(stash))[riter];
1130
1131 /* Iterate through the entries in this list */
1132 for(; entry; entry = HeNEXT(entry)) {
1133 const char* key;
1134 I32 len;
1135
1136 /* If this entry is not a glob, ignore it.
1137 Try the next. */
1138 if (!isGV(HeVAL(entry))) continue;
1139
1140 key = hv_iterkey(entry, &len);
1141 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
d056e33c
FC
1142 HV *substash;
1143
1144 /* If this entry was seen when we iterated through the
1145 oldstash, skip it. */
1146 if(seen && hv_exists(seen, key, len)) continue;
1147
1148 /* We get here only if this stash has no corresponding
1149 entry in the stash being replaced. */
1150
1151 substash = GvHV(HeVAL(entry));
35759254 1152 if(substash) {
d7879cf0 1153 SV *subname;
62c1e33f
FC
1154
1155 /* Avoid checking main::main::main::... */
1156 if(substash == stash) continue;
1157
d056e33c 1158 /* Add :: and the key (minus the trailing ::)
d7879cf0
FC
1159 to each name. */
1160 if(SvTYPE(namesv) == SVt_PVAV) {
1161 SV *aname;
1162 items = AvFILLp((AV *)namesv) + 1;
1163 svp = AvARRAY((AV *)namesv);
1164 subname = sv_2mortal((SV *)newAV());
1165 while (items--) {
1166 aname = newSVsv(*svp++);
1167 sv_catpvs(aname, "::");
1168 sv_catpvn(aname, key, len-2);
1169 av_push((AV *)subname, aname);
1170 }
1171 }
1172 else {
1173 subname = sv_2mortal(newSVsv(namesv));
1174 sv_catpvs(subname, "::");
1175 sv_catpvn(subname, key, len-2);
1176 }
80ebaca2 1177 mro_gather_and_rename(
b89cdb22 1178 stashes, seen_stashes,
d7879cf0 1179 substash, NULL, subname
d056e33c
FC
1180 );
1181 }
c8bbf675
FC
1182 }
1183 }
1184 }
1185 }
1186}
1187
1188/*
e1a479c5
BB
1189=for apidoc mro_method_changed_in
1190
47c9dd14
BB
1191Invalidates method caching on any child classes
1192of the given stash, so that they might notice
1193the changes in this one.
e1a479c5
BB
1194
1195Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
1196perl source outside of C<mro.c> should be
1197replaced by calls to this.
1198
1199Perl automatically handles most of the common
1200ways a method might be redefined. However, there
1201are a few ways you could change a method in a stash
1202without the cache code noticing, in which case you
1203need to call this method afterwards:
e1a479c5 1204
dd69841b
BB
12051) Directly manipulating the stash HV entries from
1206XS code.
e1a479c5 1207
dd69841b
BB
12082) Assigning a reference to a readonly scalar
1209constant into a stash entry in order to create
1210a constant subroutine (like constant.pm
1211does).
1212
1213This same method is available from pure perl
1214via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
1215
1216=cut
1217*/
1218void
1219Perl_mro_method_changed_in(pTHX_ HV *stash)
1220{
00169e2c
FC
1221 const char * const stashname = HvENAME_get(stash);
1222 const STRLEN stashname_len = HvENAMELEN_get(stash);
dd69841b 1223
1e05feb3 1224 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 1225 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 1226
7918f24d
NC
1227 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1228
2c7f4b87
BB
1229 if(!stashname)
1230 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1231
70cd14a1
CB
1232 /* Inc the package generation, since a local method changed */
1233 HvMROMETA(stash)->pkg_gen++;
1234
e1a479c5
BB
1235 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1236 invalidate all method caches globally */
dd69841b
BB
1237 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1238 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
1239 PL_sub_generation++;
1240 return;
1241 }
1242
1243 /* else, invalidate the method caches of all child classes,
1244 but not itself */
dd69841b 1245 if(isarev) {
1e05feb3
AL
1246 HE* iter;
1247
e1a479c5
BB
1248 hv_iterinit(isarev);
1249 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
1250 I32 len;
1251 const char* const revkey = hv_iterkey(iter, &len);
1252 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
1253 struct mro_meta* mrometa;
1254
1255 if(!revstash) continue;
1256 mrometa = HvMROMETA(revstash);
dd69841b 1257 mrometa->cache_gen++;
e1a479c5
BB
1258 if(mrometa->mro_nextmethod)
1259 hv_clear(mrometa->mro_nextmethod);
1260 }
1261 }
1262}
1263
31b9005d
NC
1264void
1265Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1266{
1267 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1268
1269 PERL_ARGS_ASSERT_MRO_SET_MRO;
1270
1271 if (!which)
1272 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1273
1274 if(meta->mro_which != which) {
9953ff72 1275 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
1276 /* If we were storing something directly, put it in the hash before
1277 we lose it. */
1278 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 1279 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
1280 }
1281 meta->mro_which = which;
1282 /* Scrub our cached pointer to the private data. */
3a6fa573 1283 meta->mro_linear_current = NULL;
31b9005d
NC
1284 /* Only affects local method cache, not
1285 even child classes */
1286 meta->cache_gen++;
1287 if(meta->mro_nextmethod)
1288 hv_clear(meta->mro_nextmethod);
1289 }
1290}
1291
e1a479c5
BB
1292#include "XSUB.h"
1293
e1a479c5 1294XS(XS_mro_method_changed_in);
e1a479c5
BB
1295
1296void
1297Perl_boot_core_mro(pTHX)
1298{
1299 dVAR;
1300 static const char file[] = __FILE__;
1301
a3e6e81e 1302 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 1303
e1a479c5 1304 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
1305}
1306
e1a479c5
BB
1307XS(XS_mro_method_changed_in)
1308{
1309 dVAR;
1310 dXSARGS;
1311 SV* classname;
1312 HV* class_stash;
1313
e1a479c5 1314 if(items != 1)
afa74d42 1315 croak_xs_usage(cv, "classname");
e1a479c5
BB
1316
1317 classname = ST(0);
1318
1319 class_stash = gv_stashsv(classname, 0);
1320 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1321
1322 mro_method_changed_in(class_stash);
1323
1324 XSRETURN_EMPTY;
1325}
1326
e1a479c5
BB
1327/*
1328 * Local variables:
1329 * c-indentation-style: bsd
1330 * c-basic-offset: 4
1331 * indent-tabs-mode: t
1332 * End:
1333 *
1334 * ex: set ts=8 sts=4 sw=4 noet:
1335 */