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