This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CGI.pm to CPAN version 3.50
[perl5.git] / mro.c
CommitLineData
e1a479c5
BB
1/* mro.c
2 *
3 * Copyright (c) 2007 Brandon L Black
1129b882 4 * Copyright (c) 2007, 2008 Larry Wall and others
e1a479c5
BB
5 *
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
8 *
9 */
10
11/*
4ac71550
TC
12 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
13 * You'll be last either way, Master Peregrin.'
14 *
15 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
cac98860
RGS
16 */
17
18/*
e1a479c5
BB
19=head1 MRO Functions
20
21These functions are related to the method resolution order of perl classes
22
23=cut
24*/
25
26#include "EXTERN.h"
4befac30 27#define PERL_IN_MRO_C
e1a479c5
BB
28#include "perl.h"
29
a3e6e81e
NC
30static const struct mro_alg dfs_alg =
31 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
3d76853f 32
fa60396f
NC
33SV *
34Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35 const struct mro_alg *const which)
36{
37 SV **data;
38 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
39
5844ac76
NC
40 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
41 which->name, which->length, which->kflags,
42 HV_FETCH_JUST_SV, NULL, which->hash);
fa60396f
NC
43 if (!data)
44 return NULL;
45
46 /* If we've been asked to look up the private data for the current MRO, then
47 cache it. */
48 if (smeta->mro_which == which)
3a6fa573 49 smeta->mro_linear_current = *data;
fa60396f
NC
50
51 return *data;
52}
53
54SV *
55Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56 const struct mro_alg *const which, SV *const data)
57{
58 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
59
9953ff72 60 if (!smeta->mro_linear_all) {
553e831a
NC
61 if (smeta->mro_which == which) {
62 /* If all we need to store is the current MRO's data, then don't use
63 memory on a hash with 1 element - store it direct, and signal
64 this by leaving the would-be-hash NULL. */
3a6fa573 65 smeta->mro_linear_current = data;
553e831a
NC
66 return data;
67 } else {
68 HV *const hv = newHV();
69 /* Start with 2 buckets. It's unlikely we'll need more. */
70 HvMAX(hv) = 1;
9953ff72 71 smeta->mro_linear_all = hv;
553e831a 72
3a6fa573 73 if (smeta->mro_linear_current) {
553e831a
NC
74 /* If we were storing something directly, put it in the hash
75 before we lose it. */
76 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
3a6fa573 77 smeta->mro_linear_current);
553e831a
NC
78 }
79 }
80 }
81
82 /* We get here if we're storing more than one linearisation for this stash,
83 or the linearisation we are storing is not that if its current MRO. */
84
85 if (smeta->mro_which == which) {
86 /* If we've been asked to store the private data for the current MRO,
87 then cache it. */
3a6fa573 88 smeta->mro_linear_current = data;
fa60396f
NC
89 }
90
9953ff72 91 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
fa60396f
NC
92 which->name, which->length, which->kflags,
93 HV_FETCH_ISSTORE, data, which->hash)) {
94 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
95 "for '%.*s' %d", (int) which->length, which->name,
96 which->kflags);
97 }
98
99 return data;
100}
101
a3e6e81e
NC
102const struct mro_alg *
103Perl_mro_get_from_name(pTHX_ SV *name) {
104 SV **data;
105
106 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
107
5844ac76
NC
108 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109 HV_FETCH_JUST_SV, NULL, 0);
a3e6e81e
NC
110 if (!data)
111 return NULL;
112 assert(SvTYPE(*data) == SVt_IV);
113 assert(SvIOK(*data));
114 return INT2PTR(const struct mro_alg *, SvUVX(*data));
115}
116
117void
118Perl_mro_register(pTHX_ const struct mro_alg *mro) {
119 SV *wrapper = newSVuv(PTR2UV(mro));
120
121 PERL_ARGS_ASSERT_MRO_REGISTER;
122
123
124 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
125 mro->name, mro->length, mro->kflags,
126 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
127 SvREFCNT_dec(wrapper);
128 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
129 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
3d76853f 130 }
3d76853f
NC
131}
132
e1a479c5
BB
133struct mro_meta*
134Perl_mro_meta_init(pTHX_ HV* stash)
135{
9fe4aecf 136 struct mro_meta* newmeta;
e1a479c5 137
7918f24d 138 PERL_ARGS_ASSERT_MRO_META_INIT;
e1a479c5
BB
139 assert(HvAUX(stash));
140 assert(!(HvAUX(stash)->xhv_mro_meta));
183086be 141 Newxz(newmeta, 1, struct mro_meta);
9fe4aecf 142 HvAUX(stash)->xhv_mro_meta = newmeta;
dd69841b 143 newmeta->cache_gen = 1;
70cd14a1 144 newmeta->pkg_gen = 1;
a3e6e81e 145 newmeta->mro_which = &dfs_alg;
e1a479c5
BB
146
147 return newmeta;
148}
149
150#if defined(USE_ITHREADS)
151
152/* for sv_dup on new threads */
153struct mro_meta*
154Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
155{
e1a479c5
BB
156 struct mro_meta* newmeta;
157
7918f24d 158 PERL_ARGS_ASSERT_MRO_META_DUP;
e1a479c5 159
33e12d9d
NC
160 Newx(newmeta, 1, struct mro_meta);
161 Copy(smeta, newmeta, 1, struct mro_meta);
162
9953ff72
NC
163 if (newmeta->mro_linear_all) {
164 newmeta->mro_linear_all
a09252eb 165 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
553e831a
NC
166 /* This is just acting as a shortcut pointer, and will be automatically
167 updated on the first get. */
3a6fa573
NC
168 newmeta->mro_linear_current = NULL;
169 } else if (newmeta->mro_linear_current) {
553e831a 170 /* Only the current MRO is stored, so this owns the data. */
3a6fa573 171 newmeta->mro_linear_current
a09252eb 172 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
553e831a
NC
173 }
174
33e12d9d
NC
175 if (newmeta->mro_nextmethod)
176 newmeta->mro_nextmethod
a09252eb 177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
a49ba3fc
NC
178 if (newmeta->isa)
179 newmeta->isa
a09252eb 180 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
e1a479c5
BB
181
182 return newmeta;
183}
184
185#endif /* USE_ITHREADS */
186
187/*
188=for apidoc mro_get_linear_isa_dfs
189
190Returns the Depth-First Search linearization of @ISA
191the given stash. The return value is a read-only AV*.
192C<level> should be 0 (it is used internally in this
193function's recursion).
194
1c908217
RGS
195You are responsible for C<SvREFCNT_inc()> on the
196return value if you plan to store it anywhere
197semi-permanently (otherwise it might be deleted
198out from under you the next time the cache is
199invalidated).
200
e1a479c5
BB
201=cut
202*/
4befac30 203static AV*
94d1e706 204S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
e1a479c5
BB
205{
206 AV* retval;
207 GV** gvp;
208 GV* gv;
209 AV* av;
190d0b22 210 const HEK* stashhek;
e1a479c5 211 struct mro_meta* meta;
a49ba3fc 212 SV *our_name;
73519bd0 213 HV *stored = NULL;
e1a479c5 214
7918f24d 215 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
e1a479c5
BB
216 assert(HvAUX(stash));
217
00169e2c
FC
218 stashhek
219 = HvAUX(stash)->xhv_name && HvENAME_HEK_NN(stash)
220 ? HvENAME_HEK_NN(stash)
221 : HvNAME_HEK(stash);
222
190d0b22 223 if (!stashhek)
1e05feb3 224 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
225
226 if (level > 100)
227 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 228 HEK_KEY(stashhek));
e1a479c5
BB
229
230 meta = HvMROMETA(stash);
1c908217
RGS
231
232 /* return cache if valid */
a3e6e81e 233 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
e1a479c5
BB
234 return retval;
235 }
236
237 /* not in cache, make a new one */
1c908217 238
ad64d0ec 239 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
a49ba3fc
NC
240 /* We use this later in this function, but don't need a reference to it
241 beyond the end of this function, so reference count is fine. */
242 our_name = newSVhek(stashhek);
243 av_push(retval, our_name); /* add ourselves at the top */
e1a479c5 244
1c908217 245 /* fetch our @ISA */
e1a479c5
BB
246 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
247 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
248
a49ba3fc
NC
249 /* "stored" is used to keep track of all of the classnames we have added to
250 the MRO so far, so we can do a quick exists check and avoid adding
251 duplicate classnames to the MRO as we go.
252 It's then retained to be re-used as a fast lookup for ->isa(), by adding
253 our own name and "UNIVERSAL" to it. */
254
a49ba3fc 255 if(av && AvFILLp(av) >= 0) {
1c908217 256
ffd8da72
NC
257 SV **svp = AvARRAY(av);
258 I32 items = AvFILLp(av) + 1;
1c908217
RGS
259
260 /* foreach(@ISA) */
e1a479c5
BB
261 while (items--) {
262 SV* const sv = *svp++;
263 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
264 SV *const *subrv_p;
265 I32 subrv_items;
e1a479c5
BB
266
267 if (!basestash) {
1c908217
RGS
268 /* if no stash exists for this @ISA member,
269 simply add it to the MRO and move on */
ffd8da72
NC
270 subrv_p = &sv;
271 subrv_items = 1;
e1a479c5
BB
272 }
273 else {
1c908217 274 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
275 of this @ISA member, and append their MRO to ours.
276 The recursive call could throw an exception, which
277 has memory management implications here, hence the use of
278 the mortal. */
ffd8da72
NC
279 const AV *const subrv
280 = mro_get_linear_isa_dfs(basestash, level + 1);
281
282 subrv_p = AvARRAY(subrv);
283 subrv_items = AvFILLp(subrv) + 1;
284 }
73519bd0
NC
285 if (stored) {
286 while(subrv_items--) {
287 SV *const subsv = *subrv_p++;
288 /* LVALUE fetch will create a new undefined SV if necessary
289 */
290 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
291 assert(he);
292 if(HeVAL(he) != &PL_sv_undef) {
293 /* It was newly created. Steal it for our new SV, and
294 replace it in the hash with the "real" thing. */
295 SV *const val = HeVAL(he);
296 HEK *const key = HeKEY_hek(he);
297
298 HeVAL(he) = &PL_sv_undef;
299 /* Save copying by making a shared hash key scalar. We
300 inline this here rather than calling
301 Perl_newSVpvn_share because we already have the
302 scalar, and we already have the hash key. */
303 assert(SvTYPE(val) == SVt_NULL);
304 sv_upgrade(val, SVt_PV);
305 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
306 SvCUR_set(val, HEK_LEN(key));
307 SvREADONLY_on(val);
308 SvFAKE_on(val);
309 SvPOK_on(val);
310 if (HEK_UTF8(key))
311 SvUTF8_on(val);
312
313 av_push(retval, val);
314 }
ffd8da72 315 }
73519bd0
NC
316 } else {
317 /* We are the first (or only) parent. We can short cut the
318 complexity above, because our @ISA is simply us prepended
319 to our parent's @ISA, and our ->isa cache is simply our
320 parent's, with our name added. */
321 /* newSVsv() is slow. This code is only faster if we can avoid
322 it by ensuring that SVs in the arrays are shared hash key
323 scalar SVs, because we can "copy" them very efficiently.
324 Although to be fair, we can't *ensure* this, as a reference
325 to the internal array is returned by mro::get_linear_isa(),
326 so we'll have to be defensive just in case someone faffed
327 with it. */
328 if (basestash) {
329 SV **svp;
17eef65c 330 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
73519bd0
NC
331 av_extend(retval, subrv_items);
332 AvFILLp(retval) = subrv_items;
333 svp = AvARRAY(retval);
334 while(subrv_items--) {
335 SV *const val = *subrv_p++;
336 *++svp = SvIsCOW_shared_hash(val)
337 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
338 : newSVsv(val);
339 }
340 } else {
341 /* They have no stash. So create ourselves an ->isa cache
342 as if we'd copied it from what theirs should be. */
343 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
344 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
345 av_push(retval,
346 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
347 &PL_sv_undef, 0))));
348 }
349 }
e1a479c5 350 }
73519bd0
NC
351 } else {
352 /* We have no parents. */
353 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
354 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
e1a479c5
BB
355 }
356
ed09b296 357 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
ed09b296
NC
358
359 SvREFCNT_inc_simple_void_NN(stored);
360 SvTEMP_off(stored);
361 SvREADONLY_on(stored);
362
363 meta->isa = stored;
364
0fd7ece8
NC
365 /* now that we're past the exception dangers, grab our own reference to
366 the AV we're about to use for the result. The reference owned by the
367 mortals' stack will be released soon, so everything will balance. */
368 SvREFCNT_inc_simple_void_NN(retval);
369 SvTEMP_off(retval);
fdef73f9 370
1c908217
RGS
371 /* we don't want anyone modifying the cache entry but us,
372 and we do so by replacing it completely */
e1a479c5 373 SvREADONLY_on(retval);
1c908217 374
a3e6e81e 375 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
fa60396f 376 MUTABLE_SV(retval)));
e1a479c5
BB
377}
378
379/*
e1a479c5
BB
380=for apidoc mro_get_linear_isa
381
382Returns either C<mro_get_linear_isa_c3> or
383C<mro_get_linear_isa_dfs> for the given stash,
384dependant upon which MRO is in effect
385for that stash. The return value is a
386read-only AV*.
387
1c908217
RGS
388You are responsible for C<SvREFCNT_inc()> on the
389return value if you plan to store it anywhere
390semi-permanently (otherwise it might be deleted
391out from under you the next time the cache is
392invalidated).
393
e1a479c5
BB
394=cut
395*/
396AV*
397Perl_mro_get_linear_isa(pTHX_ HV *stash)
398{
399 struct mro_meta* meta;
7311f41d 400 AV *isa;
2c7f4b87 401
7918f24d 402 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
403 if(!SvOOK(stash))
404 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
405
406 meta = HvMROMETA(stash);
3d76853f 407 if (!meta->mro_which)
14f97ce6 408 Perl_croak(aTHX_ "panic: invalid MRO!");
7311f41d
FC
409 isa = meta->mro_which->resolve(aTHX_ stash, 0);
410
411 if (!meta->isa) {
412 HV *const isa_hash = newHV();
413 /* Linearisation didn't build it for us, so do it here. */
414 SV *const *svp = AvARRAY(isa);
415 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
416 const HEK *canon_name = HvENAME_HEK(stash);
417 if (!canon_name) canon_name = HvNAME_HEK(stash);
418
419 while (svp < svp_end) {
420 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
421 }
422
423 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
424 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
425 HV_FETCH_ISSTORE, &PL_sv_undef,
426 HEK_HASH(canon_name));
427 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
428
429 SvREADONLY_on(isa_hash);
430
431 meta->isa = isa_hash;
432 }
433
434 return isa;
e1a479c5
BB
435}
436
437/*
438=for apidoc mro_isa_changed_in
439
1c908217 440Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
441when the @ISA of the given package has changed. Invoked
442by the C<setisa> magic, should not need to invoke directly.
443
6f86b615
FC
444=for apidoc mro_isa_changed_in3
445
446Takes the necessary steps (cache invalidations, mostly)
447when the @ISA of the given package has changed. Invoked
448by the C<setisa> magic, should not need to invoke directly.
449
450The stash can be passed as the first argument, or its name and length as
451the second and third (or both). If just the name is passed and the stash
452does not exist, then only the subclasses' method and isa caches will be
453invalidated.
454
e1a479c5
BB
455=cut
456*/
457void
6f86b615
FC
458Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
459 STRLEN stashname_len)
e1a479c5
BB
460{
461 dVAR;
462 HV* isarev;
463 AV* linear_mro;
464 HE* iter;
465 SV** svp;
466 I32 items;
1e05feb3 467 bool is_universal;
6f86b615 468 struct mro_meta * meta = NULL;
e1a479c5 469
6f86b615 470 if(!stashname && stash) {
00169e2c
FC
471 stashname = HvENAME_get(stash);
472 stashname_len = HvENAMELEN_get(stash);
6f86b615
FC
473 }
474 else if(!stash)
475 stash = gv_stashpvn(stashname, stashname_len, 0 /* don't add */);
7918f24d 476
2c7f4b87
BB
477 if(!stashname)
478 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
479
6f86b615
FC
480 if(stash) {
481 /* wipe out the cached linearizations for this stash */
482 meta = HvMROMETA(stash);
483 if (meta->mro_linear_all) {
9953ff72
NC
484 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
485 meta->mro_linear_all = NULL;
553e831a 486 /* This is just acting as a shortcut pointer. */
3a6fa573 487 meta->mro_linear_current = NULL;
6f86b615 488 } else if (meta->mro_linear_current) {
553e831a 489 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
490 SvREFCNT_dec(meta->mro_linear_current);
491 meta->mro_linear_current = NULL;
6f86b615
FC
492 }
493 if (meta->isa) {
5782d502
NC
494 SvREFCNT_dec(meta->isa);
495 meta->isa = NULL;
6f86b615 496 }
e1a479c5 497
6f86b615
FC
498 /* Inc the package generation, since our @ISA changed */
499 meta->pkg_gen++;
500 }
70cd14a1 501
e1a479c5
BB
502 /* Wipe the global method cache if this package
503 is UNIVERSAL or one of its parents */
dd69841b
BB
504
505 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 506 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
507
508 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
509 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 510 PL_sub_generation++;
dd69841b
BB
511 is_universal = TRUE;
512 }
1e05feb3 513 else { /* Wipe the local method cache otherwise */
6f86b615 514 if(meta) meta->cache_gen++;
1e05feb3
AL
515 is_universal = FALSE;
516 }
e1a479c5
BB
517
518 /* wipe next::method cache too */
6f86b615 519 if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 520
e1a479c5 521 /* Iterate the isarev (classes that are our children),
1375cf1c 522 wiping out their linearization, method and isa caches */
dd69841b 523 if(isarev) {
e1a479c5
BB
524 hv_iterinit(isarev);
525 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
526 I32 len;
527 const char* const revkey = hv_iterkey(iter, &len);
528 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
529 struct mro_meta* revmeta;
530
531 if(!revstash) continue;
532 revmeta = HvMROMETA(revstash);
9953ff72
NC
533 if (revmeta->mro_linear_all) {
534 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
535 revmeta->mro_linear_all = NULL;
553e831a 536 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
537 revmeta->mro_linear_current = NULL;
538 } else if (revmeta->mro_linear_current) {
553e831a 539 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
540 SvREFCNT_dec(revmeta->mro_linear_current);
541 revmeta->mro_linear_current = NULL;
553e831a 542 }
dd69841b
BB
543 if(!is_universal)
544 revmeta->cache_gen++;
e1a479c5
BB
545 if(revmeta->mro_nextmethod)
546 hv_clear(revmeta->mro_nextmethod);
1375cf1c
NC
547 if (revmeta->isa) {
548 SvREFCNT_dec(revmeta->isa);
549 revmeta->isa = NULL;
550 }
e1a479c5
BB
551 }
552 }
553
1c908217
RGS
554 /* Now iterate our MRO (parents), and do a few things:
555 1) instantiate with the "fake" flag if they don't exist
556 2) flag them as universal if we are universal
557 3) Add everything from our isarev to their isarev
558 */
559
6f86b615
FC
560 /* This only applies if the stash exists. */
561 if(!stash) return;
562
1c908217 563 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
564 linear_mro = mro_get_linear_isa(stash);
565 svp = AvARRAY(linear_mro) + 1;
566 items = AvFILLp(linear_mro);
1c908217 567
e1a479c5
BB
568 while (items--) {
569 SV* const sv = *svp++;
e1a479c5
BB
570 HV* mroisarev;
571
117b69ca
NC
572 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
573
574 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
575 us, then will need to upgrade it to an HV (which sv_upgrade() can
576 now do for us. */
117b69ca 577
85fbaab2 578 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 579
ad64d0ec 580 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 581
25270bc0
NC
582 /* This hash only ever contains PL_sv_yes. Storing it over itself is
583 almost as cheap as calling hv_exists, so on aggregate we expect to
584 save time by not making two calls to the common HV code for the
585 case where it doesn't exist. */
586
04fe65b0 587 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
588
589 if(isarev) {
590 hv_iterinit(isarev);
591 while((iter = hv_iternext(isarev))) {
dd69841b 592 I32 revkeylen;
1e05feb3 593 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 594 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
595 }
596 }
597 }
598}
599
600/*
c8bbf675
FC
601=for apidoc mro_package_moved
602
d056e33c
FC
603Call this function to signal to a stash that it has been assigned to
604another spot in the stash hierarchy. C<stash> is the stash that has been
605assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
606that is actually being assigned to. C<newname> and C<newname_len> are the
607full name of the GV. If these last two arguments are omitted, they can be
35759254 608inferred from C<gv>. C<gv> can be omitted if C<newname> is given.
d056e33c 609
35759254 610This can also be called with a null first argument to
d056e33c
FC
611indicate that C<oldstash> has been deleted.
612
613This function invalidates isa caches on the old stash, on all subpackages
614nested inside it, and on the subclasses of all those, including
615non-existent packages that have corresponding entries in C<stash>.
c8bbf675
FC
616
617=cut
618*/
619void
35759254
FC
620Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
621 const GV *gv, const char *newname,
62c1e33f 622 I32 newname_len)
c8bbf675
FC
623{
624 register XPVHV* xhv;
625 register HE *entry;
626 I32 riter = -1;
d056e33c 627 HV *seen = NULL;
35759254 628 HV *seen_stashes = NULL;
8b9e80a3 629 const bool stash_had_name = stash && HvENAME(stash);
c8bbf675 630
35759254
FC
631 /* If newname_len is negative, then gv is actually the caller’s hash of
632 stashes that have been seen so far. */
62c1e33f 633
35759254
FC
634 assert(stash || oldstash);
635 assert((gv && newname_len >= 0) || newname);
636
637 if(newname_len < 0) seen_stashes = (HV *)gv, gv = NULL;
638
639 /* Determine the name of the location that stash was assigned to
640 * or from which oldstash was removed.
641 *
928eb066 642 * We cannot reliably use the name in oldstash, because it may have
35759254
FC
643 * been deleted from the location in the symbol table that its name
644 * suggests, as in this case:
645 *
646 * $globref = \*foo::bar::;
647 * Symbol::delete_package("foo");
648 * *$globref = \%baz::;
649 * *$globref = *frelp::;
650 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
651 *
652 * If newname is not null, then we trust that the caller gave us the
653 * right name. Otherwise, we get it from the gv. But if the gv is not
654 * in the symbol table, then we just return.
655 */
d056e33c
FC
656 if(!newname && gv) {
657 SV * const namesv = sv_newmortal();
62c1e33f 658 STRLEN len;
d056e33c 659 gv_fullname4(namesv, gv, NULL, 0);
35759254 660 if(gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv) return;
62c1e33f
FC
661 newname = SvPV_const(namesv, len);
662 newname_len = len - 2; /* skip trailing :: */
d056e33c 663 }
35759254 664 if(newname_len < 0) newname_len = -newname_len;
c8bbf675 665
d7fbb1de
FC
666 if(oldstash && HvENAME_get(oldstash)) {
667 if(PL_stashcache)
668 (void)
669 hv_delete(PL_stashcache, newname, newname_len, G_DISCARD);
670 hv_ename_delete(oldstash, newname, newname_len);
671 }
8b9e80a3
FC
672 if(stash) {
673 hv_ename_add(stash, newname, newname_len);
674
675 /* If this stash had been detached from the symbol table (so it
676 * had no HvENAME) before being assigned to spot whose name is in
677 * newname, then its isa cache would be stale (the effective name
678 * having changed), and subclasses of newname would then use that
679 * cache in the mro_isa_changed_in3(oldstash...) call below. (See
680 * [perl #77358].)
681 * If it did have a name, then its previous name is still
682 * used in isa caches, and there is no need for this call.
683 */
684 if(!stash_had_name) mro_isa_changed_in(stash);
685 }
d7fbb1de 686
d056e33c
FC
687 mro_isa_changed_in3((HV *)oldstash, newname, newname_len);
688
689 if(
690 (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
d7fbb1de 691 ) return;
c8bbf675
FC
692
693 /* This is partly based on code in hv_iternext_flags. We are not call-
694 ing that here, as we want to avoid resetting the hash iterator. */
695
d056e33c
FC
696 /* Skip the entire loop if the hash is empty. */
697 if(oldstash && HvUSEDKEYS(oldstash)) {
698 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 699 seen = (HV *) sv_2mortal((SV *)newHV());
35759254 700 if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
d056e33c
FC
701
702 /* Iterate through entries in the oldstash, calling
703 mro_package_moved(
704 corresponding_entry_in_new_stash, current_entry, ...
705 )
706 meanwhile doing the equivalent of $seen{$key} = 1.
707 */
708
709 while (++riter <= (I32)xhv->xhv_max) {
710 entry = (HvARRAY(oldstash))[riter];
711
712 /* Iterate through the entries in this list */
713 for(; entry; entry = HeNEXT(entry)) {
714 const char* key;
715 I32 len;
716
717 /* If this entry is not a glob, ignore it.
718 Try the next. */
719 if (!isGV(HeVAL(entry))) continue;
720
721 key = hv_iterkey(entry, &len);
722 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
723 HV * const oldsubstash = GvHV(HeVAL(entry));
724 SV ** const stashentry
725 = stash ? hv_fetch(stash, key, len, 0) : NULL;
35759254 726 HV *substash = NULL;
62c1e33f
FC
727
728 /* Avoid main::main::main::... */
729 if(oldsubstash == oldstash) continue;
35759254
FC
730 if(oldsubstash) {
731 HE * const entry
732 = (HE *)
733 hv_common(
734 seen_stashes, NULL,
735 (const char *)&oldsubstash, sizeof(HV *), 0,
736 HV_FETCH_LVALUE, NULL, 0
737 );
738 if(HeVAL(entry) == &PL_sv_yes) continue;
739 HeVAL(entry) = &PL_sv_yes;
740 }
62c1e33f 741
d056e33c 742 if(
35759254
FC
743 (
744 stashentry && *stashentry
745 && (substash = GvHV(*stashentry))
746 )
00169e2c 747 || (oldsubstash && HvENAME_get(oldsubstash))
d056e33c 748 )
35759254
FC
749 {
750 /* Add :: and the key (minus the trailing ::)
751 to newname. */
752 SV *namesv
753 = newSVpvn_flags(newname, newname_len, SVs_TEMP);
754 const char *name;
755 STRLEN namlen;
756 sv_catpvs(namesv, "::");
757 sv_catpvn(namesv, key, len-2);
758 name = SvPV_const(namesv, namlen);
d056e33c 759 mro_package_moved(
35759254
FC
760 substash, oldsubstash,
761 (GV *)seen_stashes, name, -namlen
4f6b8b29 762 );
35759254 763 }
d056e33c
FC
764
765 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
766 }
767 }
768 }
769 }
c8bbf675
FC
770
771 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
772 if (stash && HvUSEDKEYS(stash)) {
773 xhv = (XPVHV*)SvANY(stash);
35759254 774 if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
d056e33c
FC
775
776 /* Iterate through the new stash, skipping $seen{$key} items,
777 calling mro_package_moved(entry, NULL, ...). */
c8bbf675
FC
778 while (++riter <= (I32)xhv->xhv_max) {
779 entry = (HvARRAY(stash))[riter];
780
781 /* Iterate through the entries in this list */
782 for(; entry; entry = HeNEXT(entry)) {
783 const char* key;
784 I32 len;
785
786 /* If this entry is not a glob, ignore it.
787 Try the next. */
788 if (!isGV(HeVAL(entry))) continue;
789
790 key = hv_iterkey(entry, &len);
791 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
d056e33c
FC
792 HV *substash;
793
794 /* If this entry was seen when we iterated through the
795 oldstash, skip it. */
796 if(seen && hv_exists(seen, key, len)) continue;
797
798 /* We get here only if this stash has no corresponding
799 entry in the stash being replaced. */
800
801 substash = GvHV(HeVAL(entry));
35759254 802 if(substash) {
62c1e33f 803 SV *namesv;
35759254
FC
804 const char *name;
805 STRLEN namlen;
806 HE *entry;
62c1e33f
FC
807
808 /* Avoid checking main::main::main::... */
809 if(substash == stash) continue;
35759254
FC
810 entry
811 = (HE *)
812 hv_common(
813 seen_stashes, NULL,
814 (const char *)&substash, sizeof(HV *), 0,
815 HV_FETCH_LVALUE, NULL, 0
816 );
817 if(HeVAL(entry) == &PL_sv_yes) continue;
818 HeVAL(entry) = &PL_sv_yes;
62c1e33f 819
d056e33c
FC
820 /* Add :: and the key (minus the trailing ::)
821 to newname. */
62c1e33f 822 namesv
d056e33c
FC
823 = newSVpvn_flags(newname, newname_len, SVs_TEMP);
824 sv_catpvs(namesv, "::");
825 sv_catpvn(namesv, key, len-2);
35759254 826 name = SvPV_const(namesv, namlen);
d056e33c 827 mro_package_moved(
35759254 828 substash, NULL, (GV *)seen_stashes, name, -namlen
d056e33c
FC
829 );
830 }
c8bbf675
FC
831 }
832 }
833 }
834 }
835}
836
837/*
e1a479c5
BB
838=for apidoc mro_method_changed_in
839
47c9dd14
BB
840Invalidates method caching on any child classes
841of the given stash, so that they might notice
842the changes in this one.
e1a479c5
BB
843
844Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
845perl source outside of C<mro.c> should be
846replaced by calls to this.
847
848Perl automatically handles most of the common
849ways a method might be redefined. However, there
850are a few ways you could change a method in a stash
851without the cache code noticing, in which case you
852need to call this method afterwards:
e1a479c5 853
dd69841b
BB
8541) Directly manipulating the stash HV entries from
855XS code.
e1a479c5 856
dd69841b
BB
8572) Assigning a reference to a readonly scalar
858constant into a stash entry in order to create
859a constant subroutine (like constant.pm
860does).
861
862This same method is available from pure perl
863via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
864
865=cut
866*/
867void
868Perl_mro_method_changed_in(pTHX_ HV *stash)
869{
00169e2c
FC
870 const char * const stashname = HvENAME_get(stash);
871 const STRLEN stashname_len = HvENAMELEN_get(stash);
dd69841b 872
1e05feb3 873 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 874 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 875
7918f24d
NC
876 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
877
2c7f4b87
BB
878 if(!stashname)
879 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
880
70cd14a1
CB
881 /* Inc the package generation, since a local method changed */
882 HvMROMETA(stash)->pkg_gen++;
883
e1a479c5
BB
884 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
885 invalidate all method caches globally */
dd69841b
BB
886 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
887 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
888 PL_sub_generation++;
889 return;
890 }
891
892 /* else, invalidate the method caches of all child classes,
893 but not itself */
dd69841b 894 if(isarev) {
1e05feb3
AL
895 HE* iter;
896
e1a479c5
BB
897 hv_iterinit(isarev);
898 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
899 I32 len;
900 const char* const revkey = hv_iterkey(iter, &len);
901 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
902 struct mro_meta* mrometa;
903
904 if(!revstash) continue;
905 mrometa = HvMROMETA(revstash);
dd69841b 906 mrometa->cache_gen++;
e1a479c5
BB
907 if(mrometa->mro_nextmethod)
908 hv_clear(mrometa->mro_nextmethod);
909 }
910 }
911}
912
31b9005d
NC
913void
914Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
915{
916 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
917
918 PERL_ARGS_ASSERT_MRO_SET_MRO;
919
920 if (!which)
921 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
922
923 if(meta->mro_which != which) {
9953ff72 924 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
925 /* If we were storing something directly, put it in the hash before
926 we lose it. */
927 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 928 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
929 }
930 meta->mro_which = which;
931 /* Scrub our cached pointer to the private data. */
3a6fa573 932 meta->mro_linear_current = NULL;
31b9005d
NC
933 /* Only affects local method cache, not
934 even child classes */
935 meta->cache_gen++;
936 if(meta->mro_nextmethod)
937 hv_clear(meta->mro_nextmethod);
938 }
939}
940
e1a479c5
BB
941#include "XSUB.h"
942
e1a479c5 943XS(XS_mro_method_changed_in);
e1a479c5
BB
944
945void
946Perl_boot_core_mro(pTHX)
947{
948 dVAR;
949 static const char file[] = __FILE__;
950
a3e6e81e 951 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 952
e1a479c5 953 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
954}
955
e1a479c5
BB
956XS(XS_mro_method_changed_in)
957{
958 dVAR;
959 dXSARGS;
960 SV* classname;
961 HV* class_stash;
962
e1a479c5 963 if(items != 1)
afa74d42 964 croak_xs_usage(cv, "classname");
e1a479c5
BB
965
966 classname = ST(0);
967
968 class_stash = gv_stashsv(classname, 0);
969 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
970
971 mro_method_changed_in(class_stash);
972
973 XSRETURN_EMPTY;
974}
975
e1a479c5
BB
976/*
977 * Local variables:
978 * c-indentation-style: bsd
979 * c-basic-offset: 4
980 * indent-tabs-mode: t
981 * End:
982 *
983 * ex: set ts=8 sts=4 sw=4 noet:
984 */