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