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