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