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