This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Use SvREFCNT_dec_NN in one place in mro.c
[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)) {
06059157 134 SvREFCNT_dec_NN(wrapper);
a3e6e81e
NC
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);
c07f9fb2 581 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
80ebaca2
FC
582
583 (void)
584 hv_store(
585 isa_hashes, (const char*)&revstash, sizeof(HV *),
586 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
587 );
588 revmeta->isa = NULL;
589 }
590
591 /* Second pass: Update PL_isarev. We can just use isa_hashes to
592 * avoid another round of stash lookups. */
593
594 /* isarev might be deleted from PL_isarev during this loop, so hang
595 * on to it. */
596 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
597
598 if(isa_hashes) {
599 hv_iterinit(isa_hashes);
600 while((iter = hv_iternext(isa_hashes))) {
601 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
602 HV * const isa = (HV *)HeVAL(iter);
603 const HEK *namehek;
604
80ebaca2
FC
605 /* We're starting at the 2nd element, skipping revstash */
606 linear_mro = mro_get_linear_isa(revstash);
607 svp = AvARRAY(linear_mro) + 1;
608 items = AvFILLp(linear_mro);
609
610 namehek = HvENAME_HEK(revstash);
611 if (!namehek) namehek = HvNAME_HEK(revstash);
612
613 while (items--) {
614 SV* const sv = *svp++;
615 HV* mroisarev;
616
617 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
618
619 /* That fetch should not fail. But if it had to create
620 a new SV for us, then will need to upgrade it to an
621 HV (which sv_upgrade() can now do for us). */
622
623 mroisarev = MUTABLE_HV(HeVAL(he));
624
625 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
626
627 /* This hash only ever contains PL_sv_yes. Storing it
628 over itself is almost as cheap as calling hv_exists,
629 so on aggregate we expect to save time by not making
630 two calls to the common HV code for the case where
631 it doesn't exist. */
632
633 (void)
634 hv_store(
204e6232
BF
635 mroisarev, HEK_KEY(namehek),
636 HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
80ebaca2
FC
637 &PL_sv_yes, 0
638 );
639 }
640
641 if((SV *)isa != &PL_sv_undef)
642 mro_clean_isarev(
643 isa, HEK_KEY(namehek), HEK_LEN(namehek),
204e6232 644 HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
80ebaca2
FC
645 );
646 }
e1a479c5
BB
647 }
648 }
649
c9143745
FC
650 /* Now iterate our MRO (parents), adding ourselves and everything from
651 our isarev to their isarev.
1c908217
RGS
652 */
653
654 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
655 linear_mro = mro_get_linear_isa(stash);
656 svp = AvARRAY(linear_mro) + 1;
657 items = AvFILLp(linear_mro);
1c908217 658
e1a479c5
BB
659 while (items--) {
660 SV* const sv = *svp++;
e1a479c5
BB
661 HV* mroisarev;
662
117b69ca
NC
663 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
664
665 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
666 us, then will need to upgrade it to an HV (which sv_upgrade() can
667 now do for us. */
117b69ca 668
85fbaab2 669 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 670
ad64d0ec 671 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 672
25270bc0
NC
673 /* This hash only ever contains PL_sv_yes. Storing it over itself is
674 almost as cheap as calling hv_exists, so on aggregate we expect to
675 save time by not making two calls to the common HV code for the
676 case where it doesn't exist. */
677
204e6232 678 (void)hv_store(mroisarev, stashname,
c60dbbc3 679 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0);
80ebaca2
FC
680 }
681
e1fa07e3 682 /* Delete our name from our former parents' isarevs. */
80ebaca2 683 if(isa && HvARRAY(isa))
204e6232
BF
684 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
685 (stashname_utf8 ? SVf_UTF8 : 0) );
80ebaca2
FC
686}
687
688/* Deletes name from all the isarev entries listed in isa */
689STATIC void
690S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
204e6232 691 const STRLEN len, HV * const exceptions, U32 flags)
80ebaca2
FC
692{
693 HE* iter;
e1a479c5 694
80ebaca2
FC
695 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
696
e1fa07e3 697 /* Delete our name from our former parents' isarevs. */
80ebaca2
FC
698 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
699 SV **svp;
700 while((iter = hv_iternext(isa))) {
701 I32 klen;
702 const char * const key = hv_iterkey(iter, &klen);
204e6232
BF
703 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
704 continue;
705 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
80ebaca2
FC
706 if(svp) {
707 HV * const isarev = (HV *)*svp;
c60dbbc3 708 (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, G_DISCARD);
1b95d04f 709 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
204e6232
BF
710 (void)hv_delete(PL_isarev, key,
711 HeKUTF8(iter) ? -klen : klen, G_DISCARD);
e1a479c5
BB
712 }
713 }
714 }
715}
716
717/*
c8bbf675
FC
718=for apidoc mro_package_moved
719
d056e33c 720Call this function to signal to a stash that it has been assigned to
61daec80
FC
721another spot in the stash hierarchy. C<stash> is the stash that has been
722assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
afdbe55d 723that is actually being assigned to.
d056e33c 724
35759254 725This can also be called with a null first argument to
d056e33c
FC
726indicate that C<oldstash> has been deleted.
727
728This function invalidates isa caches on the old stash, on all subpackages
729nested inside it, and on the subclasses of all those, including
730non-existent packages that have corresponding entries in C<stash>.
c8bbf675 731
80ebaca2
FC
732It also sets the effective names (C<HvENAME>) on all the stashes as
733appropriate.
734
0290c710 735If the C<gv> is present and is not in the symbol table, then this function
61daec80 736simply returns. This checked will be skipped if C<flags & 1>.
0290c710 737
c8bbf675
FC
738=cut
739*/
740void
35759254 741Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
afdbe55d 742 const GV * const gv, U32 flags)
c8bbf675 743{
d7879cf0
FC
744 SV *namesv;
745 HEK **namep;
746 I32 name_count;
80ebaca2
FC
747 HV *stashes;
748 HE* iter;
62c1e33f 749
afdbe55d 750 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
35759254 751 assert(stash || oldstash);
35759254 752
d7879cf0 753 /* Determine the name(s) of the location that stash was assigned to
35759254
FC
754 * or from which oldstash was removed.
755 *
928eb066 756 * We cannot reliably use the name in oldstash, because it may have
35759254
FC
757 * been deleted from the location in the symbol table that its name
758 * suggests, as in this case:
759 *
760 * $globref = \*foo::bar::;
761 * Symbol::delete_package("foo");
762 * *$globref = \%baz::;
763 * *$globref = *frelp::;
764 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
765 *
d7879cf0
FC
766 * So we get it from the gv. But, since the gv may no longer be in the
767 * symbol table, we check that first. The only reliable way to tell is
768 * to see whether its stash has an effective name and whether the gv
769 * resides in that stash under its name. That effective name may be
770 * different from what gv_fullname4 would use.
771 * If flags & 1, the caller has asked us to skip the check.
35759254 772 */
d7879cf0
FC
773 if(!(flags & 1)) {
774 SV **svp;
775 if(
776 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
204e6232
BF
777 !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
778 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
d7879cf0
FC
779 *svp != (SV *)gv
780 ) return;
781 }
782 assert(SvOOK(GvSTASH(gv)));
1f656fcf 783 assert(GvNAMELEN(gv));
d7879cf0 784 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
1f656fcf 785 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
d7879cf0
FC
786 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
787 if (!name_count) {
788 name_count = 1;
15d9236d 789 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
d7879cf0
FC
790 }
791 else {
15d9236d 792 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
d7879cf0
FC
793 if (name_count < 0) ++namep, name_count = -name_count - 1;
794 }
795 if (name_count == 1) {
796 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
1f656fcf
FC
797 namesv = GvNAMELEN(gv) == 1
798 ? newSVpvs_flags(":", SVs_TEMP)
799 : newSVpvs_flags("", SVs_TEMP);
d7879cf0
FC
800 }
801 else {
802 namesv = sv_2mortal(newSVhek(*namep));
1f656fcf
FC
803 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
804 else sv_catpvs(namesv, "::");
d7879cf0 805 }
204e6232 806 if (GvNAMELEN(gv) != 1) {
c682ebef
FC
807 sv_catpvn_flags(
808 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
d7879cf0 809 /* skip trailing :: */
c682ebef
FC
810 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
811 );
204e6232 812 }
d7879cf0
FC
813 }
814 else {
815 SV *aname;
816 namesv = sv_2mortal((SV *)newAV());
817 while (name_count--) {
818 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
1f656fcf
FC
819 aname = GvNAMELEN(gv) == 1
820 ? newSVpvs(":")
821 : newSVpvs("");
822 namep++;
d7879cf0
FC
823 }
824 else {
825 aname = newSVhek(*namep++);
1f656fcf
FC
826 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
827 else sv_catpvs(aname, "::");
d7879cf0 828 }
204e6232 829 if (GvNAMELEN(gv) != 1) {
c682ebef
FC
830 sv_catpvn_flags(
831 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
d7879cf0 832 /* skip trailing :: */
c682ebef
FC
833 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
834 );
204e6232 835 }
d7879cf0
FC
836 av_push((AV *)namesv, aname);
837 }
838 }
c8bbf675 839
80ebaca2
FC
840 /* Get a list of all the affected classes. */
841 /* We cannot simply pass them all to mro_isa_changed_in to avoid
842 the list, as that function assumes that only one package has
843 changed. It does not work with:
844
845 @foo::ISA = qw( B B::B );
846 *B:: = delete $::{"A::"};
847
848 as neither B nor B::B can be updated before the other, since they
849 will reset caches on foo, which will see either B or B::B with the
850 wrong name. The names must be set on *all* affected stashes before
beeda143 851 we do anything else. (And linearisations must be cleared, too.)
80ebaca2
FC
852 */
853 stashes = (HV *) sv_2mortal((SV *)newHV());
b89cdb22
FC
854 mro_gather_and_rename(
855 stashes, (HV *) sv_2mortal((SV *)newHV()),
d7879cf0 856 stash, oldstash, namesv
b89cdb22 857 );
80ebaca2 858
80ebaca2
FC
859 /* Once the caches have been wiped on all the classes, call
860 mro_isa_changed_in on each. */
861 hv_iterinit(stashes);
862 while((iter = hv_iternext(stashes))) {
90ba1f34
FC
863 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
864 if(HvENAME(stash)) {
865 /* We have to restore the original meta->isa (that
866 mro_gather_and_rename set aside for us) this way, in case
867 one class in this list is a superclass of a another class
868 that we have already encountered. In such a case, meta->isa
869 will have been overwritten without old entries being deleted
870 from PL_isarev. */
871 struct mro_meta * const meta = HvMROMETA(stash);
872 if(meta->isa != (HV *)HeVAL(iter)){
873 SvREFCNT_dec(meta->isa);
874 meta->isa
875 = HeVAL(iter) == &PL_sv_yes
876 ? NULL
877 : (HV *)HeVAL(iter);
878 HeVAL(iter) = NULL; /* We donated our reference count. */
879 }
880 mro_isa_changed_in(stash);
881 }
80ebaca2
FC
882 }
883}
884
aeba7c97 885STATIC void
b89cdb22 886S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
d7879cf0 887 HV *stash, HV *oldstash, SV *namesv)
80ebaca2 888{
eb578fdb
KW
889 XPVHV* xhv;
890 HE *entry;
80ebaca2 891 I32 riter = -1;
4c916935 892 I32 items = 0;
80ebaca2 893 const bool stash_had_name = stash && HvENAME(stash);
d7879cf0 894 bool fetched_isarev = FALSE;
80ebaca2
FC
895 HV *seen = NULL;
896 HV *isarev = NULL;
d7879cf0 897 SV **svp = NULL;
80ebaca2
FC
898
899 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
900
b89cdb22
FC
901 /* We use the seen_stashes hash to keep track of which packages have
902 been encountered so far. This must be separate from the main list of
903 stashes, as we need to distinguish between stashes being assigned
904 and stashes being replaced/deleted. (A nested stash can be on both
905 sides of an assignment. We cannot simply skip iterating through a
906 stash on the right if we have seen it on the left, as it will not
907 get its ename assigned to it.)
908
909 To avoid allocating extra SVs, instead of a bitfield we can make
910 bizarre use of immortals:
911
912 &PL_sv_undef: seen on the left (oldstash)
913 &PL_sv_no : seen on the right (stash)
914 &PL_sv_yes : seen on both sides
915
916 */
917
80ebaca2
FC
918 if(oldstash) {
919 /* Add to the big list. */
90ba1f34 920 struct mro_meta * meta;
80ebaca2
FC
921 HE * const entry
922 = (HE *)
923 hv_common(
b89cdb22 924 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
df5f182b 925 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2 926 );
b89cdb22 927 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
80ebaca2
FC
928 oldstash = NULL;
929 goto check_stash;
930 }
b89cdb22
FC
931 HeVAL(entry)
932 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
90ba1f34 933 meta = HvMROMETA(oldstash);
b89cdb22
FC
934 (void)
935 hv_store(
936 stashes, (const char *)&oldstash, sizeof(HV *),
90ba1f34
FC
937 meta->isa
938 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
939 : &PL_sv_yes,
940 0
b89cdb22 941 );
beeda143 942 CLEAR_LINEAR(meta);
80ebaca2
FC
943
944 /* Update the effective name. */
945 if(HvENAME_get(oldstash)) {
d7879cf0
FC
946 const HEK * const enamehek = HvENAME_HEK(oldstash);
947 if(SvTYPE(namesv) == SVt_PVAV) {
948 items = AvFILLp((AV *)namesv) + 1;
949 svp = AvARRAY((AV *)namesv);
950 }
951 else {
952 items = 1;
953 svp = &namesv;
954 }
955 while (items--) {
204e6232 956 const U32 name_utf8 = SvUTF8(*svp);
d7879cf0 957 STRLEN len;
103f5a36
NC
958 const char *name = SvPVx_const(*svp, len);
959 if(PL_stashcache) {
960 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
961 *svp));
c60dbbc3 962 (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
103f5a36
NC
963 }
964 ++svp;
204e6232 965 hv_ename_delete(oldstash, name, len, name_utf8);
d7879cf0
FC
966
967 if (!fetched_isarev) {
968 /* If the name deletion caused a name change, then we
969 * are not going to call mro_isa_changed_in with this
970 * name (and not at all if it has become anonymous) so
971 * we need to delete old isarev entries here, both
e1fa07e3 972 * those in the superclasses and this class's own list
d7879cf0
FC
973 * of subclasses. We simply delete the latter from
974 * PL_isarev, since we still need it. hv_delete morti-
975 * fies it for us, so sv_2mortal is not necessary. */
976 if(HvENAME_HEK(oldstash) != enamehek) {
977 if(meta->isa && HvARRAY(meta->isa))
204e6232
BF
978 mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
979 isarev = (HV *)hv_delete(PL_isarev, name,
c60dbbc3 980 name_utf8 ? -(I32)len : (I32)len, 0);
d7879cf0
FC
981 fetched_isarev=TRUE;
982 }
983 }
984 }
80ebaca2 985 }
d7fbb1de 986 }
80ebaca2 987 check_stash:
8b9e80a3 988 if(stash) {
d7879cf0
FC
989 if(SvTYPE(namesv) == SVt_PVAV) {
990 items = AvFILLp((AV *)namesv) + 1;
991 svp = AvARRAY((AV *)namesv);
992 }
993 else {
994 items = 1;
995 svp = &namesv;
996 }
997 while (items--) {
204e6232 998 const U32 name_utf8 = SvUTF8(*svp);
d7879cf0
FC
999 STRLEN len;
1000 const char *name = SvPVx_const(*svp++, len);
204e6232 1001 hv_ename_add(stash, name, len, name_utf8);
d7879cf0 1002 }
80ebaca2 1003
b89cdb22
FC
1004 /* Add it to the big list if it needs
1005 * mro_isa_changed_in called on it. That happens if it was
80ebaca2 1006 * detached from the symbol table (so it had no HvENAME) before
9404893f 1007 * being assigned to the spot named by the 'name' variable, because
486ec47a 1008 * its cached isa linearisation is now stale (the effective name
80ebaca2
FC
1009 * having changed), and subclasses will then use that cache when
1010 * mro_package_moved calls mro_isa_changed_in. (See
8b9e80a3 1011 * [perl #77358].)
80ebaca2 1012 *
8b9e80a3 1013 * If it did have a name, then its previous name is still
80ebaca2
FC
1014 * used in isa caches, and there is no need for
1015 * mro_package_moved to call mro_isa_changed_in.
8b9e80a3 1016 */
80ebaca2
FC
1017
1018 entry
1019 = (HE *)
1020 hv_common(
b89cdb22 1021 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
df5f182b 1022 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2 1023 );
b89cdb22 1024 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
80ebaca2 1025 stash = NULL;
b89cdb22
FC
1026 else {
1027 HeVAL(entry)
1028 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1029 if(!stash_had_name)
90ba1f34
FC
1030 {
1031 struct mro_meta * const meta = HvMROMETA(stash);
b89cdb22
FC
1032 (void)
1033 hv_store(
1034 stashes, (const char *)&stash, sizeof(HV *),
90ba1f34
FC
1035 meta->isa
1036 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1037 : &PL_sv_yes,
1038 0
b89cdb22 1039 );
beeda143 1040 CLEAR_LINEAR(meta);
90ba1f34 1041 }
b89cdb22 1042 }
8b9e80a3 1043 }
d7fbb1de 1044
80ebaca2
FC
1045 if(!stash && !oldstash)
1046 /* Both stashes have been encountered already. */
1047 return;
1048
1049 /* Add all the subclasses to the big list. */
d7879cf0
FC
1050 if(!fetched_isarev) {
1051 /* If oldstash is not null, then we can use its HvENAME to look up
1052 the isarev hash, since all its subclasses will be listed there.
06f3ce86
FC
1053 It will always have an HvENAME. It the HvENAME was removed
1054 above, then fetch_isarev will be true, and this code will not be
1055 reached.
1056
1057 If oldstash is null, then this is an empty spot with no stash in
1058 it, so subclasses could be listed in isarev hashes belonging to
1059 any of the names, so we have to check all of them.
1060 */
e0aa2606 1061 assert(!oldstash || HvENAME(oldstash));
06f3ce86
FC
1062 if (oldstash) {
1063 /* Extra variable to avoid a compiler warning */
1064 char * const hvename = HvENAME(oldstash);
d7879cf0 1065 fetched_isarev = TRUE;
204e6232
BF
1066 svp = hv_fetch(PL_isarev, hvename,
1067 HvENAMEUTF8(oldstash)
1068 ? -HvENAMELEN_get(oldstash)
1069 : HvENAMELEN_get(oldstash), 0);
d7879cf0
FC
1070 if (svp) isarev = MUTABLE_HV(*svp);
1071 }
1072 else if(SvTYPE(namesv) == SVt_PVAV) {
1073 items = AvFILLp((AV *)namesv) + 1;
1074 svp = AvARRAY((AV *)namesv);
1075 }
1076 else {
1077 items = 1;
1078 svp = &namesv;
1079 }
1080 }
80ebaca2 1081 if(
d7879cf0 1082 isarev || !fetched_isarev
80ebaca2 1083 ) {
d7879cf0 1084 while (fetched_isarev || items--) {
80ebaca2 1085 HE *iter;
d7879cf0
FC
1086
1087 if (!fetched_isarev) {
1088 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1089 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1090 }
1091
80ebaca2
FC
1092 hv_iterinit(isarev);
1093 while((iter = hv_iternext(isarev))) {
204e6232 1094 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
90ba1f34 1095 struct mro_meta * meta;
80ebaca2
FC
1096
1097 if(!revstash) continue;
90ba1f34 1098 meta = HvMROMETA(revstash);
b89cdb22
FC
1099 (void)
1100 hv_store(
1101 stashes, (const char *)&revstash, sizeof(HV *),
90ba1f34
FC
1102 meta->isa
1103 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1104 : &PL_sv_yes,
1105 0
b89cdb22 1106 );
beeda143 1107 CLEAR_LINEAR(meta);
80ebaca2 1108 }
d7879cf0
FC
1109
1110 if (fetched_isarev) break;
1111 }
80ebaca2 1112 }
d056e33c 1113
c8bbf675
FC
1114 /* This is partly based on code in hv_iternext_flags. We are not call-
1115 ing that here, as we want to avoid resetting the hash iterator. */
1116
d056e33c
FC
1117 /* Skip the entire loop if the hash is empty. */
1118 if(oldstash && HvUSEDKEYS(oldstash)) {
1119 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 1120 seen = (HV *) sv_2mortal((SV *)newHV());
d056e33c 1121
80ebaca2
FC
1122 /* Iterate through entries in the oldstash, adding them to the
1123 list, meanwhile doing the equivalent of $seen{$key} = 1.
d056e33c
FC
1124 */
1125
1126 while (++riter <= (I32)xhv->xhv_max) {
1127 entry = (HvARRAY(oldstash))[riter];
1128
1129 /* Iterate through the entries in this list */
1130 for(; entry; entry = HeNEXT(entry)) {
1131 const char* key;
090c3c37 1132 I32 len;
d056e33c
FC
1133
1134 /* If this entry is not a glob, ignore it.
1135 Try the next. */
1136 if (!isGV(HeVAL(entry))) continue;
1137
090c3c37 1138 key = hv_iterkey(entry, &len);
1f656fcf
FC
1139 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1140 || (len == 1 && key[0] == ':')) {
d056e33c
FC
1141 HV * const oldsubstash = GvHV(HeVAL(entry));
1142 SV ** const stashentry
090c3c37 1143 = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
35759254 1144 HV *substash = NULL;
62c1e33f
FC
1145
1146 /* Avoid main::main::main::... */
1147 if(oldsubstash == oldstash) continue;
1148
d056e33c 1149 if(
35759254
FC
1150 (
1151 stashentry && *stashentry
1152 && (substash = GvHV(*stashentry))
1153 )
00169e2c 1154 || (oldsubstash && HvENAME_get(oldsubstash))
d056e33c 1155 )
35759254
FC
1156 {
1157 /* Add :: and the key (minus the trailing ::)
d7879cf0
FC
1158 to each name. */
1159 SV *subname;
1160 if(SvTYPE(namesv) == SVt_PVAV) {
1161 SV *aname;
1162 items = AvFILLp((AV *)namesv) + 1;
1163 svp = AvARRAY((AV *)namesv);
1164 subname = sv_2mortal((SV *)newAV());
1165 while (items--) {
1166 aname = newSVsv(*svp++);
1f656fcf
FC
1167 if (len == 1)
1168 sv_catpvs(aname, ":");
1169 else {
1170 sv_catpvs(aname, "::");
c682ebef
FC
1171 sv_catpvn_flags(
1172 aname, key, len-2,
090c3c37 1173 HeUTF8(entry)
c682ebef
FC
1174 ? SV_CATUTF8 : SV_CATBYTES
1175 );
1f656fcf 1176 }
d7879cf0
FC
1177 av_push((AV *)subname, aname);
1178 }
80ebaca2 1179 }
d7879cf0
FC
1180 else {
1181 subname = sv_2mortal(newSVsv(namesv));
1f656fcf
FC
1182 if (len == 1) sv_catpvs(subname, ":");
1183 else {
1184 sv_catpvs(subname, "::");
c682ebef
FC
1185 sv_catpvn_flags(
1186 subname, key, len-2,
090c3c37 1187 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
c682ebef 1188 );
1f656fcf 1189 }
d7879cf0
FC
1190 }
1191 mro_gather_and_rename(
1192 stashes, seen_stashes,
1193 substash, oldsubstash, subname
1194 );
35759254 1195 }
d056e33c 1196
090c3c37 1197 (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
d056e33c
FC
1198 }
1199 }
1200 }
1201 }
c8bbf675
FC
1202
1203 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
1204 if (stash && HvUSEDKEYS(stash)) {
1205 xhv = (XPVHV*)SvANY(stash);
b89cdb22 1206 riter = -1;
d056e33c
FC
1207
1208 /* Iterate through the new stash, skipping $seen{$key} items,
b89cdb22 1209 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
c8bbf675
FC
1210 while (++riter <= (I32)xhv->xhv_max) {
1211 entry = (HvARRAY(stash))[riter];
1212
1213 /* Iterate through the entries in this list */
1214 for(; entry; entry = HeNEXT(entry)) {
1215 const char* key;
090c3c37 1216 I32 len;
c8bbf675
FC
1217
1218 /* If this entry is not a glob, ignore it.
1219 Try the next. */
1220 if (!isGV(HeVAL(entry))) continue;
1221
090c3c37 1222 key = hv_iterkey(entry, &len);
1f656fcf
FC
1223 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1224 || (len == 1 && key[0] == ':')) {
d056e33c
FC
1225 HV *substash;
1226
1227 /* If this entry was seen when we iterated through the
1228 oldstash, skip it. */
090c3c37 1229 if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
d056e33c
FC
1230
1231 /* We get here only if this stash has no corresponding
1232 entry in the stash being replaced. */
1233
1234 substash = GvHV(HeVAL(entry));
35759254 1235 if(substash) {
d7879cf0 1236 SV *subname;
62c1e33f
FC
1237
1238 /* Avoid checking main::main::main::... */
1239 if(substash == stash) continue;
1240
d056e33c 1241 /* Add :: and the key (minus the trailing ::)
d7879cf0
FC
1242 to each name. */
1243 if(SvTYPE(namesv) == SVt_PVAV) {
1244 SV *aname;
1245 items = AvFILLp((AV *)namesv) + 1;
1246 svp = AvARRAY((AV *)namesv);
1247 subname = sv_2mortal((SV *)newAV());
1248 while (items--) {
1249 aname = newSVsv(*svp++);
1f656fcf
FC
1250 if (len == 1)
1251 sv_catpvs(aname, ":");
1252 else {
1253 sv_catpvs(aname, "::");
c682ebef
FC
1254 sv_catpvn_flags(
1255 aname, key, len-2,
090c3c37 1256 HeUTF8(entry)
c682ebef
FC
1257 ? SV_CATUTF8 : SV_CATBYTES
1258 );
1f656fcf 1259 }
d7879cf0
FC
1260 av_push((AV *)subname, aname);
1261 }
1262 }
1263 else {
1264 subname = sv_2mortal(newSVsv(namesv));
1f656fcf
FC
1265 if (len == 1) sv_catpvs(subname, ":");
1266 else {
1267 sv_catpvs(subname, "::");
c682ebef
FC
1268 sv_catpvn_flags(
1269 subname, key, len-2,
090c3c37 1270 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
c682ebef 1271 );
1f656fcf 1272 }
d7879cf0 1273 }
80ebaca2 1274 mro_gather_and_rename(
b89cdb22 1275 stashes, seen_stashes,
d7879cf0 1276 substash, NULL, subname
d056e33c
FC
1277 );
1278 }
c8bbf675
FC
1279 }
1280 }
1281 }
1282 }
1283}
1284
1285/*
e1a479c5
BB
1286=for apidoc mro_method_changed_in
1287
47c9dd14
BB
1288Invalidates method caching on any child classes
1289of the given stash, so that they might notice
1290the changes in this one.
e1a479c5
BB
1291
1292Ideally, all instances of C<PL_sub_generation++> in
25d585df 1293perl source outside of F<mro.c> should be
dd69841b
BB
1294replaced by calls to this.
1295
1296Perl automatically handles most of the common
1297ways a method might be redefined. However, there
1298are a few ways you could change a method in a stash
1299without the cache code noticing, in which case you
1300need to call this method afterwards:
e1a479c5 1301
dd69841b
BB
13021) Directly manipulating the stash HV entries from
1303XS code.
e1a479c5 1304
dd69841b
BB
13052) Assigning a reference to a readonly scalar
1306constant into a stash entry in order to create
1307a constant subroutine (like constant.pm
1308does).
1309
1310This same method is available from pure perl
1311via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
1312
1313=cut
1314*/
1315void
1316Perl_mro_method_changed_in(pTHX_ HV *stash)
1317{
00169e2c
FC
1318 const char * const stashname = HvENAME_get(stash);
1319 const STRLEN stashname_len = HvENAMELEN_get(stash);
204e6232 1320 const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
dd69841b 1321
204e6232 1322 SV ** const svp = hv_fetch(PL_isarev, stashname,
c60dbbc3 1323 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
85fbaab2 1324 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 1325
7918f24d
NC
1326 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1327
2c7f4b87
BB
1328 if(!stashname)
1329 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1330
70cd14a1
CB
1331 /* Inc the package generation, since a local method changed */
1332 HvMROMETA(stash)->pkg_gen++;
1333
8c34e50d
FC
1334 /* DESTROY can be cached in SvSTASH. */
1335 if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
1336
e1a479c5
BB
1337 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1338 invalidate all method caches globally */
dd69841b
BB
1339 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1340 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
1341 PL_sub_generation++;
1342 return;
1343 }
1344
1345 /* else, invalidate the method caches of all child classes,
1346 but not itself */
dd69841b 1347 if(isarev) {
1e05feb3
AL
1348 HE* iter;
1349
e1a479c5
BB
1350 hv_iterinit(isarev);
1351 while((iter = hv_iternext(isarev))) {
204e6232 1352 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
bc2cbbac
BB
1353 struct mro_meta* mrometa;
1354
1355 if(!revstash) continue;
1356 mrometa = HvMROMETA(revstash);
dd69841b 1357 mrometa->cache_gen++;
e1a479c5
BB
1358 if(mrometa->mro_nextmethod)
1359 hv_clear(mrometa->mro_nextmethod);
c07f9fb2 1360 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
e1a479c5
BB
1361 }
1362 }
234df27b
FC
1363
1364 /* The method change may be due to *{$package . "::()"} = \&nil; in
1365 overload.pm. */
1366 HvAMAGIC_on(stash);
e1a479c5
BB
1367}
1368
31b9005d
NC
1369void
1370Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1371{
1372 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1373
1374 PERL_ARGS_ASSERT_MRO_SET_MRO;
1375
1376 if (!which)
1377 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1378
1379 if(meta->mro_which != which) {
9953ff72 1380 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
1381 /* If we were storing something directly, put it in the hash before
1382 we lose it. */
1383 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 1384 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
1385 }
1386 meta->mro_which = which;
1387 /* Scrub our cached pointer to the private data. */
3a6fa573 1388 meta->mro_linear_current = NULL;
31b9005d
NC
1389 /* Only affects local method cache, not
1390 even child classes */
1391 meta->cache_gen++;
1392 if(meta->mro_nextmethod)
1393 hv_clear(meta->mro_nextmethod);
1394 }
1395}
1396
e1a479c5
BB
1397#include "XSUB.h"
1398
e1a479c5 1399XS(XS_mro_method_changed_in);
e1a479c5
BB
1400
1401void
1402Perl_boot_core_mro(pTHX)
1403{
1404 dVAR;
1405 static const char file[] = __FILE__;
1406
a3e6e81e 1407 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 1408
e1a479c5 1409 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
1410}
1411
e1a479c5
BB
1412XS(XS_mro_method_changed_in)
1413{
1414 dVAR;
1415 dXSARGS;
1416 SV* classname;
1417 HV* class_stash;
1418
e1a479c5 1419 if(items != 1)
afa74d42 1420 croak_xs_usage(cv, "classname");
e1a479c5
BB
1421
1422 classname = ST(0);
1423
1424 class_stash = gv_stashsv(classname, 0);
1425 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1426
1427 mro_method_changed_in(class_stash);
1428
1429 XSRETURN_EMPTY;
1430}
1431
e1a479c5
BB
1432/*
1433 * Local variables:
1434 * c-indentation-style: bsd
1435 * c-basic-offset: 4
14d04a33 1436 * indent-tabs-mode: nil
e1a479c5
BB
1437 * End:
1438 *
14d04a33 1439 * ex: set ts=8 sts=4 sw=4 et:
e1a479c5 1440 */