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