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 '%"SVf"'",
228 SVfARG(sv_2mortal(newSVhek(stashhek))));
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);
474 const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
476 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
479 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
482 /* wipe out the cached linearizations for this stash */
483 meta = HvMROMETA(stash);
486 /* Steal it for our own purposes. */
487 isa = (HV *)sv_2mortal((SV *)meta->isa);
491 /* Inc the package generation, since our @ISA changed */
494 /* Wipe the global method cache if this package
495 is UNIVERSAL or one of its parents */
497 svp = hv_fetch(PL_isarev, stashname,
498 stashname_utf8 ? -stashname_len : stashname_len, 0);
499 isarev = svp ? MUTABLE_HV(*svp) : NULL;
501 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
502 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
506 else { /* Wipe the local method cache otherwise */
508 is_universal = FALSE;
511 /* wipe next::method cache too */
512 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
514 /* Iterate the isarev (classes that are our children),
515 wiping out their linearization, method and isa caches
516 and upating PL_isarev. */
518 HV *isa_hashes = NULL;
520 /* We have to iterate through isarev twice to avoid a chicken and
521 * egg problem: if A inherits from B and both are in isarev, A might
522 * be processed before B and use B’s previous linearisation.
525 /* First iteration: Wipe everything, but stash away the isa hashes
526 * since we still need them for updating PL_isarev.
529 if(hv_iterinit(isarev)) {
530 /* Only create the hash if we need it; i.e., if isarev has
532 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
534 while((iter = hv_iternext(isarev))) {
535 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 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),
599 HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
604 if((SV *)isa != &PL_sv_undef)
606 isa, HEK_KEY(namehek), HEK_LEN(namehek),
607 HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
613 /* Now iterate our MRO (parents), adding ourselves and everything from
614 our isarev to their isarev.
617 /* We're starting at the 2nd element, skipping ourselves here */
618 linear_mro = mro_get_linear_isa(stash);
619 svp = AvARRAY(linear_mro) + 1;
620 items = AvFILLp(linear_mro);
623 SV* const sv = *svp++;
626 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
628 /* That fetch should not fail. But if it had to create a new SV for
629 us, then will need to upgrade it to an HV (which sv_upgrade() can
632 mroisarev = MUTABLE_HV(HeVAL(he));
634 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
636 /* This hash only ever contains PL_sv_yes. Storing it over itself is
637 almost as cheap as calling hv_exists, so on aggregate we expect to
638 save time by not making two calls to the common HV code for the
639 case where it doesn't exist. */
641 (void)hv_store(mroisarev, stashname,
642 stashname_utf8 ? -stashname_len : stashname_len, &PL_sv_yes, 0);
645 /* Delete our name from our former parents’ isarevs. */
646 if(isa && HvARRAY(isa))
647 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
648 (stashname_utf8 ? SVf_UTF8 : 0) );
651 /* Deletes name from all the isarev entries listed in isa */
653 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
654 const STRLEN len, HV * const exceptions, U32 flags)
658 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
660 /* Delete our name from our former parents’ isarevs. */
661 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
663 while((iter = hv_iternext(isa))) {
665 const char * const key = hv_iterkey(iter, &klen);
666 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
668 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
670 HV * const isarev = (HV *)*svp;
671 (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -len : len, G_DISCARD);
672 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
673 (void)hv_delete(PL_isarev, key,
674 HeKUTF8(iter) ? -klen : klen, G_DISCARD);
681 =for apidoc mro_package_moved
683 Call this function to signal to a stash that it has been assigned to
684 another spot in the stash hierarchy. C<stash> is the stash that has been
685 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
686 that is actually being assigned to.
688 This can also be called with a null first argument to
689 indicate that C<oldstash> has been deleted.
691 This function invalidates isa caches on the old stash, on all subpackages
692 nested inside it, and on the subclasses of all those, including
693 non-existent packages that have corresponding entries in C<stash>.
695 It also sets the effective names (C<HvENAME>) on all the stashes as
698 If the C<gv> is present and is not in the symbol table, then this function
699 simply returns. This checked will be skipped if C<flags & 1>.
704 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
705 const GV * const gv, U32 flags)
713 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
714 assert(stash || oldstash);
716 /* Determine the name(s) of the location that stash was assigned to
717 * or from which oldstash was removed.
719 * We cannot reliably use the name in oldstash, because it may have
720 * been deleted from the location in the symbol table that its name
721 * suggests, as in this case:
723 * $globref = \*foo::bar::;
724 * Symbol::delete_package("foo");
725 * *$globref = \%baz::;
726 * *$globref = *frelp::;
727 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
729 * So we get it from the gv. But, since the gv may no longer be in the
730 * symbol table, we check that first. The only reliable way to tell is
731 * to see whether its stash has an effective name and whether the gv
732 * resides in that stash under its name. That effective name may be
733 * different from what gv_fullname4 would use.
734 * If flags & 1, the caller has asked us to skip the check.
739 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
740 !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
741 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
745 assert(SvOOK(GvSTASH(gv)));
746 assert(GvNAMELEN(gv));
747 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
748 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
749 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
752 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
755 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
756 if (name_count < 0) ++namep, name_count = -name_count - 1;
758 if (name_count == 1) {
759 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
760 namesv = GvNAMELEN(gv) == 1
761 ? newSVpvs_flags(":", SVs_TEMP)
762 : newSVpvs_flags("", SVs_TEMP);
765 namesv = sv_2mortal(newSVhek(*namep));
766 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
767 else sv_catpvs(namesv, "::");
769 if (GvNAMELEN(gv) != 1) {
771 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
772 /* skip trailing :: */
773 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
779 namesv = sv_2mortal((SV *)newAV());
780 while (name_count--) {
781 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
782 aname = GvNAMELEN(gv) == 1
788 aname = newSVhek(*namep++);
789 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
790 else sv_catpvs(aname, "::");
792 if (GvNAMELEN(gv) != 1) {
794 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
795 /* skip trailing :: */
796 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
799 av_push((AV *)namesv, aname);
803 /* Get a list of all the affected classes. */
804 /* We cannot simply pass them all to mro_isa_changed_in to avoid
805 the list, as that function assumes that only one package has
806 changed. It does not work with:
808 @foo::ISA = qw( B B::B );
809 *B:: = delete $::{"A::"};
811 as neither B nor B::B can be updated before the other, since they
812 will reset caches on foo, which will see either B or B::B with the
813 wrong name. The names must be set on *all* affected stashes before
814 we do anything else. (And linearisations must be cleared, too.)
816 stashes = (HV *) sv_2mortal((SV *)newHV());
817 mro_gather_and_rename(
818 stashes, (HV *) sv_2mortal((SV *)newHV()),
819 stash, oldstash, namesv
822 /* Once the caches have been wiped on all the classes, call
823 mro_isa_changed_in on each. */
824 hv_iterinit(stashes);
825 while((iter = hv_iternext(stashes))) {
826 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
828 /* We have to restore the original meta->isa (that
829 mro_gather_and_rename set aside for us) this way, in case
830 one class in this list is a superclass of a another class
831 that we have already encountered. In such a case, meta->isa
832 will have been overwritten without old entries being deleted
834 struct mro_meta * const meta = HvMROMETA(stash);
835 if(meta->isa != (HV *)HeVAL(iter)){
836 SvREFCNT_dec(meta->isa);
838 = HeVAL(iter) == &PL_sv_yes
841 HeVAL(iter) = NULL; /* We donated our reference count. */
843 mro_isa_changed_in(stash);
849 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
850 HV *stash, HV *oldstash, SV *namesv)
856 const bool stash_had_name = stash && HvENAME(stash);
857 bool fetched_isarev = FALSE;
862 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
864 /* We use the seen_stashes hash to keep track of which packages have
865 been encountered so far. This must be separate from the main list of
866 stashes, as we need to distinguish between stashes being assigned
867 and stashes being replaced/deleted. (A nested stash can be on both
868 sides of an assignment. We cannot simply skip iterating through a
869 stash on the right if we have seen it on the left, as it will not
870 get its ename assigned to it.)
872 To avoid allocating extra SVs, instead of a bitfield we can make
873 bizarre use of immortals:
875 &PL_sv_undef: seen on the left (oldstash)
876 &PL_sv_no : seen on the right (stash)
877 &PL_sv_yes : seen on both sides
882 /* Add to the big list. */
883 struct mro_meta * meta;
887 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
888 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
890 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
895 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
896 meta = HvMROMETA(oldstash);
899 stashes, (const char *)&oldstash, sizeof(HV *),
901 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
907 /* Update the effective name. */
908 if(HvENAME_get(oldstash)) {
909 const HEK * const enamehek = HvENAME_HEK(oldstash);
910 if(SvTYPE(namesv) == SVt_PVAV) {
911 items = AvFILLp((AV *)namesv) + 1;
912 svp = AvARRAY((AV *)namesv);
919 const U32 name_utf8 = SvUTF8(*svp);
921 const char *name = SvPVx_const(*svp++, len);
923 (void)hv_delete(PL_stashcache, name, name_utf8 ? -len : len, G_DISCARD);
924 hv_ename_delete(oldstash, name, len, name_utf8);
926 if (!fetched_isarev) {
927 /* If the name deletion caused a name change, then we
928 * are not going to call mro_isa_changed_in with this
929 * name (and not at all if it has become anonymous) so
930 * we need to delete old isarev entries here, both
931 * those in the superclasses and this class’s own list
932 * of subclasses. We simply delete the latter from
933 * PL_isarev, since we still need it. hv_delete morti-
934 * fies it for us, so sv_2mortal is not necessary. */
935 if(HvENAME_HEK(oldstash) != enamehek) {
936 if(meta->isa && HvARRAY(meta->isa))
937 mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
938 isarev = (HV *)hv_delete(PL_isarev, name,
939 name_utf8 ? -len : len, 0);
948 if(SvTYPE(namesv) == SVt_PVAV) {
949 items = AvFILLp((AV *)namesv) + 1;
950 svp = AvARRAY((AV *)namesv);
957 const U32 name_utf8 = SvUTF8(*svp);
959 const char *name = SvPVx_const(*svp++, len);
960 hv_ename_add(stash, name, len, name_utf8);
963 /* Add it to the big list if it needs
964 * mro_isa_changed_in called on it. That happens if it was
965 * detached from the symbol table (so it had no HvENAME) before
966 * being assigned to the spot named by the ‘name’ variable, because
967 * its cached isa linearisation is now stale (the effective name
968 * having changed), and subclasses will then use that cache when
969 * mro_package_moved calls mro_isa_changed_in. (See
972 * If it did have a name, then its previous name is still
973 * used in isa caches, and there is no need for
974 * mro_package_moved to call mro_isa_changed_in.
980 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
981 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
983 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
987 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
990 struct mro_meta * const meta = HvMROMETA(stash);
993 stashes, (const char *)&stash, sizeof(HV *),
995 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1004 if(!stash && !oldstash)
1005 /* Both stashes have been encountered already. */
1008 /* Add all the subclasses to the big list. */
1009 if(!fetched_isarev) {
1010 /* If oldstash is not null, then we can use its HvENAME to look up
1011 the isarev hash, since all its subclasses will be listed there.
1012 It will always have an HvENAME. It the HvENAME was removed
1013 above, then fetch_isarev will be true, and this code will not be
1016 If oldstash is null, then this is an empty spot with no stash in
1017 it, so subclasses could be listed in isarev hashes belonging to
1018 any of the names, so we have to check all of them.
1020 assert(!oldstash || HvENAME(oldstash));
1022 /* Extra variable to avoid a compiler warning */
1023 char * const hvename = HvENAME(oldstash);
1024 fetched_isarev = TRUE;
1025 svp = hv_fetch(PL_isarev, hvename,
1026 HvENAMEUTF8(oldstash)
1027 ? -HvENAMELEN_get(oldstash)
1028 : HvENAMELEN_get(oldstash), 0);
1029 if (svp) isarev = MUTABLE_HV(*svp);
1031 else if(SvTYPE(namesv) == SVt_PVAV) {
1032 items = AvFILLp((AV *)namesv) + 1;
1033 svp = AvARRAY((AV *)namesv);
1041 isarev || !fetched_isarev
1043 while (fetched_isarev || items--) {
1046 if (!fetched_isarev) {
1047 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1048 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1051 hv_iterinit(isarev);
1052 while((iter = hv_iternext(isarev))) {
1053 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1054 struct mro_meta * meta;
1056 if(!revstash) continue;
1057 meta = HvMROMETA(revstash);
1060 stashes, (const char *)&revstash, sizeof(HV *),
1062 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1069 if (fetched_isarev) break;
1073 /* This is partly based on code in hv_iternext_flags. We are not call-
1074 ing that here, as we want to avoid resetting the hash iterator. */
1076 /* Skip the entire loop if the hash is empty. */
1077 if(oldstash && HvUSEDKEYS(oldstash)) {
1078 xhv = (XPVHV*)SvANY(oldstash);
1079 seen = (HV *) sv_2mortal((SV *)newHV());
1081 /* Iterate through entries in the oldstash, adding them to the
1082 list, meanwhile doing the equivalent of $seen{$key} = 1.
1085 while (++riter <= (I32)xhv->xhv_max) {
1086 entry = (HvARRAY(oldstash))[riter];
1088 /* Iterate through the entries in this list */
1089 for(; entry; entry = HeNEXT(entry)) {
1094 /* If this entry is not a glob, ignore it.
1096 if (!isGV(HeVAL(entry))) continue;
1098 keysv = hv_iterkeysv(entry);
1099 key = SvPV_const(keysv, len);
1100 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1101 || (len == 1 && key[0] == ':')) {
1102 HV * const oldsubstash = GvHV(HeVAL(entry));
1103 SV ** const stashentry
1104 = stash ? hv_fetch(stash, key, SvUTF8(keysv) ? -len : len, 0) : NULL;
1105 HV *substash = NULL;
1107 /* Avoid main::main::main::... */
1108 if(oldsubstash == oldstash) continue;
1112 stashentry && *stashentry
1113 && (substash = GvHV(*stashentry))
1115 || (oldsubstash && HvENAME_get(oldsubstash))
1118 /* Add :: and the key (minus the trailing ::)
1121 if(SvTYPE(namesv) == SVt_PVAV) {
1123 items = AvFILLp((AV *)namesv) + 1;
1124 svp = AvARRAY((AV *)namesv);
1125 subname = sv_2mortal((SV *)newAV());
1127 aname = newSVsv(*svp++);
1129 sv_catpvs(aname, ":");
1131 sv_catpvs(aname, "::");
1135 ? SV_CATUTF8 : SV_CATBYTES
1138 av_push((AV *)subname, aname);
1142 subname = sv_2mortal(newSVsv(namesv));
1143 if (len == 1) sv_catpvs(subname, ":");
1145 sv_catpvs(subname, "::");
1147 subname, key, len-2,
1148 SvUTF8(keysv) ? SV_CATUTF8 : SV_CATBYTES
1152 mro_gather_and_rename(
1153 stashes, seen_stashes,
1154 substash, oldsubstash, subname
1158 (void)hv_store(seen, key, SvUTF8(keysv) ? -len : len, &PL_sv_yes, 0);
1164 /* Skip the entire loop if the hash is empty. */
1165 if (stash && HvUSEDKEYS(stash)) {
1166 xhv = (XPVHV*)SvANY(stash);
1169 /* Iterate through the new stash, skipping $seen{$key} items,
1170 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1171 while (++riter <= (I32)xhv->xhv_max) {
1172 entry = (HvARRAY(stash))[riter];
1174 /* Iterate through the entries in this list */
1175 for(; entry; entry = HeNEXT(entry)) {
1180 /* If this entry is not a glob, ignore it.
1182 if (!isGV(HeVAL(entry))) continue;
1184 keysv = hv_iterkeysv(entry);
1185 key = SvPV_const(keysv, len);
1186 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1187 || (len == 1 && key[0] == ':')) {
1190 /* If this entry was seen when we iterated through the
1191 oldstash, skip it. */
1192 if(seen && hv_exists(seen, key, SvUTF8(keysv) ? -len : len)) continue;
1194 /* We get here only if this stash has no corresponding
1195 entry in the stash being replaced. */
1197 substash = GvHV(HeVAL(entry));
1201 /* Avoid checking main::main::main::... */
1202 if(substash == stash) continue;
1204 /* Add :: and the key (minus the trailing ::)
1206 if(SvTYPE(namesv) == SVt_PVAV) {
1208 items = AvFILLp((AV *)namesv) + 1;
1209 svp = AvARRAY((AV *)namesv);
1210 subname = sv_2mortal((SV *)newAV());
1212 aname = newSVsv(*svp++);
1214 sv_catpvs(aname, ":");
1216 sv_catpvs(aname, "::");
1220 ? SV_CATUTF8 : SV_CATBYTES
1223 av_push((AV *)subname, aname);
1227 subname = sv_2mortal(newSVsv(namesv));
1228 if (len == 1) sv_catpvs(subname, ":");
1230 sv_catpvs(subname, "::");
1232 subname, key, len-2,
1233 SvUTF8(keysv) ? SV_CATUTF8 : SV_CATBYTES
1237 mro_gather_and_rename(
1238 stashes, seen_stashes,
1239 substash, NULL, subname
1249 =for apidoc mro_method_changed_in
1251 Invalidates method caching on any child classes
1252 of the given stash, so that they might notice
1253 the changes in this one.
1255 Ideally, all instances of C<PL_sub_generation++> in
1256 perl source outside of C<mro.c> should be
1257 replaced by calls to this.
1259 Perl automatically handles most of the common
1260 ways a method might be redefined. However, there
1261 are a few ways you could change a method in a stash
1262 without the cache code noticing, in which case you
1263 need to call this method afterwards:
1265 1) Directly manipulating the stash HV entries from
1268 2) Assigning a reference to a readonly scalar
1269 constant into a stash entry in order to create
1270 a constant subroutine (like constant.pm
1273 This same method is available from pure perl
1274 via, C<mro::method_changed_in(classname)>.
1279 Perl_mro_method_changed_in(pTHX_ HV *stash)
1281 const char * const stashname = HvENAME_get(stash);
1282 const STRLEN stashname_len = HvENAMELEN_get(stash);
1283 const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
1285 SV ** const svp = hv_fetch(PL_isarev, stashname,
1286 stashname_utf8 ? -stashname_len : stashname_len, 0);
1287 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1289 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1292 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1294 /* Inc the package generation, since a local method changed */
1295 HvMROMETA(stash)->pkg_gen++;
1297 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1298 invalidate all method caches globally */
1299 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1300 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1301 PL_sub_generation++;
1305 /* else, invalidate the method caches of all child classes,
1310 hv_iterinit(isarev);
1311 while((iter = hv_iternext(isarev))) {
1312 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1313 struct mro_meta* mrometa;
1315 if(!revstash) continue;
1316 mrometa = HvMROMETA(revstash);
1317 mrometa->cache_gen++;
1318 if(mrometa->mro_nextmethod)
1319 hv_clear(mrometa->mro_nextmethod);
1325 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1327 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1329 PERL_ARGS_ASSERT_MRO_SET_MRO;
1332 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1334 if(meta->mro_which != which) {
1335 if (meta->mro_linear_current && !meta->mro_linear_all) {
1336 /* If we were storing something directly, put it in the hash before
1338 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1339 MUTABLE_SV(meta->mro_linear_current));
1341 meta->mro_which = which;
1342 /* Scrub our cached pointer to the private data. */
1343 meta->mro_linear_current = NULL;
1344 /* Only affects local method cache, not
1345 even child classes */
1347 if(meta->mro_nextmethod)
1348 hv_clear(meta->mro_nextmethod);
1354 XS(XS_mro_method_changed_in);
1357 Perl_boot_core_mro(pTHX)
1360 static const char file[] = __FILE__;
1362 Perl_mro_register(aTHX_ &dfs_alg);
1364 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1367 XS(XS_mro_method_changed_in)
1375 croak_xs_usage(cv, "classname");
1379 class_stash = gv_stashsv(classname, 0);
1380 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1382 mro_method_changed_in(class_stash);
1389 * c-indentation-style: bsd
1391 * indent-tabs-mode: t
1394 * ex: set ts=8 sts=4 sw=4 noet: