3 * Copyright (c) 2007 Brandon L Black
4 * Copyright (c) 2007, 2008 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.
12 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
13 * You'll be last either way, Master Peregrin.'
15 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
21 These functions are related to the method resolution order of perl classes
30 static const struct mro_alg dfs_alg =
31 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
34 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35 const struct mro_alg *const which)
38 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
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);
46 /* If we've been asked to look up the private data for the current MRO, then
48 if (smeta->mro_which == which)
49 smeta->mro_linear_current = *data;
55 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56 const struct mro_alg *const which, SV *const data)
58 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
60 if (!smeta->mro_linear_all) {
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. */
65 smeta->mro_linear_current = data;
68 HV *const hv = newHV();
69 /* Start with 2 buckets. It's unlikely we'll need more. */
71 smeta->mro_linear_all = hv;
73 if (smeta->mro_linear_current) {
74 /* If we were storing something directly, put it in the hash
76 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
77 smeta->mro_linear_current);
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. */
85 if (smeta->mro_which == which) {
86 /* If we've been asked to store the private data for the current MRO,
88 smeta->mro_linear_current = data;
91 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
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,
102 const struct mro_alg *
103 Perl_mro_get_from_name(pTHX_ SV *name) {
106 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
108 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109 HV_FETCH_JUST_SV, NULL, 0);
112 assert(SvTYPE(*data) == SVt_IV);
113 assert(SvIOK(*data));
114 return INT2PTR(const struct mro_alg *, SvUVX(*data));
118 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
119 SV *wrapper = newSVuv(PTR2UV(mro));
121 PERL_ARGS_ASSERT_MRO_REGISTER;
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);
134 Perl_mro_meta_init(pTHX_ HV* stash)
136 struct mro_meta* newmeta;
138 PERL_ARGS_ASSERT_MRO_META_INIT;
139 assert(HvAUX(stash));
140 assert(!(HvAUX(stash)->xhv_mro_meta));
141 Newxz(newmeta, 1, struct mro_meta);
142 HvAUX(stash)->xhv_mro_meta = newmeta;
143 newmeta->cache_gen = 1;
144 newmeta->pkg_gen = 1;
145 newmeta->mro_which = &dfs_alg;
150 #if defined(USE_ITHREADS)
152 /* for sv_dup on new threads */
154 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
156 struct mro_meta* newmeta;
158 PERL_ARGS_ASSERT_MRO_META_DUP;
160 Newx(newmeta, 1, struct mro_meta);
161 Copy(smeta, newmeta, 1, struct mro_meta);
163 if (newmeta->mro_linear_all) {
164 newmeta->mro_linear_all
165 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
166 /* This is just acting as a shortcut pointer, and will be automatically
167 updated on the first get. */
168 newmeta->mro_linear_current = NULL;
169 } else if (newmeta->mro_linear_current) {
170 /* Only the current MRO is stored, so this owns the data. */
171 newmeta->mro_linear_current
172 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
175 if (newmeta->mro_nextmethod)
176 newmeta->mro_nextmethod
177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
180 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
185 #endif /* USE_ITHREADS */
188 =for apidoc mro_get_linear_isa_dfs
190 Returns the Depth-First Search linearization of @ISA
191 the given stash. The return value is a read-only AV*.
192 C<level> should be 0 (it is used internally in this
193 function's recursion).
195 You are responsible for C<SvREFCNT_inc()> on the
196 return value if you plan to store it anywhere
197 semi-permanently (otherwise it might be deleted
198 out from under you the next time the cache is
204 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
211 struct mro_meta* meta;
215 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
216 assert(HvAUX(stash));
219 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
220 ? HvENAME_HEK_NN(stash)
224 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
227 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
230 meta = HvMROMETA(stash);
232 /* return cache if valid */
233 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
237 /* not in cache, make a new one */
239 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
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 */
246 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
247 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
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. */
255 if(av && AvFILLp(av) >= 0) {
257 SV **svp = AvARRAY(av);
258 I32 items = AvFILLp(av) + 1;
262 SV* const sv = *svp++;
263 HV* const basestash = gv_stashsv(sv, 0);
268 /* if no stash exists for this @ISA member,
269 simply add it to the MRO and move on */
274 /* otherwise, recurse into ourselves for the MRO
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
279 const AV *const subrv
280 = mro_get_linear_isa_dfs(basestash, level + 1);
282 subrv_p = AvARRAY(subrv);
283 subrv_items = AvFILLp(subrv) + 1;
286 while(subrv_items--) {
287 SV *const subsv = *subrv_p++;
288 /* LVALUE fetch will create a new undefined SV if necessary
290 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
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);
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));
313 av_push(retval, val);
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
330 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
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)))
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);
346 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
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);
357 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
359 SvREFCNT_inc_simple_void_NN(stored);
361 SvREADONLY_on(stored);
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);
371 /* we don't want anyone modifying the cache entry but us,
372 and we do so by replacing it completely */
373 SvREADONLY_on(retval);
375 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
376 MUTABLE_SV(retval)));
380 =for apidoc mro_get_linear_isa
382 Returns the mro linearisation for the given stash. By default, this
383 will be whatever C<mro_get_linear_isa_dfs> returns unless some
384 other MRO is in effect for the stash. The return value is a
387 You are responsible for C<SvREFCNT_inc()> on the
388 return value if you plan to store it anywhere
389 semi-permanently (otherwise it might be deleted
390 out from under you the next time the cache is
396 Perl_mro_get_linear_isa(pTHX_ HV *stash)
398 struct mro_meta* meta;
401 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
403 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
405 meta = HvMROMETA(stash);
406 if (!meta->mro_which)
407 Perl_croak(aTHX_ "panic: invalid MRO!");
408 isa = meta->mro_which->resolve(aTHX_ stash, 0);
411 HV *const isa_hash = newHV();
412 /* Linearisation didn't build it for us, so do it here. */
413 SV *const *svp = AvARRAY(isa);
414 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
415 const HEK *canon_name = HvENAME_HEK(stash);
416 if (!canon_name) canon_name = HvNAME_HEK(stash);
418 while (svp < svp_end) {
419 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
422 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
423 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
424 HV_FETCH_ISSTORE, &PL_sv_undef,
425 HEK_HASH(canon_name));
426 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
428 SvREADONLY_on(isa_hash);
430 meta->isa = isa_hash;
437 =for apidoc mro_isa_changed_in
439 Takes the necessary steps (cache invalidations, mostly)
440 when the @ISA of the given package has changed. Invoked
441 by the C<setisa> magic, should not need to invoke directly.
446 /* Macro to avoid repeating the code five times. */
447 #define CLEAR_LINEAR(mEta) \
448 if (mEta->mro_linear_all) { \
449 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
450 mEta->mro_linear_all = NULL; \
451 /* This is just acting as a shortcut pointer. */ \
452 mEta->mro_linear_current = NULL; \
453 } else if (mEta->mro_linear_current) { \
454 /* Only the current MRO is stored, so this owns the data. */ \
455 SvREFCNT_dec(mEta->mro_linear_current); \
456 mEta->mro_linear_current = NULL; \
460 Perl_mro_isa_changed_in(pTHX_ HV* stash)
469 struct mro_meta * meta;
472 const char * const stashname = HvENAME_get(stash);
473 const STRLEN stashname_len = HvENAMELEN_get(stash);
475 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
478 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
481 /* wipe out the cached linearizations for this stash */
482 meta = HvMROMETA(stash);
485 /* Steal it for our own purposes. */
486 isa = (HV *)sv_2mortal((SV *)meta->isa);
490 /* Inc the package generation, since our @ISA changed */
493 /* Wipe the global method cache if this package
494 is UNIVERSAL or one of its parents */
496 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
497 isarev = svp ? MUTABLE_HV(*svp) : NULL;
499 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
500 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
504 else { /* Wipe the local method cache otherwise */
506 is_universal = FALSE;
509 /* wipe next::method cache too */
510 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
512 /* Iterate the isarev (classes that are our children),
513 wiping out their linearization, method and isa caches
514 and upating PL_isarev. */
516 HV *isa_hashes = NULL;
518 /* We have to iterate through isarev twice to avoid a chicken and
519 * egg problem: if A inherits from B and both are in isarev, A might
520 * be processed before B and use B’s previous linearisation.
523 /* First iteration: Wipe everything, but stash away the isa hashes
524 * since we still need them for updating PL_isarev.
527 if(hv_iterinit(isarev)) {
528 /* Only create the hash if we need it; i.e., if isarev has
530 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
532 while((iter = hv_iternext(isarev))) {
534 const char* const revkey = hv_iterkey(iter, &len);
535 HV* revstash = gv_stashpvn(revkey, len, 0);
536 struct mro_meta* revmeta;
538 if(!revstash) continue;
539 revmeta = HvMROMETA(revstash);
540 CLEAR_LINEAR(revmeta);
542 revmeta->cache_gen++;
543 if(revmeta->mro_nextmethod)
544 hv_clear(revmeta->mro_nextmethod);
548 isa_hashes, (const char*)&revstash, sizeof(HV *),
549 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
554 /* Second pass: Update PL_isarev. We can just use isa_hashes to
555 * avoid another round of stash lookups. */
557 /* isarev might be deleted from PL_isarev during this loop, so hang
559 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
562 hv_iterinit(isa_hashes);
563 while((iter = hv_iternext(isa_hashes))) {
564 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
565 HV * const isa = (HV *)HeVAL(iter);
568 /* We're starting at the 2nd element, skipping revstash */
569 linear_mro = mro_get_linear_isa(revstash);
570 svp = AvARRAY(linear_mro) + 1;
571 items = AvFILLp(linear_mro);
573 namehek = HvENAME_HEK(revstash);
574 if (!namehek) namehek = HvNAME_HEK(revstash);
577 SV* const sv = *svp++;
580 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
582 /* That fetch should not fail. But if it had to create
583 a new SV for us, then will need to upgrade it to an
584 HV (which sv_upgrade() can now do for us). */
586 mroisarev = MUTABLE_HV(HeVAL(he));
588 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
590 /* This hash only ever contains PL_sv_yes. Storing it
591 over itself is almost as cheap as calling hv_exists,
592 so on aggregate we expect to save time by not making
593 two calls to the common HV code for the case where
598 mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
603 if((SV *)isa != &PL_sv_undef)
605 isa, HEK_KEY(namehek), HEK_LEN(namehek),
606 HvMROMETA(revstash)->isa
612 /* Now iterate our MRO (parents), adding ourselves and everything from
613 our isarev to their isarev.
616 /* We're starting at the 2nd element, skipping ourselves here */
617 linear_mro = mro_get_linear_isa(stash);
618 svp = AvARRAY(linear_mro) + 1;
619 items = AvFILLp(linear_mro);
622 SV* const sv = *svp++;
625 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
627 /* That fetch should not fail. But if it had to create a new SV for
628 us, then will need to upgrade it to an HV (which sv_upgrade() can
631 mroisarev = MUTABLE_HV(HeVAL(he));
633 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
635 /* This hash only ever contains PL_sv_yes. Storing it over itself is
636 almost as cheap as calling hv_exists, so on aggregate we expect to
637 save time by not making two calls to the common HV code for the
638 case where it doesn't exist. */
640 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
643 /* Delete our name from our former parents’ isarevs. */
644 if(isa && HvARRAY(isa))
645 mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
648 /* Deletes name from all the isarev entries listed in isa */
650 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
651 const STRLEN len, HV * const exceptions)
655 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
657 /* Delete our name from our former parents’ isarevs. */
658 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
660 while((iter = hv_iternext(isa))) {
662 const char * const key = hv_iterkey(iter, &klen);
663 if(exceptions && hv_exists(exceptions, key, klen)) continue;
664 svp = hv_fetch(PL_isarev, key, klen, 0);
666 HV * const isarev = (HV *)*svp;
667 (void)hv_delete(isarev, name, len, G_DISCARD);
668 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
669 (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
676 =for apidoc mro_package_moved
678 Call this function to signal to a stash that it has been assigned to
679 another spot in the stash hierarchy. C<stash> is the stash that has been
680 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
681 that is actually being assigned to.
683 This can also be called with a null first argument to
684 indicate that C<oldstash> has been deleted.
686 This function invalidates isa caches on the old stash, on all subpackages
687 nested inside it, and on the subclasses of all those, including
688 non-existent packages that have corresponding entries in C<stash>.
690 It also sets the effective names (C<HvENAME>) on all the stashes as
693 If the C<gv> is present and is not in the symbol table, then this function
694 simply returns. This checked will be skipped if C<flags & 1>.
699 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
700 const GV * const gv, U32 flags)
708 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
709 assert(stash || oldstash);
711 /* Determine the name(s) of the location that stash was assigned to
712 * or from which oldstash was removed.
714 * We cannot reliably use the name in oldstash, because it may have
715 * been deleted from the location in the symbol table that its name
716 * suggests, as in this case:
718 * $globref = \*foo::bar::;
719 * Symbol::delete_package("foo");
720 * *$globref = \%baz::;
721 * *$globref = *frelp::;
722 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
724 * So we get it from the gv. But, since the gv may no longer be in the
725 * symbol table, we check that first. The only reliable way to tell is
726 * to see whether its stash has an effective name and whether the gv
727 * resides in that stash under its name. That effective name may be
728 * different from what gv_fullname4 would use.
729 * If flags & 1, the caller has asked us to skip the check.
734 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
735 !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), 0)) ||
739 assert(SvOOK(GvSTASH(gv)));
740 assert(GvNAMELEN(gv));
741 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
742 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
743 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
746 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
749 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
750 if (name_count < 0) ++namep, name_count = -name_count - 1;
752 if (name_count == 1) {
753 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
754 namesv = GvNAMELEN(gv) == 1
755 ? newSVpvs_flags(":", SVs_TEMP)
756 : newSVpvs_flags("", SVs_TEMP);
759 namesv = sv_2mortal(newSVhek(*namep));
760 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
761 else sv_catpvs(namesv, "::");
763 if (GvNAMELEN(gv) != 1)
764 sv_catpvn(namesv, GvNAME(gv), GvNAMELEN(gv) - 2);
765 /* skip trailing :: */
769 namesv = sv_2mortal((SV *)newAV());
770 while (name_count--) {
771 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
772 aname = GvNAMELEN(gv) == 1
778 aname = newSVhek(*namep++);
779 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
780 else sv_catpvs(aname, "::");
782 if (GvNAMELEN(gv) != 1)
783 sv_catpvn(aname, GvNAME(gv), GvNAMELEN(gv) - 2);
784 /* skip trailing :: */
785 av_push((AV *)namesv, aname);
789 /* Get a list of all the affected classes. */
790 /* We cannot simply pass them all to mro_isa_changed_in to avoid
791 the list, as that function assumes that only one package has
792 changed. It does not work with:
794 @foo::ISA = qw( B B::B );
795 *B:: = delete $::{"A::"};
797 as neither B nor B::B can be updated before the other, since they
798 will reset caches on foo, which will see either B or B::B with the
799 wrong name. The names must be set on *all* affected stashes before
800 we do anything else. (And linearisations must be cleared, too.)
802 stashes = (HV *) sv_2mortal((SV *)newHV());
803 mro_gather_and_rename(
804 stashes, (HV *) sv_2mortal((SV *)newHV()),
805 stash, oldstash, namesv
808 /* Once the caches have been wiped on all the classes, call
809 mro_isa_changed_in on each. */
810 hv_iterinit(stashes);
811 while((iter = hv_iternext(stashes))) {
812 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
814 /* We have to restore the original meta->isa (that
815 mro_gather_and_rename set aside for us) this way, in case
816 one class in this list is a superclass of a another class
817 that we have already encountered. In such a case, meta->isa
818 will have been overwritten without old entries being deleted
820 struct mro_meta * const meta = HvMROMETA(stash);
821 if(meta->isa != (HV *)HeVAL(iter)){
822 SvREFCNT_dec(meta->isa);
824 = HeVAL(iter) == &PL_sv_yes
827 HeVAL(iter) = NULL; /* We donated our reference count. */
829 mro_isa_changed_in(stash);
835 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
836 HV *stash, HV *oldstash, SV *namesv)
842 const bool stash_had_name = stash && HvENAME(stash);
843 bool fetched_isarev = FALSE;
848 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
850 /* We use the seen_stashes hash to keep track of which packages have
851 been encountered so far. This must be separate from the main list of
852 stashes, as we need to distinguish between stashes being assigned
853 and stashes being replaced/deleted. (A nested stash can be on both
854 sides of an assignment. We cannot simply skip iterating through a
855 stash on the right if we have seen it on the left, as it will not
856 get its ename assigned to it.)
858 To avoid allocating extra SVs, instead of a bitfield we can make
859 bizarre use of immortals:
861 &PL_sv_undef: seen on the left (oldstash)
862 &PL_sv_no : seen on the right (stash)
863 &PL_sv_yes : seen on both sides
868 /* Add to the big list. */
869 struct mro_meta * meta;
873 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
874 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
876 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
881 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
882 meta = HvMROMETA(oldstash);
885 stashes, (const char *)&oldstash, sizeof(HV *),
887 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
893 /* Update the effective name. */
894 if(HvENAME_get(oldstash)) {
895 const HEK * const enamehek = HvENAME_HEK(oldstash);
896 if(SvTYPE(namesv) == SVt_PVAV) {
897 items = AvFILLp((AV *)namesv) + 1;
898 svp = AvARRAY((AV *)namesv);
906 const char *name = SvPVx_const(*svp++, len);
908 (void)hv_delete(PL_stashcache, name, len, G_DISCARD);
909 hv_ename_delete(oldstash, name, len, 0);
911 if (!fetched_isarev) {
912 /* If the name deletion caused a name change, then we
913 * are not going to call mro_isa_changed_in with this
914 * name (and not at all if it has become anonymous) so
915 * we need to delete old isarev entries here, both
916 * those in the superclasses and this class’s own list
917 * of subclasses. We simply delete the latter from
918 * PL_isarev, since we still need it. hv_delete morti-
919 * fies it for us, so sv_2mortal is not necessary. */
920 if(HvENAME_HEK(oldstash) != enamehek) {
921 if(meta->isa && HvARRAY(meta->isa))
922 mro_clean_isarev(meta->isa, name, len, NULL);
923 isarev = (HV *)hv_delete(PL_isarev, name, len, 0);
932 if(SvTYPE(namesv) == SVt_PVAV) {
933 items = AvFILLp((AV *)namesv) + 1;
934 svp = AvARRAY((AV *)namesv);
942 const char *name = SvPVx_const(*svp++, len);
943 hv_ename_add(stash, name, len, 0);
946 /* Add it to the big list if it needs
947 * mro_isa_changed_in called on it. That happens if it was
948 * detached from the symbol table (so it had no HvENAME) before
949 * being assigned to the spot named by the ‘name’ variable, because
950 * its cached isa linearisation is now stale (the effective name
951 * having changed), and subclasses will then use that cache when
952 * mro_package_moved calls mro_isa_changed_in. (See
955 * If it did have a name, then its previous name is still
956 * used in isa caches, and there is no need for
957 * mro_package_moved to call mro_isa_changed_in.
963 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
964 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
966 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
970 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
973 struct mro_meta * const meta = HvMROMETA(stash);
976 stashes, (const char *)&stash, sizeof(HV *),
978 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
987 if(!stash && !oldstash)
988 /* Both stashes have been encountered already. */
991 /* Add all the subclasses to the big list. */
992 if(!fetched_isarev) {
993 /* If oldstash is not null, then we can use its HvENAME to look up
994 the isarev hash, since all its subclasses will be listed there.
995 It will always have an HvENAME. It the HvENAME was removed
996 above, then fetch_isarev will be true, and this code will not be
999 If oldstash is null, then this is an empty spot with no stash in
1000 it, so subclasses could be listed in isarev hashes belonging to
1001 any of the names, so we have to check all of them.
1003 assert(!oldstash || HvENAME(oldstash));
1005 /* Extra variable to avoid a compiler warning */
1006 char * const hvename = HvENAME(oldstash);
1007 fetched_isarev = TRUE;
1008 svp = hv_fetch(PL_isarev, hvename, HvENAMELEN_get(oldstash), 0);
1009 if (svp) isarev = MUTABLE_HV(*svp);
1011 else if(SvTYPE(namesv) == SVt_PVAV) {
1012 items = AvFILLp((AV *)namesv) + 1;
1013 svp = AvARRAY((AV *)namesv);
1021 isarev || !fetched_isarev
1023 while (fetched_isarev || items--) {
1026 if (!fetched_isarev) {
1027 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1028 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1031 hv_iterinit(isarev);
1032 while((iter = hv_iternext(isarev))) {
1034 const char* const revkey = hv_iterkey(iter, &len);
1035 HV* revstash = gv_stashpvn(revkey, len, 0);
1036 struct mro_meta * meta;
1038 if(!revstash) continue;
1039 meta = HvMROMETA(revstash);
1042 stashes, (const char *)&revstash, sizeof(HV *),
1044 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1051 if (fetched_isarev) break;
1055 /* This is partly based on code in hv_iternext_flags. We are not call-
1056 ing that here, as we want to avoid resetting the hash iterator. */
1058 /* Skip the entire loop if the hash is empty. */
1059 if(oldstash && HvUSEDKEYS(oldstash)) {
1060 xhv = (XPVHV*)SvANY(oldstash);
1061 seen = (HV *) sv_2mortal((SV *)newHV());
1063 /* Iterate through entries in the oldstash, adding them to the
1064 list, meanwhile doing the equivalent of $seen{$key} = 1.
1067 while (++riter <= (I32)xhv->xhv_max) {
1068 entry = (HvARRAY(oldstash))[riter];
1070 /* Iterate through the entries in this list */
1071 for(; entry; entry = HeNEXT(entry)) {
1075 /* If this entry is not a glob, ignore it.
1077 if (!isGV(HeVAL(entry))) continue;
1079 key = hv_iterkey(entry, &len);
1080 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1081 || (len == 1 && key[0] == ':')) {
1082 HV * const oldsubstash = GvHV(HeVAL(entry));
1083 SV ** const stashentry
1084 = stash ? hv_fetch(stash, key, len, 0) : NULL;
1085 HV *substash = NULL;
1087 /* Avoid main::main::main::... */
1088 if(oldsubstash == oldstash) continue;
1092 stashentry && *stashentry
1093 && (substash = GvHV(*stashentry))
1095 || (oldsubstash && HvENAME_get(oldsubstash))
1098 /* Add :: and the key (minus the trailing ::)
1101 if(SvTYPE(namesv) == SVt_PVAV) {
1103 items = AvFILLp((AV *)namesv) + 1;
1104 svp = AvARRAY((AV *)namesv);
1105 subname = sv_2mortal((SV *)newAV());
1107 aname = newSVsv(*svp++);
1109 sv_catpvs(aname, ":");
1111 sv_catpvs(aname, "::");
1112 sv_catpvn(aname, key, len-2);
1114 av_push((AV *)subname, aname);
1118 subname = sv_2mortal(newSVsv(namesv));
1119 if (len == 1) sv_catpvs(subname, ":");
1121 sv_catpvs(subname, "::");
1122 sv_catpvn(subname, key, len-2);
1125 mro_gather_and_rename(
1126 stashes, seen_stashes,
1127 substash, oldsubstash, subname
1131 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
1137 /* Skip the entire loop if the hash is empty. */
1138 if (stash && HvUSEDKEYS(stash)) {
1139 xhv = (XPVHV*)SvANY(stash);
1142 /* Iterate through the new stash, skipping $seen{$key} items,
1143 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1144 while (++riter <= (I32)xhv->xhv_max) {
1145 entry = (HvARRAY(stash))[riter];
1147 /* Iterate through the entries in this list */
1148 for(; entry; entry = HeNEXT(entry)) {
1152 /* If this entry is not a glob, ignore it.
1154 if (!isGV(HeVAL(entry))) continue;
1156 key = hv_iterkey(entry, &len);
1157 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1158 || (len == 1 && key[0] == ':')) {
1161 /* If this entry was seen when we iterated through the
1162 oldstash, skip it. */
1163 if(seen && hv_exists(seen, key, len)) continue;
1165 /* We get here only if this stash has no corresponding
1166 entry in the stash being replaced. */
1168 substash = GvHV(HeVAL(entry));
1172 /* Avoid checking main::main::main::... */
1173 if(substash == stash) continue;
1175 /* Add :: and the key (minus the trailing ::)
1177 if(SvTYPE(namesv) == SVt_PVAV) {
1179 items = AvFILLp((AV *)namesv) + 1;
1180 svp = AvARRAY((AV *)namesv);
1181 subname = sv_2mortal((SV *)newAV());
1183 aname = newSVsv(*svp++);
1185 sv_catpvs(aname, ":");
1187 sv_catpvs(aname, "::");
1188 sv_catpvn(aname, key, len-2);
1190 av_push((AV *)subname, aname);
1194 subname = sv_2mortal(newSVsv(namesv));
1195 if (len == 1) sv_catpvs(subname, ":");
1197 sv_catpvs(subname, "::");
1198 sv_catpvn(subname, key, len-2);
1201 mro_gather_and_rename(
1202 stashes, seen_stashes,
1203 substash, NULL, subname
1213 =for apidoc mro_method_changed_in
1215 Invalidates method caching on any child classes
1216 of the given stash, so that they might notice
1217 the changes in this one.
1219 Ideally, all instances of C<PL_sub_generation++> in
1220 perl source outside of C<mro.c> should be
1221 replaced by calls to this.
1223 Perl automatically handles most of the common
1224 ways a method might be redefined. However, there
1225 are a few ways you could change a method in a stash
1226 without the cache code noticing, in which case you
1227 need to call this method afterwards:
1229 1) Directly manipulating the stash HV entries from
1232 2) Assigning a reference to a readonly scalar
1233 constant into a stash entry in order to create
1234 a constant subroutine (like constant.pm
1237 This same method is available from pure perl
1238 via, C<mro::method_changed_in(classname)>.
1243 Perl_mro_method_changed_in(pTHX_ HV *stash)
1245 const char * const stashname = HvENAME_get(stash);
1246 const STRLEN stashname_len = HvENAMELEN_get(stash);
1248 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
1249 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1251 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1254 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1256 /* Inc the package generation, since a local method changed */
1257 HvMROMETA(stash)->pkg_gen++;
1259 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1260 invalidate all method caches globally */
1261 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1262 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1263 PL_sub_generation++;
1267 /* else, invalidate the method caches of all child classes,
1272 hv_iterinit(isarev);
1273 while((iter = hv_iternext(isarev))) {
1275 const char* const revkey = hv_iterkey(iter, &len);
1276 HV* const revstash = gv_stashpvn(revkey, len, 0);
1277 struct mro_meta* mrometa;
1279 if(!revstash) continue;
1280 mrometa = HvMROMETA(revstash);
1281 mrometa->cache_gen++;
1282 if(mrometa->mro_nextmethod)
1283 hv_clear(mrometa->mro_nextmethod);
1289 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1291 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1293 PERL_ARGS_ASSERT_MRO_SET_MRO;
1296 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1298 if(meta->mro_which != which) {
1299 if (meta->mro_linear_current && !meta->mro_linear_all) {
1300 /* If we were storing something directly, put it in the hash before
1302 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1303 MUTABLE_SV(meta->mro_linear_current));
1305 meta->mro_which = which;
1306 /* Scrub our cached pointer to the private data. */
1307 meta->mro_linear_current = NULL;
1308 /* Only affects local method cache, not
1309 even child classes */
1311 if(meta->mro_nextmethod)
1312 hv_clear(meta->mro_nextmethod);
1318 XS(XS_mro_method_changed_in);
1321 Perl_boot_core_mro(pTHX)
1324 static const char file[] = __FILE__;
1326 Perl_mro_register(aTHX_ &dfs_alg);
1328 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1331 XS(XS_mro_method_changed_in)
1339 croak_xs_usage(cv, "classname");
1343 class_stash = gv_stashsv(classname, 0);
1344 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1346 mro_method_changed_in(class_stash);
1353 * c-indentation-style: bsd
1355 * indent-tabs-mode: t
1358 * ex: set ts=8 sts=4 sw=4 noet: