This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
msgrcv: properly downgrade the receive buffer
[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/*
51b56f5c 22=head1 MRO
e1a479c5 23These functions are related to the method resolution order of perl classes
6a6f8717 24Also see L<perlmroapi>.
e1a479c5
BB
25
26=cut
27*/
28
29#include "EXTERN.h"
4befac30 30#define PERL_IN_MRO_C
e1a479c5
BB
31#include "perl.h"
32
a3e6e81e
NC
33static const struct mro_alg dfs_alg =
34 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
3d76853f 35
fa60396f
NC
36SV *
37Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
38 const struct mro_alg *const which)
39{
40 SV **data;
41 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
42
5844ac76
NC
43 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
44 which->name, which->length, which->kflags,
45 HV_FETCH_JUST_SV, NULL, which->hash);
fa60396f
NC
46 if (!data)
47 return NULL;
48
49 /* If we've been asked to look up the private data for the current MRO, then
50 cache it. */
51 if (smeta->mro_which == which)
3a6fa573 52 smeta->mro_linear_current = *data;
fa60396f
NC
53
54 return *data;
55}
56
57SV *
58Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
59 const struct mro_alg *const which, SV *const data)
60{
61 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
62
9953ff72 63 if (!smeta->mro_linear_all) {
553e831a
NC
64 if (smeta->mro_which == which) {
65 /* If all we need to store is the current MRO's data, then don't use
66 memory on a hash with 1 element - store it direct, and signal
67 this by leaving the would-be-hash NULL. */
3a6fa573 68 smeta->mro_linear_current = data;
553e831a
NC
69 return data;
70 } else {
71 HV *const hv = newHV();
72 /* Start with 2 buckets. It's unlikely we'll need more. */
8b371338 73 HvMAX(hv) = 1;
9953ff72 74 smeta->mro_linear_all = hv;
553e831a 75
3a6fa573 76 if (smeta->mro_linear_current) {
553e831a
NC
77 /* If we were storing something directly, put it in the hash
78 before we lose it. */
8b371338 79 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
3a6fa573 80 smeta->mro_linear_current);
553e831a
NC
81 }
82 }
83 }
84
85 /* We get here if we're storing more than one linearisation for this stash,
86 or the linearisation we are storing is not that if its current MRO. */
87
88 if (smeta->mro_which == which) {
89 /* If we've been asked to store the private data for the current MRO,
90 then cache it. */
3a6fa573 91 smeta->mro_linear_current = data;
fa60396f
NC
92 }
93
9953ff72 94 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
fa60396f
NC
95 which->name, which->length, which->kflags,
96 HV_FETCH_ISSTORE, data, which->hash)) {
97 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
98 "for '%.*s' %d", (int) which->length, which->name,
99 which->kflags);
100 }
101
102 return data;
103}
104
a3e6e81e
NC
105const struct mro_alg *
106Perl_mro_get_from_name(pTHX_ SV *name) {
107 SV **data;
108
109 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
110
5844ac76
NC
111 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
112 HV_FETCH_JUST_SV, NULL, 0);
a3e6e81e
NC
113 if (!data)
114 return NULL;
115 assert(SvTYPE(*data) == SVt_IV);
116 assert(SvIOK(*data));
117 return INT2PTR(const struct mro_alg *, SvUVX(*data));
118}
119
c145ee24
FC
120/*
121=for apidoc mro_register
6a6f8717
KW
122Registers a custom mro plugin. See L<perlmroapi> for details on this and other
123mro functions.
164df45a
FC
124
125=cut
c145ee24
FC
126*/
127
a3e6e81e
NC
128void
129Perl_mro_register(pTHX_ const struct mro_alg *mro) {
130 SV *wrapper = newSVuv(PTR2UV(mro));
131
132 PERL_ARGS_ASSERT_MRO_REGISTER;
133
8b371338 134
a3e6e81e
NC
135 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
136 mro->name, mro->length, mro->kflags,
137 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
06059157 138 SvREFCNT_dec_NN(wrapper);
a3e6e81e
NC
139 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
140 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
3d76853f 141 }
3d76853f
NC
142}
143
e1a479c5
BB
144struct mro_meta*
145Perl_mro_meta_init(pTHX_ HV* stash)
146{
9fe4aecf 147 struct mro_meta* newmeta;
e1a479c5 148
7918f24d 149 PERL_ARGS_ASSERT_MRO_META_INIT;
dc3bf405 150 PERL_UNUSED_CONTEXT;
e1a479c5
BB
151 assert(HvAUX(stash));
152 assert(!(HvAUX(stash)->xhv_mro_meta));
183086be 153 Newxz(newmeta, 1, struct mro_meta);
9fe4aecf 154 HvAUX(stash)->xhv_mro_meta = newmeta;
dd69841b 155 newmeta->cache_gen = 1;
70cd14a1 156 newmeta->pkg_gen = 1;
a3e6e81e 157 newmeta->mro_which = &dfs_alg;
e1a479c5
BB
158
159 return newmeta;
160}
161
162#if defined(USE_ITHREADS)
163
164/* for sv_dup on new threads */
165struct mro_meta*
166Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
167{
e1a479c5
BB
168 struct mro_meta* newmeta;
169
7918f24d 170 PERL_ARGS_ASSERT_MRO_META_DUP;
e1a479c5 171
33e12d9d
NC
172 Newx(newmeta, 1, struct mro_meta);
173 Copy(smeta, newmeta, 1, struct mro_meta);
174
9953ff72
NC
175 if (newmeta->mro_linear_all) {
176 newmeta->mro_linear_all
a09252eb 177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
553e831a
NC
178 /* This is just acting as a shortcut pointer, and will be automatically
179 updated on the first get. */
3a6fa573
NC
180 newmeta->mro_linear_current = NULL;
181 } else if (newmeta->mro_linear_current) {
553e831a 182 /* Only the current MRO is stored, so this owns the data. */
3a6fa573 183 newmeta->mro_linear_current
a09252eb 184 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
553e831a
NC
185 }
186
33e12d9d
NC
187 if (newmeta->mro_nextmethod)
188 newmeta->mro_nextmethod
a09252eb 189 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
a49ba3fc
NC
190 if (newmeta->isa)
191 newmeta->isa
a09252eb 192 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
e1a479c5 193
1a33a059
FC
194 newmeta->super = NULL;
195
ac3b837b
TC
196 /* clear the destructor cache */
197 newmeta->destroy = NULL;
198 newmeta->destroy_gen = 0;
199
e1a479c5
BB
200 return newmeta;
201}
202
203#endif /* USE_ITHREADS */
204
205/*
206=for apidoc mro_get_linear_isa_dfs
207
796b6530 208Returns the Depth-First Search linearization of C<@ISA>
e1a479c5
BB
209the given stash. The return value is a read-only AV*.
210C<level> should be 0 (it is used internally in this
211function's recursion).
212
1c908217
RGS
213You are responsible for C<SvREFCNT_inc()> on the
214return value if you plan to store it anywhere
215semi-permanently (otherwise it might be deleted
216out from under you the next time the cache is
217invalidated).
218
e1a479c5
BB
219=cut
220*/
4befac30 221static AV*
94d1e706 222S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
e1a479c5
BB
223{
224 AV* retval;
225 GV** gvp;
226 GV* gv;
227 AV* av;
190d0b22 228 const HEK* stashhek;
e1a479c5 229 struct mro_meta* meta;
a49ba3fc 230 SV *our_name;
73519bd0 231 HV *stored = NULL;
e1a479c5 232
7918f24d 233 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
e1a479c5
BB
234 assert(HvAUX(stash));
235
00169e2c 236 stashhek
15d9236d 237 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
00169e2c
FC
238 ? HvENAME_HEK_NN(stash)
239 : HvNAME_HEK(stash);
240
190d0b22 241 if (!stashhek)
1e05feb3 242 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
243
244 if (level > 100)
d0c0e7dd 245 Perl_croak(aTHX_
147e3846 246 "Recursive inheritance detected in package '%" HEKf "'",
d0c0e7dd 247 HEKfARG(stashhek));
e1a479c5
BB
248
249 meta = HvMROMETA(stash);
1c908217
RGS
250
251 /* return cache if valid */
a3e6e81e 252 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
e1a479c5
BB
253 return retval;
254 }
255
256 /* not in cache, make a new one */
1c908217 257
ad64d0ec 258 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
a49ba3fc
NC
259 /* We use this later in this function, but don't need a reference to it
260 beyond the end of this function, so reference count is fine. */
261 our_name = newSVhek(stashhek);
262 av_push(retval, our_name); /* add ourselves at the top */
e1a479c5 263
1c908217 264 /* fetch our @ISA */
e1a479c5
BB
265 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
266 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
267
a49ba3fc
NC
268 /* "stored" is used to keep track of all of the classnames we have added to
269 the MRO so far, so we can do a quick exists check and avoid adding
270 duplicate classnames to the MRO as we go.
271 It's then retained to be re-used as a fast lookup for ->isa(), by adding
272 our own name and "UNIVERSAL" to it. */
273
a49ba3fc 274 if(av && AvFILLp(av) >= 0) {
1c908217 275
ffd8da72
NC
276 SV **svp = AvARRAY(av);
277 I32 items = AvFILLp(av) + 1;
1c908217
RGS
278
279 /* foreach(@ISA) */
e1a479c5 280 while (items--) {
3df5c4b5 281 SV* const sv = *svp ? *svp : &PL_sv_undef;
e1a479c5 282 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
283 SV *const *subrv_p;
284 I32 subrv_items;
3df5c4b5 285 svp++;
e1a479c5
BB
286
287 if (!basestash) {
1c908217
RGS
288 /* if no stash exists for this @ISA member,
289 simply add it to the MRO and move on */
ffd8da72
NC
290 subrv_p = &sv;
291 subrv_items = 1;
e1a479c5
BB
292 }
293 else {
1c908217 294 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
295 of this @ISA member, and append their MRO to ours.
296 The recursive call could throw an exception, which
297 has memory management implications here, hence the use of
298 the mortal. */
ffd8da72
NC
299 const AV *const subrv
300 = mro_get_linear_isa_dfs(basestash, level + 1);
301
302 subrv_p = AvARRAY(subrv);
303 subrv_items = AvFILLp(subrv) + 1;
304 }
73519bd0
NC
305 if (stored) {
306 while(subrv_items--) {
307 SV *const subsv = *subrv_p++;
308 /* LVALUE fetch will create a new undefined SV if necessary
309 */
310 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
311 assert(he);
312 if(HeVAL(he) != &PL_sv_undef) {
313 /* It was newly created. Steal it for our new SV, and
314 replace it in the hash with the "real" thing. */
315 SV *const val = HeVAL(he);
316 HEK *const key = HeKEY_hek(he);
317
318 HeVAL(he) = &PL_sv_undef;
b69f5762 319 sv_sethek(val, key);
73519bd0
NC
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())));
4d00dfae 351 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef);
73519bd0
NC
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())));
4d00dfae 361 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef);
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));
4d00dfae 456 (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef);
7311f41d
FC
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)
796b6530 470when the C<@ISA> of the given package has changed. Invoked
e1a479c5
BB
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 491{
e1a479c5
BB
492 HV* isarev;
493 AV* linear_mro;
494 HE* iter;
495 SV** svp;
496 I32 items;
1e05feb3 497 bool is_universal;
4df35a07 498 struct mro_meta * meta;
80ebaca2 499 HV *isa = NULL;
e1a479c5 500
3386c920 501 const HEK * const stashhek = HvENAME_HEK(stash);
4df35a07
FC
502 const char * const stashname = HvENAME_get(stash);
503 const STRLEN stashname_len = HvENAMELEN_get(stash);
504
505 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
7918f24d 506
2c7f4b87
BB
507 if(!stashname)
508 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
509
4df35a07
FC
510
511 /* wipe out the cached linearizations for this stash */
512 meta = HvMROMETA(stash);
f7afb547 513 CLEAR_LINEAR(meta);
4df35a07 514 if (meta->isa) {
80ebaca2
FC
515 /* Steal it for our own purposes. */
516 isa = (HV *)sv_2mortal((SV *)meta->isa);
5782d502 517 meta->isa = NULL;
6f86b615 518 }
70cd14a1 519
4df35a07
FC
520 /* Inc the package generation, since our @ISA changed */
521 meta->pkg_gen++;
522
e1a479c5
BB
523 /* Wipe the global method cache if this package
524 is UNIVERSAL or one of its parents */
dd69841b 525
3386c920 526 svp = hv_fetchhek(PL_isarev, stashhek, 0);
85fbaab2 527 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b 528
4d00dfae
YO
529 if((memEQs(stashname, stashname_len, "UNIVERSAL"))
530 || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
e1a479c5 531 PL_sub_generation++;
dd69841b
BB
532 is_universal = TRUE;
533 }
1e05feb3 534 else { /* Wipe the local method cache otherwise */
4df35a07 535 meta->cache_gen++;
1e05feb3
AL
536 is_universal = FALSE;
537 }
e1a479c5
BB
538
539 /* wipe next::method cache too */
4df35a07 540 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 541
9cbd5ca3
FC
542 /* Changes to @ISA might turn overloading on */
543 HvAMAGIC_on(stash);
3d147ac2
DM
544 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
545 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
9cbd5ca3 546
ac3b837b
TC
547 /* DESTROY can be cached in meta. */
548 meta->destroy_gen = 0;
8c34e50d 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. */
8b371338 632
80ebaca2 633 (void)
3386c920 634 hv_storehek(mroisarev, namehek, &PL_sv_yes);
80ebaca2
FC
635 }
636
316ebaf2
JH
637 if ((SV *)isa != &PL_sv_undef) {
638 assert(namehek);
80ebaca2
FC
639 mro_clean_isarev(
640 isa, HEK_KEY(namehek), HEK_LEN(namehek),
3386c920
FC
641 HvMROMETA(revstash)->isa, HEK_HASH(namehek),
642 HEK_UTF8(namehek)
80ebaca2 643 );
316ebaf2 644 }
80ebaca2 645 }
e1a479c5
BB
646 }
647 }
648
c9143745
FC
649 /* Now iterate our MRO (parents), adding ourselves and everything from
650 our isarev to their isarev.
1c908217
RGS
651 */
652
653 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
654 linear_mro = mro_get_linear_isa(stash);
655 svp = AvARRAY(linear_mro) + 1;
656 items = AvFILLp(linear_mro);
1c908217 657
e1a479c5
BB
658 while (items--) {
659 SV* const sv = *svp++;
e1a479c5
BB
660 HV* mroisarev;
661
117b69ca
NC
662 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
663
664 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
665 us, then will need to upgrade it to an HV (which sv_upgrade() can
666 now do for us. */
117b69ca 667
85fbaab2 668 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 669
ad64d0ec 670 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 671
25270bc0
NC
672 /* This hash only ever contains PL_sv_yes. Storing it over itself is
673 almost as cheap as calling hv_exists, so on aggregate we expect to
674 save time by not making two calls to the common HV code for the
675 case where it doesn't exist. */
8b371338 676
3386c920 677 (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
80ebaca2
FC
678 }
679
e1fa07e3 680 /* Delete our name from our former parents' isarevs. */
80ebaca2 681 if(isa && HvARRAY(isa))
204e6232 682 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
3386c920 683 HEK_HASH(stashhek), HEK_UTF8(stashhek));
80ebaca2
FC
684}
685
686/* Deletes name from all the isarev entries listed in isa */
687STATIC void
688S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
3386c920
FC
689 const STRLEN len, HV * const exceptions, U32 hash,
690 U32 flags)
80ebaca2
FC
691{
692 HE* iter;
e1a479c5 693
80ebaca2
FC
694 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
695
e1fa07e3 696 /* Delete our name from our former parents' isarevs. */
3dc78631 697 if(HvARRAY(isa) && hv_iterinit(isa)) {
80ebaca2
FC
698 SV **svp;
699 while((iter = hv_iternext(isa))) {
700 I32 klen;
701 const char * const key = hv_iterkey(iter, &klen);
204e6232
BF
702 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
703 continue;
704 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
80ebaca2
FC
705 if(svp) {
706 HV * const isarev = (HV *)*svp;
3386c920
FC
707 (void)hv_common(isarev, NULL, name, len, flags,
708 G_DISCARD|HV_DELETE, NULL, hash);
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 721another spot in the stash hierarchy. C<stash> is the stash that has been
154e47c8 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)) ||
3386c920 777 !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
d7879cf0
FC
778 *svp != (SV *)gv
779 ) return;
780 }
781 assert(SvOOK(GvSTASH(gv)));
1f656fcf 782 assert(GvNAMELEN(gv));
d7879cf0 783 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
1f656fcf 784 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
d7879cf0
FC
785 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
786 if (!name_count) {
787 name_count = 1;
15d9236d 788 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
d7879cf0
FC
789 }
790 else {
15d9236d 791 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
d7879cf0
FC
792 if (name_count < 0) ++namep, name_count = -name_count - 1;
793 }
794 if (name_count == 1) {
b59bf0b2 795 if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) {
1f656fcf
FC
796 namesv = GvNAMELEN(gv) == 1
797 ? newSVpvs_flags(":", SVs_TEMP)
798 : newSVpvs_flags("", SVs_TEMP);
d7879cf0
FC
799 }
800 else {
801 namesv = sv_2mortal(newSVhek(*namep));
1f656fcf
FC
802 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
803 else sv_catpvs(namesv, "::");
d7879cf0 804 }
204e6232 805 if (GvNAMELEN(gv) != 1) {
c682ebef
FC
806 sv_catpvn_flags(
807 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
d7879cf0 808 /* skip trailing :: */
c682ebef
FC
809 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
810 );
204e6232 811 }
d7879cf0
FC
812 }
813 else {
814 SV *aname;
815 namesv = sv_2mortal((SV *)newAV());
816 while (name_count--) {
b59bf0b2 817 if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){
1f656fcf
FC
818 aname = GvNAMELEN(gv) == 1
819 ? newSVpvs(":")
820 : newSVpvs("");
821 namep++;
d7879cf0
FC
822 }
823 else {
824 aname = newSVhek(*namep++);
1f656fcf
FC
825 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
826 else sv_catpvs(aname, "::");
d7879cf0 827 }
204e6232 828 if (GvNAMELEN(gv) != 1) {
c682ebef
FC
829 sv_catpvn_flags(
830 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
d7879cf0 831 /* skip trailing :: */
c682ebef
FC
832 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
833 );
204e6232 834 }
d7879cf0
FC
835 av_push((AV *)namesv, aname);
836 }
837 }
c8bbf675 838
80ebaca2
FC
839 /* Get a list of all the affected classes. */
840 /* We cannot simply pass them all to mro_isa_changed_in to avoid
841 the list, as that function assumes that only one package has
842 changed. It does not work with:
843
844 @foo::ISA = qw( B B::B );
845 *B:: = delete $::{"A::"};
846
847 as neither B nor B::B can be updated before the other, since they
848 will reset caches on foo, which will see either B or B::B with the
849 wrong name. The names must be set on *all* affected stashes before
beeda143 850 we do anything else. (And linearisations must be cleared, too.)
80ebaca2
FC
851 */
852 stashes = (HV *) sv_2mortal((SV *)newHV());
b89cdb22
FC
853 mro_gather_and_rename(
854 stashes, (HV *) sv_2mortal((SV *)newHV()),
d7879cf0 855 stash, oldstash, namesv
b89cdb22 856 );
80ebaca2 857
80ebaca2
FC
858 /* Once the caches have been wiped on all the classes, call
859 mro_isa_changed_in on each. */
860 hv_iterinit(stashes);
861 while((iter = hv_iternext(stashes))) {
35bc1e35
JK
862 HV * const this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
863 if(HvENAME(this_stash)) {
90ba1f34
FC
864 /* We have to restore the original meta->isa (that
865 mro_gather_and_rename set aside for us) this way, in case
866 one class in this list is a superclass of a another class
867 that we have already encountered. In such a case, meta->isa
38a04ca0 868 will have been overwritten without old entries being deleted
90ba1f34 869 from PL_isarev. */
35bc1e35 870 struct mro_meta * const meta = HvMROMETA(this_stash);
90ba1f34
FC
871 if(meta->isa != (HV *)HeVAL(iter)){
872 SvREFCNT_dec(meta->isa);
873 meta->isa
874 = HeVAL(iter) == &PL_sv_yes
875 ? NULL
876 : (HV *)HeVAL(iter);
877 HeVAL(iter) = NULL; /* We donated our reference count. */
878 }
35bc1e35 879 mro_isa_changed_in(this_stash);
90ba1f34 880 }
80ebaca2
FC
881 }
882}
883
aeba7c97 884STATIC void
b89cdb22 885S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
d7879cf0 886 HV *stash, HV *oldstash, SV *namesv)
80ebaca2 887{
eb578fdb
KW
888 XPVHV* xhv;
889 HE *entry;
80ebaca2 890 I32 riter = -1;
4c916935 891 I32 items = 0;
80ebaca2 892 const bool stash_had_name = stash && HvENAME(stash);
d7879cf0 893 bool fetched_isarev = FALSE;
80ebaca2
FC
894 HV *seen = NULL;
895 HV *isarev = NULL;
d7879cf0 896 SV **svp = NULL;
80ebaca2
FC
897
898 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
899
b89cdb22
FC
900 /* We use the seen_stashes hash to keep track of which packages have
901 been encountered so far. This must be separate from the main list of
902 stashes, as we need to distinguish between stashes being assigned
903 and stashes being replaced/deleted. (A nested stash can be on both
904 sides of an assignment. We cannot simply skip iterating through a
905 stash on the right if we have seen it on the left, as it will not
906 get its ename assigned to it.)
907
908 To avoid allocating extra SVs, instead of a bitfield we can make
909 bizarre use of immortals:
910
911 &PL_sv_undef: seen on the left (oldstash)
912 &PL_sv_no : seen on the right (stash)
913 &PL_sv_yes : seen on both sides
914
915 */
916
80ebaca2
FC
917 if(oldstash) {
918 /* Add to the big list. */
90ba1f34 919 struct mro_meta * meta;
80ebaca2
FC
920 HE * const entry
921 = (HE *)
922 hv_common(
b89cdb22 923 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
df5f182b 924 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2 925 );
b89cdb22 926 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
80ebaca2
FC
927 oldstash = NULL;
928 goto check_stash;
929 }
b89cdb22
FC
930 HeVAL(entry)
931 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
90ba1f34 932 meta = HvMROMETA(oldstash);
b89cdb22
FC
933 (void)
934 hv_store(
935 stashes, (const char *)&oldstash, sizeof(HV *),
90ba1f34
FC
936 meta->isa
937 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
938 : &PL_sv_yes,
939 0
b89cdb22 940 );
beeda143 941 CLEAR_LINEAR(meta);
80ebaca2
FC
942
943 /* Update the effective name. */
944 if(HvENAME_get(oldstash)) {
d7879cf0
FC
945 const HEK * const enamehek = HvENAME_HEK(oldstash);
946 if(SvTYPE(namesv) == SVt_PVAV) {
947 items = AvFILLp((AV *)namesv) + 1;
948 svp = AvARRAY((AV *)namesv);
949 }
950 else {
951 items = 1;
952 svp = &namesv;
953 }
954 while (items--) {
204e6232 955 const U32 name_utf8 = SvUTF8(*svp);
d7879cf0 956 STRLEN len;
103f5a36
NC
957 const char *name = SvPVx_const(*svp, len);
958 if(PL_stashcache) {
147e3846 959 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%" SVf "'\n",
c1f6cd39 960 SVfARG(*svp)));
c60dbbc3 961 (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
103f5a36
NC
962 }
963 ++svp;
204e6232 964 hv_ename_delete(oldstash, name, len, name_utf8);
d7879cf0
FC
965
966 if (!fetched_isarev) {
967 /* If the name deletion caused a name change, then we
968 * are not going to call mro_isa_changed_in with this
969 * name (and not at all if it has become anonymous) so
970 * we need to delete old isarev entries here, both
e1fa07e3 971 * those in the superclasses and this class's own list
d7879cf0
FC
972 * of subclasses. We simply delete the latter from
973 * PL_isarev, since we still need it. hv_delete morti-
974 * fies it for us, so sv_2mortal is not necessary. */
975 if(HvENAME_HEK(oldstash) != enamehek) {
976 if(meta->isa && HvARRAY(meta->isa))
3386c920
FC
977 mro_clean_isarev(meta->isa, name, len, 0, 0,
978 name_utf8 ? HVhek_UTF8 : 0);
204e6232 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 */
3386c920 1064 const HEK * const hvename = HvENAME_HEK(oldstash);
d7879cf0 1065 fetched_isarev = TRUE;
3386c920 1066 svp = hv_fetchhek(PL_isarev, hvename, 0);
d7879cf0
FC
1067 if (svp) isarev = MUTABLE_HV(*svp);
1068 }
1069 else if(SvTYPE(namesv) == SVt_PVAV) {
1070 items = AvFILLp((AV *)namesv) + 1;
1071 svp = AvARRAY((AV *)namesv);
1072 }
1073 else {
1074 items = 1;
1075 svp = &namesv;
1076 }
1077 }
80ebaca2 1078 if(
d7879cf0 1079 isarev || !fetched_isarev
80ebaca2 1080 ) {
d7879cf0 1081 while (fetched_isarev || items--) {
80ebaca2 1082 HE *iter;
d7879cf0
FC
1083
1084 if (!fetched_isarev) {
1085 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1086 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1087 }
1088
80ebaca2
FC
1089 hv_iterinit(isarev);
1090 while((iter = hv_iternext(isarev))) {
204e6232 1091 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
90ba1f34 1092 struct mro_meta * meta;
80ebaca2
FC
1093
1094 if(!revstash) continue;
90ba1f34 1095 meta = HvMROMETA(revstash);
b89cdb22
FC
1096 (void)
1097 hv_store(
1098 stashes, (const char *)&revstash, sizeof(HV *),
90ba1f34
FC
1099 meta->isa
1100 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1101 : &PL_sv_yes,
1102 0
b89cdb22 1103 );
beeda143 1104 CLEAR_LINEAR(meta);
80ebaca2 1105 }
d7879cf0
FC
1106
1107 if (fetched_isarev) break;
1108 }
80ebaca2 1109 }
d056e33c 1110
c8bbf675
FC
1111 /* This is partly based on code in hv_iternext_flags. We are not call-
1112 ing that here, as we want to avoid resetting the hash iterator. */
1113
d056e33c 1114 /* Skip the entire loop if the hash is empty. */
8b371338 1115 if(oldstash && HvUSEDKEYS(oldstash)) {
d056e33c 1116 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 1117 seen = (HV *) sv_2mortal((SV *)newHV());
d056e33c 1118
80ebaca2
FC
1119 /* Iterate through entries in the oldstash, adding them to the
1120 list, meanwhile doing the equivalent of $seen{$key} = 1.
d056e33c
FC
1121 */
1122
1123 while (++riter <= (I32)xhv->xhv_max) {
1124 entry = (HvARRAY(oldstash))[riter];
1125
1126 /* Iterate through the entries in this list */
1127 for(; entry; entry = HeNEXT(entry)) {
1128 const char* key;
090c3c37 1129 I32 len;
d056e33c
FC
1130
1131 /* If this entry is not a glob, ignore it.
1132 Try the next. */
1133 if (!isGV(HeVAL(entry))) continue;
1134
090c3c37 1135 key = hv_iterkey(entry, &len);
1f656fcf
FC
1136 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1137 || (len == 1 && key[0] == ':')) {
d056e33c
FC
1138 HV * const oldsubstash = GvHV(HeVAL(entry));
1139 SV ** const stashentry
090c3c37 1140 = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
35759254 1141 HV *substash = NULL;
62c1e33f
FC
1142
1143 /* Avoid main::main::main::... */
1144 if(oldsubstash == oldstash) continue;
1145
d056e33c 1146 if(
35759254 1147 (
3d8812a2 1148 stashentry && *stashentry && isGV(*stashentry)
35759254
FC
1149 && (substash = GvHV(*stashentry))
1150 )
00169e2c 1151 || (oldsubstash && HvENAME_get(oldsubstash))
d056e33c 1152 )
35759254
FC
1153 {
1154 /* Add :: and the key (minus the trailing ::)
d7879cf0
FC
1155 to each name. */
1156 SV *subname;
1157 if(SvTYPE(namesv) == SVt_PVAV) {
1158 SV *aname;
1159 items = AvFILLp((AV *)namesv) + 1;
1160 svp = AvARRAY((AV *)namesv);
1161 subname = sv_2mortal((SV *)newAV());
1162 while (items--) {
1163 aname = newSVsv(*svp++);
1f656fcf
FC
1164 if (len == 1)
1165 sv_catpvs(aname, ":");
1166 else {
1167 sv_catpvs(aname, "::");
c682ebef
FC
1168 sv_catpvn_flags(
1169 aname, key, len-2,
090c3c37 1170 HeUTF8(entry)
c682ebef
FC
1171 ? SV_CATUTF8 : SV_CATBYTES
1172 );
1f656fcf 1173 }
d7879cf0
FC
1174 av_push((AV *)subname, aname);
1175 }
80ebaca2 1176 }
d7879cf0
FC
1177 else {
1178 subname = sv_2mortal(newSVsv(namesv));
1f656fcf
FC
1179 if (len == 1) sv_catpvs(subname, ":");
1180 else {
1181 sv_catpvs(subname, "::");
c682ebef
FC
1182 sv_catpvn_flags(
1183 subname, key, len-2,
090c3c37 1184 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
c682ebef 1185 );
1f656fcf 1186 }
d7879cf0
FC
1187 }
1188 mro_gather_and_rename(
1189 stashes, seen_stashes,
1190 substash, oldsubstash, subname
1191 );
35759254 1192 }
d056e33c 1193
090c3c37 1194 (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
d056e33c
FC
1195 }
1196 }
1197 }
1198 }
c8bbf675
FC
1199
1200 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
1201 if (stash && HvUSEDKEYS(stash)) {
1202 xhv = (XPVHV*)SvANY(stash);
b89cdb22 1203 riter = -1;
d056e33c
FC
1204
1205 /* Iterate through the new stash, skipping $seen{$key} items,
b89cdb22 1206 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
c8bbf675
FC
1207 while (++riter <= (I32)xhv->xhv_max) {
1208 entry = (HvARRAY(stash))[riter];
1209
1210 /* Iterate through the entries in this list */
1211 for(; entry; entry = HeNEXT(entry)) {
1212 const char* key;
090c3c37 1213 I32 len;
c8bbf675
FC
1214
1215 /* If this entry is not a glob, ignore it.
1216 Try the next. */
1217 if (!isGV(HeVAL(entry))) continue;
1218
090c3c37 1219 key = hv_iterkey(entry, &len);
1f656fcf
FC
1220 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1221 || (len == 1 && key[0] == ':')) {
d056e33c
FC
1222 HV *substash;
1223
1224 /* If this entry was seen when we iterated through the
1225 oldstash, skip it. */
090c3c37 1226 if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
d056e33c
FC
1227
1228 /* We get here only if this stash has no corresponding
1229 entry in the stash being replaced. */
1230
1231 substash = GvHV(HeVAL(entry));
35759254 1232 if(substash) {
d7879cf0 1233 SV *subname;
62c1e33f
FC
1234
1235 /* Avoid checking main::main::main::... */
1236 if(substash == stash) continue;
1237
d056e33c 1238 /* Add :: and the key (minus the trailing ::)
d7879cf0
FC
1239 to each name. */
1240 if(SvTYPE(namesv) == SVt_PVAV) {
1241 SV *aname;
1242 items = AvFILLp((AV *)namesv) + 1;
1243 svp = AvARRAY((AV *)namesv);
1244 subname = sv_2mortal((SV *)newAV());
1245 while (items--) {
1246 aname = newSVsv(*svp++);
1f656fcf
FC
1247 if (len == 1)
1248 sv_catpvs(aname, ":");
1249 else {
1250 sv_catpvs(aname, "::");
c682ebef
FC
1251 sv_catpvn_flags(
1252 aname, key, len-2,
090c3c37 1253 HeUTF8(entry)
c682ebef
FC
1254 ? SV_CATUTF8 : SV_CATBYTES
1255 );
1f656fcf 1256 }
d7879cf0
FC
1257 av_push((AV *)subname, aname);
1258 }
1259 }
1260 else {
1261 subname = sv_2mortal(newSVsv(namesv));
1f656fcf
FC
1262 if (len == 1) sv_catpvs(subname, ":");
1263 else {
1264 sv_catpvs(subname, "::");
c682ebef
FC
1265 sv_catpvn_flags(
1266 subname, key, len-2,
090c3c37 1267 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
c682ebef 1268 );
1f656fcf 1269 }
d7879cf0 1270 }
80ebaca2 1271 mro_gather_and_rename(
b89cdb22 1272 stashes, seen_stashes,
d7879cf0 1273 substash, NULL, subname
d056e33c
FC
1274 );
1275 }
c8bbf675
FC
1276 }
1277 }
1278 }
1279 }
1280}
1281
1282/*
e1a479c5
BB
1283=for apidoc mro_method_changed_in
1284
47c9dd14
BB
1285Invalidates method caching on any child classes
1286of the given stash, so that they might notice
1287the changes in this one.
e1a479c5
BB
1288
1289Ideally, all instances of C<PL_sub_generation++> in
25d585df 1290perl source outside of F<mro.c> should be
dd69841b
BB
1291replaced by calls to this.
1292
1293Perl automatically handles most of the common
1294ways a method might be redefined. However, there
1295are a few ways you could change a method in a stash
1296without the cache code noticing, in which case you
1297need to call this method afterwards:
e1a479c5 1298
dd69841b
BB
12991) Directly manipulating the stash HV entries from
1300XS code.
e1a479c5 1301
dd69841b
BB
13022) Assigning a reference to a readonly scalar
1303constant into a stash entry in order to create
75af9d73 1304a constant subroutine (like F<constant.pm>
dd69841b
BB
1305does).
1306
1307This same method is available from pure perl
1308via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
1309
1310=cut
1311*/
1312void
1313Perl_mro_method_changed_in(pTHX_ HV *stash)
1314{
00169e2c
FC
1315 const char * const stashname = HvENAME_get(stash);
1316 const STRLEN stashname_len = HvENAMELEN_get(stash);
dd69841b 1317
3386c920 1318 SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
85fbaab2 1319 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 1320
7918f24d
NC
1321 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1322
2c7f4b87
BB
1323 if(!stashname)
1324 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1325
70cd14a1
CB
1326 /* Inc the package generation, since a local method changed */
1327 HvMROMETA(stash)->pkg_gen++;
1328
ac3b837b
TC
1329 /* DESTROY can be cached in meta */
1330 HvMROMETA(stash)->destroy_gen = 0;
8c34e50d 1331
e1a479c5
BB
1332 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1333 invalidate all method caches globally */
4d00dfae
YO
1334 if((memEQs(stashname, stashname_len, "UNIVERSAL"))
1335 || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
e1a479c5
BB
1336 PL_sub_generation++;
1337 return;
1338 }
1339
1340 /* else, invalidate the method caches of all child classes,
1341 but not itself */
dd69841b 1342 if(isarev) {
1e05feb3
AL
1343 HE* iter;
1344
e1a479c5
BB
1345 hv_iterinit(isarev);
1346 while((iter = hv_iternext(isarev))) {
204e6232 1347 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
bc2cbbac
BB
1348 struct mro_meta* mrometa;
1349
1350 if(!revstash) continue;
1351 mrometa = HvMROMETA(revstash);
dd69841b 1352 mrometa->cache_gen++;
e1a479c5
BB
1353 if(mrometa->mro_nextmethod)
1354 hv_clear(mrometa->mro_nextmethod);
ac3b837b 1355 mrometa->destroy_gen = 0;
e1a479c5
BB
1356 }
1357 }
234df27b
FC
1358
1359 /* The method change may be due to *{$package . "::()"} = \&nil; in
1360 overload.pm. */
1361 HvAMAGIC_on(stash);
3d147ac2
DM
1362 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
1363 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
e1a479c5
BB
1364}
1365
31b9005d
NC
1366void
1367Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1368{
1369 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
8b371338 1370
31b9005d
NC
1371 PERL_ARGS_ASSERT_MRO_SET_MRO;
1372
1373 if (!which)
147e3846 1374 Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", name);
31b9005d
NC
1375
1376 if(meta->mro_which != which) {
9953ff72 1377 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
1378 /* If we were storing something directly, put it in the hash before
1379 we lose it. */
8b371338 1380 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 1381 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
1382 }
1383 meta->mro_which = which;
1384 /* Scrub our cached pointer to the private data. */
3a6fa573 1385 meta->mro_linear_current = NULL;
31b9005d
NC
1386 /* Only affects local method cache, not
1387 even child classes */
1388 meta->cache_gen++;
1389 if(meta->mro_nextmethod)
1390 hv_clear(meta->mro_nextmethod);
1391 }
1392}
1393
e1a479c5
BB
1394#include "XSUB.h"
1395
e1a479c5 1396XS(XS_mro_method_changed_in);
e1a479c5
BB
1397
1398void
1399Perl_boot_core_mro(pTHX)
1400{
e1a479c5
BB
1401 static const char file[] = __FILE__;
1402
a3e6e81e 1403 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 1404
e1a479c5 1405 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
1406}
1407
e1a479c5
BB
1408XS(XS_mro_method_changed_in)
1409{
e1a479c5
BB
1410 dXSARGS;
1411 SV* classname;
1412 HV* class_stash;
1413
e1a479c5 1414 if(items != 1)
afa74d42 1415 croak_xs_usage(cv, "classname");
8b371338 1416
e1a479c5
BB
1417 classname = ST(0);
1418
1419 class_stash = gv_stashsv(classname, 0);
147e3846 1420 if(!class_stash) Perl_croak(aTHX_ "No such class: '%" SVf "'!", SVfARG(classname));
e1a479c5
BB
1421
1422 mro_method_changed_in(class_stash);
1423
1424 XSRETURN_EMPTY;
1425}
1426
e1a479c5 1427/*
14d04a33 1428 * ex: set ts=8 sts=4 sw=4 et:
e1a479c5 1429 */