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