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