3 * Copyright (c) 2007 Brandon L Black
4 * Copyright (c) 2007, 2008, 2009, 2010, 2011 Larry Wall and others
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.
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)
15 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
16 * You'll be last either way, Master Peregrin.'
18 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
23 These functions are related to the method resolution order of perl classes
32 static const struct mro_alg dfs_alg =
33 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
36 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
37 const struct mro_alg *const which)
40 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
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);
48 /* If we've been asked to look up the private data for the current MRO, then
50 if (smeta->mro_which == which)
51 smeta->mro_linear_current = *data;
57 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
58 const struct mro_alg *const which, SV *const data)
60 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
62 if (!smeta->mro_linear_all) {
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. */
67 smeta->mro_linear_current = data;
70 HV *const hv = newHV();
71 /* Start with 2 buckets. It's unlikely we'll need more. */
73 smeta->mro_linear_all = hv;
75 if (smeta->mro_linear_current) {
76 /* If we were storing something directly, put it in the hash
78 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
79 smeta->mro_linear_current);
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. */
87 if (smeta->mro_which == which) {
88 /* If we've been asked to store the private data for the current MRO,
90 smeta->mro_linear_current = data;
93 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
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,
104 const struct mro_alg *
105 Perl_mro_get_from_name(pTHX_ SV *name) {
108 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
110 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
111 HV_FETCH_JUST_SV, NULL, 0);
114 assert(SvTYPE(*data) == SVt_IV);
115 assert(SvIOK(*data));
116 return INT2PTR(const struct mro_alg *, SvUVX(*data));
120 =for apidoc mro_register
121 Registers a custom mro plugin. See L<perlmroapi> for details.
127 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
128 SV *wrapper = newSVuv(PTR2UV(mro));
130 PERL_ARGS_ASSERT_MRO_REGISTER;
133 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
134 mro->name, mro->length, mro->kflags,
135 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
136 SvREFCNT_dec_NN(wrapper);
137 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
138 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
143 Perl_mro_meta_init(pTHX_ HV* stash)
145 struct mro_meta* newmeta;
147 PERL_ARGS_ASSERT_MRO_META_INIT;
149 assert(HvAUX(stash));
150 assert(!(HvAUX(stash)->xhv_mro_meta));
151 Newxz(newmeta, 1, struct mro_meta);
152 HvAUX(stash)->xhv_mro_meta = newmeta;
153 newmeta->cache_gen = 1;
154 newmeta->pkg_gen = 1;
155 newmeta->mro_which = &dfs_alg;
160 #if defined(USE_ITHREADS)
162 /* for sv_dup on new threads */
164 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
166 struct mro_meta* newmeta;
168 PERL_ARGS_ASSERT_MRO_META_DUP;
170 Newx(newmeta, 1, struct mro_meta);
171 Copy(smeta, newmeta, 1, struct mro_meta);
173 if (newmeta->mro_linear_all) {
174 newmeta->mro_linear_all
175 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
176 /* This is just acting as a shortcut pointer, and will be automatically
177 updated on the first get. */
178 newmeta->mro_linear_current = NULL;
179 } else if (newmeta->mro_linear_current) {
180 /* Only the current MRO is stored, so this owns the data. */
181 newmeta->mro_linear_current
182 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
185 if (newmeta->mro_nextmethod)
186 newmeta->mro_nextmethod
187 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
190 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
192 newmeta->super = NULL;
194 /* clear the destructor cache */
195 newmeta->destroy = NULL;
196 newmeta->destroy_gen = 0;
201 #endif /* USE_ITHREADS */
204 =for apidoc mro_get_linear_isa_dfs
206 Returns the Depth-First Search linearization of C<@ISA>
207 the given stash. The return value is a read-only AV*.
208 C<level> should be 0 (it is used internally in this
209 function's recursion).
211 You are responsible for C<SvREFCNT_inc()> on the
212 return value if you plan to store it anywhere
213 semi-permanently (otherwise it might be deleted
214 out from under you the next time the cache is
220 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
227 struct mro_meta* meta;
231 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
232 assert(HvAUX(stash));
235 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
236 ? HvENAME_HEK_NN(stash)
240 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
244 "Recursive inheritance detected in package '%" HEKf "'",
247 meta = HvMROMETA(stash);
249 /* return cache if valid */
250 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
254 /* not in cache, make a new one */
256 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
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 */
263 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
264 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
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. */
272 if(av && AvFILLp(av) >= 0) {
274 SV **svp = AvARRAY(av);
275 I32 items = AvFILLp(av) + 1;
279 SV* const sv = *svp ? *svp : &PL_sv_undef;
280 HV* const basestash = gv_stashsv(sv, 0);
286 /* if no stash exists for this @ISA member,
287 simply add it to the MRO and move on */
292 /* otherwise, recurse into ourselves for the MRO
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
297 const AV *const subrv
298 = mro_get_linear_isa_dfs(basestash, level + 1);
300 subrv_p = AvARRAY(subrv);
301 subrv_items = AvFILLp(subrv) + 1;
304 while(subrv_items--) {
305 SV *const subsv = *subrv_p++;
306 /* LVALUE fetch will create a new undefined SV if necessary
308 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
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);
316 HeVAL(he) = &PL_sv_undef;
318 av_push(retval, val);
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
335 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
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)))
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())));
349 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef);
351 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
357 /* We have no parents. */
358 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
359 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef);
362 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
364 SvREFCNT_inc_simple_void_NN(stored);
366 SvREADONLY_on(stored);
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);
376 /* we don't want anyone modifying the cache entry but us,
377 and we do so by replacing it completely */
378 SvREADONLY_on(retval);
380 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
381 MUTABLE_SV(retval)));
385 =for apidoc mro_get_linear_isa
387 Returns the mro linearisation for the given stash. By default, this
388 will be whatever C<mro_get_linear_isa_dfs> returns unless some
389 other MRO is in effect for the stash. The return value is a
392 You are responsible for C<SvREFCNT_inc()> on the
393 return value if you plan to store it anywhere
394 semi-permanently (otherwise it might be deleted
395 out from under you the next time the cache is
401 Perl_mro_get_linear_isa(pTHX_ HV *stash)
403 struct mro_meta* meta;
406 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
408 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
410 meta = HvMROMETA(stash);
411 if (!meta->mro_which)
412 Perl_croak(aTHX_ "panic: invalid MRO!");
413 isa = meta->mro_which->resolve(aTHX_ stash, 0);
415 if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
417 (HvENAME(stash)||HvNAME(stash))
418 ? newSVhek(HvENAME_HEK(stash)
423 if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
425 AV * const old = isa;
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++);
435 else SvREFCNT_dec(namesv);
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);
446 while (svp < svp_end) {
447 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
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));
454 (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef);
456 SvREADONLY_on(isa_hash);
458 meta->isa = isa_hash;
465 =for apidoc mro_isa_changed_in
467 Takes the necessary steps (cache invalidations, mostly)
468 when the C<@ISA> of the given package has changed. Invoked
469 by the C<setisa> magic, should not need to invoke directly.
474 /* Macro to avoid repeating the code five times. */
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; \
488 Perl_mro_isa_changed_in(pTHX_ HV* stash)
496 struct mro_meta * meta;
499 const HEK * const stashhek = HvENAME_HEK(stash);
500 const char * const stashname = HvENAME_get(stash);
501 const STRLEN stashname_len = HvENAMELEN_get(stash);
503 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
506 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
509 /* wipe out the cached linearizations for this stash */
510 meta = HvMROMETA(stash);
513 /* Steal it for our own purposes. */
514 isa = (HV *)sv_2mortal((SV *)meta->isa);
518 /* Inc the package generation, since our @ISA changed */
521 /* Wipe the global method cache if this package
522 is UNIVERSAL or one of its parents */
524 svp = hv_fetchhek(PL_isarev, stashhek, 0);
525 isarev = svp ? MUTABLE_HV(*svp) : NULL;
527 if((memEQs(stashname, stashname_len, "UNIVERSAL"))
528 || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
532 else { /* Wipe the local method cache otherwise */
534 is_universal = FALSE;
537 /* wipe next::method cache too */
538 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
540 /* Changes to @ISA might turn overloading on */
542 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
543 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
545 /* DESTROY can be cached in meta. */
546 meta->destroy_gen = 0;
548 /* Iterate the isarev (classes that are our children),
549 wiping out their linearization, method and isa caches
550 and upating PL_isarev. */
552 HV *isa_hashes = NULL;
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
556 * be processed before B and use B's previous linearisation.
559 /* First iteration: Wipe everything, but stash away the isa hashes
560 * since we still need them for updating PL_isarev.
563 if(hv_iterinit(isarev)) {
564 /* Only create the hash if we need it; i.e., if isarev has
566 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
568 while((iter = hv_iternext(isarev))) {
569 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
570 struct mro_meta* revmeta;
572 if(!revstash) continue;
573 revmeta = HvMROMETA(revstash);
574 CLEAR_LINEAR(revmeta);
576 revmeta->cache_gen++;
577 if(revmeta->mro_nextmethod)
578 hv_clear(revmeta->mro_nextmethod);
579 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
583 isa_hashes, (const char*)&revstash, sizeof(HV *),
584 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
589 /* Second pass: Update PL_isarev. We can just use isa_hashes to
590 * avoid another round of stash lookups. */
592 /* isarev might be deleted from PL_isarev during this loop, so hang
594 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
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);
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);
608 namehek = HvENAME_HEK(revstash);
609 if (!namehek) namehek = HvNAME_HEK(revstash);
612 SV* const sv = *svp++;
615 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
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). */
621 mroisarev = MUTABLE_HV(HeVAL(he));
623 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
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
632 hv_storehek(mroisarev, namehek, &PL_sv_yes);
635 if ((SV *)isa != &PL_sv_undef) {
638 isa, HEK_KEY(namehek), HEK_LEN(namehek),
639 HvMROMETA(revstash)->isa, HEK_HASH(namehek),
647 /* Now iterate our MRO (parents), adding ourselves and everything from
648 our isarev to their isarev.
651 /* We're starting at the 2nd element, skipping ourselves here */
652 linear_mro = mro_get_linear_isa(stash);
653 svp = AvARRAY(linear_mro) + 1;
654 items = AvFILLp(linear_mro);
657 SV* const sv = *svp++;
660 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
662 /* That fetch should not fail. But if it had to create a new SV for
663 us, then will need to upgrade it to an HV (which sv_upgrade() can
666 mroisarev = MUTABLE_HV(HeVAL(he));
668 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
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. */
675 (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
678 /* Delete our name from our former parents' isarevs. */
679 if(isa && HvARRAY(isa))
680 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
681 HEK_HASH(stashhek), HEK_UTF8(stashhek));
684 /* Deletes name from all the isarev entries listed in isa */
686 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
687 const STRLEN len, HV * const exceptions, U32 hash,
692 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
694 /* Delete our name from our former parents' isarevs. */
695 if(HvARRAY(isa) && hv_iterinit(isa)) {
697 while((iter = hv_iternext(isa))) {
699 const char * const key = hv_iterkey(iter, &klen);
700 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
702 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
704 HV * const isarev = (HV *)*svp;
705 (void)hv_common(isarev, NULL, name, len, flags,
706 G_DISCARD|HV_DELETE, NULL, hash);
707 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
708 (void)hv_delete(PL_isarev, key,
709 HeKUTF8(iter) ? -klen : klen, G_DISCARD);
716 =for apidoc mro_package_moved
718 Call this function to signal to a stash that it has been assigned to
719 another spot in the stash hierarchy. C<stash> is the stash that has been
720 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
721 that is actually being assigned to.
723 This can also be called with a null first argument to
724 indicate that C<oldstash> has been deleted.
726 This function invalidates isa caches on the old stash, on all subpackages
727 nested inside it, and on the subclasses of all those, including
728 non-existent packages that have corresponding entries in C<stash>.
730 It also sets the effective names (C<HvENAME>) on all the stashes as
733 If the C<gv> is present and is not in the symbol table, then this function
734 simply returns. This checked will be skipped if C<flags & 1>.
739 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
740 const GV * const gv, U32 flags)
748 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
749 assert(stash || oldstash);
751 /* Determine the name(s) of the location that stash was assigned to
752 * or from which oldstash was removed.
754 * We cannot reliably use the name in oldstash, because it may have
755 * been deleted from the location in the symbol table that its name
756 * suggests, as in this case:
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)
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.
774 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
775 !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
779 assert(SvOOK(GvSTASH(gv)));
780 assert(GvNAMELEN(gv));
781 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
782 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
783 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
786 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
789 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
790 if (name_count < 0) ++namep, name_count = -name_count - 1;
792 if (name_count == 1) {
793 if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) {
794 namesv = GvNAMELEN(gv) == 1
795 ? newSVpvs_flags(":", SVs_TEMP)
796 : newSVpvs_flags("", SVs_TEMP);
799 namesv = sv_2mortal(newSVhek(*namep));
800 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
801 else sv_catpvs(namesv, "::");
803 if (GvNAMELEN(gv) != 1) {
805 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
806 /* skip trailing :: */
807 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
813 namesv = sv_2mortal((SV *)newAV());
814 while (name_count--) {
815 if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){
816 aname = GvNAMELEN(gv) == 1
822 aname = newSVhek(*namep++);
823 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
824 else sv_catpvs(aname, "::");
826 if (GvNAMELEN(gv) != 1) {
828 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
829 /* skip trailing :: */
830 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
833 av_push((AV *)namesv, aname);
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:
842 @foo::ISA = qw( B B::B );
843 *B:: = delete $::{"A::"};
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
848 we do anything else. (And linearisations must be cleared, too.)
850 stashes = (HV *) sv_2mortal((SV *)newHV());
851 mro_gather_and_rename(
852 stashes, (HV *) sv_2mortal((SV *)newHV()),
853 stash, oldstash, namesv
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))) {
860 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
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
866 will have been overwritten without old entries being deleted
868 struct mro_meta * const meta = HvMROMETA(stash);
869 if(meta->isa != (HV *)HeVAL(iter)){
870 SvREFCNT_dec(meta->isa);
872 = HeVAL(iter) == &PL_sv_yes
875 HeVAL(iter) = NULL; /* We donated our reference count. */
877 mro_isa_changed_in(stash);
883 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
884 HV *stash, HV *oldstash, SV *namesv)
890 const bool stash_had_name = stash && HvENAME(stash);
891 bool fetched_isarev = FALSE;
896 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
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.)
906 To avoid allocating extra SVs, instead of a bitfield we can make
907 bizarre use of immortals:
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
916 /* Add to the big list. */
917 struct mro_meta * meta;
921 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
922 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
924 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
929 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
930 meta = HvMROMETA(oldstash);
933 stashes, (const char *)&oldstash, sizeof(HV *),
935 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
941 /* Update the effective name. */
942 if(HvENAME_get(oldstash)) {
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);
953 const U32 name_utf8 = SvUTF8(*svp);
955 const char *name = SvPVx_const(*svp, len);
957 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%" SVf "'\n",
959 (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
962 hv_ename_delete(oldstash, name, len, name_utf8);
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
969 * those in the superclasses and this class's own list
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))
975 mro_clean_isarev(meta->isa, name, len, 0, 0,
976 name_utf8 ? HVhek_UTF8 : 0);
977 isarev = (HV *)hv_delete(PL_isarev, name,
978 name_utf8 ? -(I32)len : (I32)len, 0);
987 if(SvTYPE(namesv) == SVt_PVAV) {
988 items = AvFILLp((AV *)namesv) + 1;
989 svp = AvARRAY((AV *)namesv);
996 const U32 name_utf8 = SvUTF8(*svp);
998 const char *name = SvPVx_const(*svp++, len);
999 hv_ename_add(stash, name, len, name_utf8);
1002 /* Add it to the big list if it needs
1003 * mro_isa_changed_in called on it. That happens if it was
1004 * detached from the symbol table (so it had no HvENAME) before
1005 * being assigned to the spot named by the 'name' variable, because
1006 * its cached isa linearisation is now stale (the effective name
1007 * having changed), and subclasses will then use that cache when
1008 * mro_package_moved calls mro_isa_changed_in. (See
1011 * If it did have a name, then its previous name is still
1012 * used in isa caches, and there is no need for
1013 * mro_package_moved to call mro_isa_changed_in.
1019 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1020 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1022 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1026 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1029 struct mro_meta * const meta = HvMROMETA(stash);
1032 stashes, (const char *)&stash, sizeof(HV *),
1034 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1043 if(!stash && !oldstash)
1044 /* Both stashes have been encountered already. */
1047 /* Add all the subclasses to the big list. */
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.
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
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.
1059 assert(!oldstash || HvENAME(oldstash));
1061 /* Extra variable to avoid a compiler warning */
1062 const HEK * const hvename = HvENAME_HEK(oldstash);
1063 fetched_isarev = TRUE;
1064 svp = hv_fetchhek(PL_isarev, hvename, 0);
1065 if (svp) isarev = MUTABLE_HV(*svp);
1067 else if(SvTYPE(namesv) == SVt_PVAV) {
1068 items = AvFILLp((AV *)namesv) + 1;
1069 svp = AvARRAY((AV *)namesv);
1077 isarev || !fetched_isarev
1079 while (fetched_isarev || items--) {
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;
1087 hv_iterinit(isarev);
1088 while((iter = hv_iternext(isarev))) {
1089 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1090 struct mro_meta * meta;
1092 if(!revstash) continue;
1093 meta = HvMROMETA(revstash);
1096 stashes, (const char *)&revstash, sizeof(HV *),
1098 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1105 if (fetched_isarev) break;
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. */
1112 /* Skip the entire loop if the hash is empty. */
1113 if(oldstash && HvUSEDKEYS(oldstash)) {
1114 xhv = (XPVHV*)SvANY(oldstash);
1115 seen = (HV *) sv_2mortal((SV *)newHV());
1117 /* Iterate through entries in the oldstash, adding them to the
1118 list, meanwhile doing the equivalent of $seen{$key} = 1.
1121 while (++riter <= (I32)xhv->xhv_max) {
1122 entry = (HvARRAY(oldstash))[riter];
1124 /* Iterate through the entries in this list */
1125 for(; entry; entry = HeNEXT(entry)) {
1129 /* If this entry is not a glob, ignore it.
1131 if (!isGV(HeVAL(entry))) continue;
1133 key = hv_iterkey(entry, &len);
1134 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1135 || (len == 1 && key[0] == ':')) {
1136 HV * const oldsubstash = GvHV(HeVAL(entry));
1137 SV ** const stashentry
1138 = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
1139 HV *substash = NULL;
1141 /* Avoid main::main::main::... */
1142 if(oldsubstash == oldstash) continue;
1146 stashentry && *stashentry && isGV(*stashentry)
1147 && (substash = GvHV(*stashentry))
1149 || (oldsubstash && HvENAME_get(oldsubstash))
1152 /* Add :: and the key (minus the trailing ::)
1155 if(SvTYPE(namesv) == SVt_PVAV) {
1157 items = AvFILLp((AV *)namesv) + 1;
1158 svp = AvARRAY((AV *)namesv);
1159 subname = sv_2mortal((SV *)newAV());
1161 aname = newSVsv(*svp++);
1163 sv_catpvs(aname, ":");
1165 sv_catpvs(aname, "::");
1169 ? SV_CATUTF8 : SV_CATBYTES
1172 av_push((AV *)subname, aname);
1176 subname = sv_2mortal(newSVsv(namesv));
1177 if (len == 1) sv_catpvs(subname, ":");
1179 sv_catpvs(subname, "::");
1181 subname, key, len-2,
1182 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1186 mro_gather_and_rename(
1187 stashes, seen_stashes,
1188 substash, oldsubstash, subname
1192 (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
1198 /* Skip the entire loop if the hash is empty. */
1199 if (stash && HvUSEDKEYS(stash)) {
1200 xhv = (XPVHV*)SvANY(stash);
1203 /* Iterate through the new stash, skipping $seen{$key} items,
1204 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1205 while (++riter <= (I32)xhv->xhv_max) {
1206 entry = (HvARRAY(stash))[riter];
1208 /* Iterate through the entries in this list */
1209 for(; entry; entry = HeNEXT(entry)) {
1213 /* If this entry is not a glob, ignore it.
1215 if (!isGV(HeVAL(entry))) continue;
1217 key = hv_iterkey(entry, &len);
1218 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1219 || (len == 1 && key[0] == ':')) {
1222 /* If this entry was seen when we iterated through the
1223 oldstash, skip it. */
1224 if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
1226 /* We get here only if this stash has no corresponding
1227 entry in the stash being replaced. */
1229 substash = GvHV(HeVAL(entry));
1233 /* Avoid checking main::main::main::... */
1234 if(substash == stash) continue;
1236 /* Add :: and the key (minus the trailing ::)
1238 if(SvTYPE(namesv) == SVt_PVAV) {
1240 items = AvFILLp((AV *)namesv) + 1;
1241 svp = AvARRAY((AV *)namesv);
1242 subname = sv_2mortal((SV *)newAV());
1244 aname = newSVsv(*svp++);
1246 sv_catpvs(aname, ":");
1248 sv_catpvs(aname, "::");
1252 ? SV_CATUTF8 : SV_CATBYTES
1255 av_push((AV *)subname, aname);
1259 subname = sv_2mortal(newSVsv(namesv));
1260 if (len == 1) sv_catpvs(subname, ":");
1262 sv_catpvs(subname, "::");
1264 subname, key, len-2,
1265 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1269 mro_gather_and_rename(
1270 stashes, seen_stashes,
1271 substash, NULL, subname
1281 =for apidoc mro_method_changed_in
1283 Invalidates method caching on any child classes
1284 of the given stash, so that they might notice
1285 the changes in this one.
1287 Ideally, all instances of C<PL_sub_generation++> in
1288 perl source outside of F<mro.c> should be
1289 replaced by calls to this.
1291 Perl automatically handles most of the common
1292 ways a method might be redefined. However, there
1293 are a few ways you could change a method in a stash
1294 without the cache code noticing, in which case you
1295 need to call this method afterwards:
1297 1) Directly manipulating the stash HV entries from
1300 2) Assigning a reference to a readonly scalar
1301 constant into a stash entry in order to create
1302 a constant subroutine (like F<constant.pm>
1305 This same method is available from pure perl
1306 via, C<mro::method_changed_in(classname)>.
1311 Perl_mro_method_changed_in(pTHX_ HV *stash)
1313 const char * const stashname = HvENAME_get(stash);
1314 const STRLEN stashname_len = HvENAMELEN_get(stash);
1316 SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
1317 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1319 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1322 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1324 /* Inc the package generation, since a local method changed */
1325 HvMROMETA(stash)->pkg_gen++;
1327 /* DESTROY can be cached in meta */
1328 HvMROMETA(stash)->destroy_gen = 0;
1330 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1331 invalidate all method caches globally */
1332 if((memEQs(stashname, stashname_len, "UNIVERSAL"))
1333 || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
1334 PL_sub_generation++;
1338 /* else, invalidate the method caches of all child classes,
1343 hv_iterinit(isarev);
1344 while((iter = hv_iternext(isarev))) {
1345 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1346 struct mro_meta* mrometa;
1348 if(!revstash) continue;
1349 mrometa = HvMROMETA(revstash);
1350 mrometa->cache_gen++;
1351 if(mrometa->mro_nextmethod)
1352 hv_clear(mrometa->mro_nextmethod);
1353 mrometa->destroy_gen = 0;
1357 /* The method change may be due to *{$package . "::()"} = \&nil; in
1360 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
1361 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
1365 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1367 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1369 PERL_ARGS_ASSERT_MRO_SET_MRO;
1372 Perl_croak(aTHX_ "Invalid mro name: '%" SVf "'", name);
1374 if(meta->mro_which != which) {
1375 if (meta->mro_linear_current && !meta->mro_linear_all) {
1376 /* If we were storing something directly, put it in the hash before
1378 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1379 MUTABLE_SV(meta->mro_linear_current));
1381 meta->mro_which = which;
1382 /* Scrub our cached pointer to the private data. */
1383 meta->mro_linear_current = NULL;
1384 /* Only affects local method cache, not
1385 even child classes */
1387 if(meta->mro_nextmethod)
1388 hv_clear(meta->mro_nextmethod);
1394 XS(XS_mro_method_changed_in);
1397 Perl_boot_core_mro(pTHX)
1399 static const char file[] = __FILE__;
1401 Perl_mro_register(aTHX_ &dfs_alg);
1403 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1406 XS(XS_mro_method_changed_in)
1413 croak_xs_usage(cv, "classname");
1417 class_stash = gv_stashsv(classname, 0);
1418 if(!class_stash) Perl_croak(aTHX_ "No such class: '%" SVf "'!", SVfARG(classname));
1420 mro_method_changed_in(class_stash);
1426 * ex: set ts=8 sts=4 sw=4 et: