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.
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"]
20 These functions are related to the method resolution order of perl classes
29 static const struct mro_alg dfs_alg =
30 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
33 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
34 const struct mro_alg *const which)
37 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
39 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
40 which->name, which->length, which->kflags,
41 HV_FETCH_JUST_SV, NULL, which->hash);
45 /* If we've been asked to look up the private data for the current MRO, then
47 if (smeta->mro_which == which)
48 smeta->mro_linear_current = *data;
54 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
55 const struct mro_alg *const which, SV *const data)
57 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
59 if (!smeta->mro_linear_all) {
60 if (smeta->mro_which == which) {
61 /* If all we need to store is the current MRO's data, then don't use
62 memory on a hash with 1 element - store it direct, and signal
63 this by leaving the would-be-hash NULL. */
64 smeta->mro_linear_current = data;
67 HV *const hv = newHV();
68 /* Start with 2 buckets. It's unlikely we'll need more. */
70 smeta->mro_linear_all = hv;
72 if (smeta->mro_linear_current) {
73 /* If we were storing something directly, put it in the hash
75 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
76 smeta->mro_linear_current);
81 /* We get here if we're storing more than one linearisation for this stash,
82 or the linearisation we are storing is not that if its current MRO. */
84 if (smeta->mro_which == which) {
85 /* If we've been asked to store the private data for the current MRO,
87 smeta->mro_linear_current = data;
90 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
91 which->name, which->length, which->kflags,
92 HV_FETCH_ISSTORE, data, which->hash)) {
93 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
94 "for '%.*s' %d", (int) which->length, which->name,
101 const struct mro_alg *
102 Perl_mro_get_from_name(pTHX_ SV *name) {
105 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
107 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
108 HV_FETCH_JUST_SV, NULL, 0);
111 assert(SvTYPE(*data) == SVt_IV);
112 assert(SvIOK(*data));
113 return INT2PTR(const struct mro_alg *, SvUVX(*data));
117 =for apidoc mro_register
118 Registers a custom mro plugin. See L<perlmroapi> for details.
124 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
125 SV *wrapper = newSVuv(PTR2UV(mro));
127 PERL_ARGS_ASSERT_MRO_REGISTER;
130 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
131 mro->name, mro->length, mro->kflags,
132 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
133 SvREFCNT_dec_NN(wrapper);
134 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
135 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
140 Perl_mro_meta_init(pTHX_ HV* stash)
142 struct mro_meta* newmeta;
144 PERL_ARGS_ASSERT_MRO_META_INIT;
146 assert(HvAUX(stash));
147 assert(!(HvAUX(stash)->xhv_mro_meta));
148 Newxz(newmeta, 1, struct mro_meta);
149 HvAUX(stash)->xhv_mro_meta = newmeta;
150 newmeta->cache_gen = 1;
151 newmeta->pkg_gen = 1;
152 newmeta->mro_which = &dfs_alg;
157 #if defined(USE_ITHREADS)
159 /* for sv_dup on new threads */
161 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
163 struct mro_meta* newmeta;
165 PERL_ARGS_ASSERT_MRO_META_DUP;
167 Newx(newmeta, 1, struct mro_meta);
168 Copy(smeta, newmeta, 1, struct mro_meta);
170 if (newmeta->mro_linear_all) {
171 newmeta->mro_linear_all
172 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
173 /* This is just acting as a shortcut pointer, and will be automatically
174 updated on the first get. */
175 newmeta->mro_linear_current = NULL;
176 } else if (newmeta->mro_linear_current) {
177 /* Only the current MRO is stored, so this owns the data. */
178 newmeta->mro_linear_current
179 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
182 if (newmeta->mro_nextmethod)
183 newmeta->mro_nextmethod
184 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
187 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
189 newmeta->super = NULL;
194 #endif /* USE_ITHREADS */
197 =for apidoc mro_get_linear_isa_dfs
199 Returns the Depth-First Search linearization of @ISA
200 the given stash. The return value is a read-only AV*.
201 C<level> should be 0 (it is used internally in this
202 function's recursion).
204 You are responsible for C<SvREFCNT_inc()> on the
205 return value if you plan to store it anywhere
206 semi-permanently (otherwise it might be deleted
207 out from under you the next time the cache is
213 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
220 struct mro_meta* meta;
224 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
225 assert(HvAUX(stash));
228 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
229 ? HvENAME_HEK_NN(stash)
233 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
237 "Recursive inheritance detected in package '%"HEKf"'",
240 meta = HvMROMETA(stash);
242 /* return cache if valid */
243 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
247 /* not in cache, make a new one */
249 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
250 /* We use this later in this function, but don't need a reference to it
251 beyond the end of this function, so reference count is fine. */
252 our_name = newSVhek(stashhek);
253 av_push(retval, our_name); /* add ourselves at the top */
256 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
257 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
259 /* "stored" is used to keep track of all of the classnames we have added to
260 the MRO so far, so we can do a quick exists check and avoid adding
261 duplicate classnames to the MRO as we go.
262 It's then retained to be re-used as a fast lookup for ->isa(), by adding
263 our own name and "UNIVERSAL" to it. */
265 if(av && AvFILLp(av) >= 0) {
267 SV **svp = AvARRAY(av);
268 I32 items = AvFILLp(av) + 1;
272 SV* const sv = *svp ? *svp : &PL_sv_undef;
273 HV* const basestash = gv_stashsv(sv, 0);
279 /* if no stash exists for this @ISA member,
280 simply add it to the MRO and move on */
285 /* otherwise, recurse into ourselves for the MRO
286 of this @ISA member, and append their MRO to ours.
287 The recursive call could throw an exception, which
288 has memory management implications here, hence the use of
290 const AV *const subrv
291 = mro_get_linear_isa_dfs(basestash, level + 1);
293 subrv_p = AvARRAY(subrv);
294 subrv_items = AvFILLp(subrv) + 1;
297 while(subrv_items--) {
298 SV *const subsv = *subrv_p++;
299 /* LVALUE fetch will create a new undefined SV if necessary
301 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
303 if(HeVAL(he) != &PL_sv_undef) {
304 /* It was newly created. Steal it for our new SV, and
305 replace it in the hash with the "real" thing. */
306 SV *const val = HeVAL(he);
307 HEK *const key = HeKEY_hek(he);
309 HeVAL(he) = &PL_sv_undef;
311 av_push(retval, val);
315 /* We are the first (or only) parent. We can short cut the
316 complexity above, because our @ISA is simply us prepended
317 to our parent's @ISA, and our ->isa cache is simply our
318 parent's, with our name added. */
319 /* newSVsv() is slow. This code is only faster if we can avoid
320 it by ensuring that SVs in the arrays are shared hash key
321 scalar SVs, because we can "copy" them very efficiently.
322 Although to be fair, we can't *ensure* this, as a reference
323 to the internal array is returned by mro::get_linear_isa(),
324 so we'll have to be defensive just in case someone faffed
328 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
329 av_extend(retval, subrv_items);
330 AvFILLp(retval) = subrv_items;
331 svp = AvARRAY(retval);
332 while(subrv_items--) {
333 SV *const val = *subrv_p++;
334 *++svp = SvIsCOW_shared_hash(val)
335 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
339 /* They have no stash. So create ourselves an ->isa cache
340 as if we'd copied it from what theirs should be. */
341 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
342 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
344 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
350 /* We have no parents. */
351 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
352 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
355 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
357 SvREFCNT_inc_simple_void_NN(stored);
359 SvREADONLY_on(stored);
363 /* now that we're past the exception dangers, grab our own reference to
364 the AV we're about to use for the result. The reference owned by the
365 mortals' stack will be released soon, so everything will balance. */
366 SvREFCNT_inc_simple_void_NN(retval);
369 /* we don't want anyone modifying the cache entry but us,
370 and we do so by replacing it completely */
371 SvREADONLY_on(retval);
373 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
374 MUTABLE_SV(retval)));
378 =for apidoc mro_get_linear_isa
380 Returns the mro linearisation for the given stash. By default, this
381 will be whatever C<mro_get_linear_isa_dfs> returns unless some
382 other MRO is in effect for the stash. The return value is a
385 You are responsible for C<SvREFCNT_inc()> on the
386 return value if you plan to store it anywhere
387 semi-permanently (otherwise it might be deleted
388 out from under you the next time the cache is
394 Perl_mro_get_linear_isa(pTHX_ HV *stash)
396 struct mro_meta* meta;
399 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
401 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
403 meta = HvMROMETA(stash);
404 if (!meta->mro_which)
405 Perl_croak(aTHX_ "panic: invalid MRO!");
406 isa = meta->mro_which->resolve(aTHX_ stash, 0);
408 if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
410 (HvENAME(stash)||HvNAME(stash))
411 ? newSVhek(HvENAME_HEK(stash)
416 if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
418 AV * const old = isa;
420 SV **ovp = AvARRAY(old);
421 SV * const * const oend = ovp + AvFILLp(old) + 1;
422 isa = (AV *)sv_2mortal((SV *)newAV());
423 av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
424 *AvARRAY(isa) = namesv;
425 svp = AvARRAY(isa)+1;
426 while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
428 else SvREFCNT_dec(namesv);
432 HV *const isa_hash = newHV();
433 /* Linearisation didn't build it for us, so do it here. */
434 SV *const *svp = AvARRAY(isa);
435 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
436 const HEK *canon_name = HvENAME_HEK(stash);
437 if (!canon_name) canon_name = HvNAME_HEK(stash);
439 while (svp < svp_end) {
440 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
443 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
444 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
445 HV_FETCH_ISSTORE, &PL_sv_undef,
446 HEK_HASH(canon_name));
447 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
449 SvREADONLY_on(isa_hash);
451 meta->isa = isa_hash;
458 =for apidoc mro_isa_changed_in
460 Takes the necessary steps (cache invalidations, mostly)
461 when the @ISA of the given package has changed. Invoked
462 by the C<setisa> magic, should not need to invoke directly.
467 /* Macro to avoid repeating the code five times. */
468 #define CLEAR_LINEAR(mEta) \
469 if (mEta->mro_linear_all) { \
470 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
471 mEta->mro_linear_all = NULL; \
472 /* This is just acting as a shortcut pointer. */ \
473 mEta->mro_linear_current = NULL; \
474 } else if (mEta->mro_linear_current) { \
475 /* Only the current MRO is stored, so this owns the data. */ \
476 SvREFCNT_dec(mEta->mro_linear_current); \
477 mEta->mro_linear_current = NULL; \
481 Perl_mro_isa_changed_in(pTHX_ HV* stash)
489 struct mro_meta * meta;
492 const HEK * const stashhek = HvENAME_HEK(stash);
493 const char * const stashname = HvENAME_get(stash);
494 const STRLEN stashname_len = HvENAMELEN_get(stash);
496 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
499 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
502 /* wipe out the cached linearizations for this stash */
503 meta = HvMROMETA(stash);
506 /* Steal it for our own purposes. */
507 isa = (HV *)sv_2mortal((SV *)meta->isa);
511 /* Inc the package generation, since our @ISA changed */
514 /* Wipe the global method cache if this package
515 is UNIVERSAL or one of its parents */
517 svp = hv_fetchhek(PL_isarev, stashhek, 0);
518 isarev = svp ? MUTABLE_HV(*svp) : NULL;
520 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
521 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
525 else { /* Wipe the local method cache otherwise */
527 is_universal = FALSE;
530 /* wipe next::method cache too */
531 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
533 /* Changes to @ISA might turn overloading on */
535 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
536 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
538 /* DESTROY can be cached in SvSTASH. */
539 if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
541 /* Iterate the isarev (classes that are our children),
542 wiping out their linearization, method and isa caches
543 and upating PL_isarev. */
545 HV *isa_hashes = NULL;
547 /* We have to iterate through isarev twice to avoid a chicken and
548 * egg problem: if A inherits from B and both are in isarev, A might
549 * be processed before B and use B's previous linearisation.
552 /* First iteration: Wipe everything, but stash away the isa hashes
553 * since we still need them for updating PL_isarev.
556 if(hv_iterinit(isarev)) {
557 /* Only create the hash if we need it; i.e., if isarev has
559 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
561 while((iter = hv_iternext(isarev))) {
562 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
563 struct mro_meta* revmeta;
565 if(!revstash) continue;
566 revmeta = HvMROMETA(revstash);
567 CLEAR_LINEAR(revmeta);
569 revmeta->cache_gen++;
570 if(revmeta->mro_nextmethod)
571 hv_clear(revmeta->mro_nextmethod);
572 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
576 isa_hashes, (const char*)&revstash, sizeof(HV *),
577 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
582 /* Second pass: Update PL_isarev. We can just use isa_hashes to
583 * avoid another round of stash lookups. */
585 /* isarev might be deleted from PL_isarev during this loop, so hang
587 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
590 hv_iterinit(isa_hashes);
591 while((iter = hv_iternext(isa_hashes))) {
592 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
593 HV * const isa = (HV *)HeVAL(iter);
596 /* We're starting at the 2nd element, skipping revstash */
597 linear_mro = mro_get_linear_isa(revstash);
598 svp = AvARRAY(linear_mro) + 1;
599 items = AvFILLp(linear_mro);
601 namehek = HvENAME_HEK(revstash);
602 if (!namehek) namehek = HvNAME_HEK(revstash);
605 SV* const sv = *svp++;
608 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
610 /* That fetch should not fail. But if it had to create
611 a new SV for us, then will need to upgrade it to an
612 HV (which sv_upgrade() can now do for us). */
614 mroisarev = MUTABLE_HV(HeVAL(he));
616 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
618 /* This hash only ever contains PL_sv_yes. Storing it
619 over itself is almost as cheap as calling hv_exists,
620 so on aggregate we expect to save time by not making
621 two calls to the common HV code for the case where
625 hv_storehek(mroisarev, namehek, &PL_sv_yes);
628 if ((SV *)isa != &PL_sv_undef) {
631 isa, HEK_KEY(namehek), HEK_LEN(namehek),
632 HvMROMETA(revstash)->isa, HEK_HASH(namehek),
640 /* Now iterate our MRO (parents), adding ourselves and everything from
641 our isarev to their isarev.
644 /* We're starting at the 2nd element, skipping ourselves here */
645 linear_mro = mro_get_linear_isa(stash);
646 svp = AvARRAY(linear_mro) + 1;
647 items = AvFILLp(linear_mro);
650 SV* const sv = *svp++;
653 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
655 /* That fetch should not fail. But if it had to create a new SV for
656 us, then will need to upgrade it to an HV (which sv_upgrade() can
659 mroisarev = MUTABLE_HV(HeVAL(he));
661 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
663 /* This hash only ever contains PL_sv_yes. Storing it over itself is
664 almost as cheap as calling hv_exists, so on aggregate we expect to
665 save time by not making two calls to the common HV code for the
666 case where it doesn't exist. */
668 (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
671 /* Delete our name from our former parents' isarevs. */
672 if(isa && HvARRAY(isa))
673 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
674 HEK_HASH(stashhek), HEK_UTF8(stashhek));
677 /* Deletes name from all the isarev entries listed in isa */
679 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
680 const STRLEN len, HV * const exceptions, U32 hash,
685 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
687 /* Delete our name from our former parents' isarevs. */
688 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
690 while((iter = hv_iternext(isa))) {
692 const char * const key = hv_iterkey(iter, &klen);
693 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
695 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
697 HV * const isarev = (HV *)*svp;
698 (void)hv_common(isarev, NULL, name, len, flags,
699 G_DISCARD|HV_DELETE, NULL, hash);
700 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
701 (void)hv_delete(PL_isarev, key,
702 HeKUTF8(iter) ? -klen : klen, G_DISCARD);
709 =for apidoc mro_package_moved
711 Call this function to signal to a stash that it has been assigned to
712 another spot in the stash hierarchy. C<stash> is the stash that has been
713 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
714 that is actually being assigned to.
716 This can also be called with a null first argument to
717 indicate that C<oldstash> has been deleted.
719 This function invalidates isa caches on the old stash, on all subpackages
720 nested inside it, and on the subclasses of all those, including
721 non-existent packages that have corresponding entries in C<stash>.
723 It also sets the effective names (C<HvENAME>) on all the stashes as
726 If the C<gv> is present and is not in the symbol table, then this function
727 simply returns. This checked will be skipped if C<flags & 1>.
732 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
733 const GV * const gv, U32 flags)
741 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
742 assert(stash || oldstash);
744 /* Determine the name(s) of the location that stash was assigned to
745 * or from which oldstash was removed.
747 * We cannot reliably use the name in oldstash, because it may have
748 * been deleted from the location in the symbol table that its name
749 * suggests, as in this case:
751 * $globref = \*foo::bar::;
752 * Symbol::delete_package("foo");
753 * *$globref = \%baz::;
754 * *$globref = *frelp::;
755 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
757 * So we get it from the gv. But, since the gv may no longer be in the
758 * symbol table, we check that first. The only reliable way to tell is
759 * to see whether its stash has an effective name and whether the gv
760 * resides in that stash under its name. That effective name may be
761 * different from what gv_fullname4 would use.
762 * If flags & 1, the caller has asked us to skip the check.
767 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
768 !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
772 assert(SvOOK(GvSTASH(gv)));
773 assert(GvNAMELEN(gv));
774 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
775 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
776 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
779 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
782 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
783 if (name_count < 0) ++namep, name_count = -name_count - 1;
785 if (name_count == 1) {
786 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
787 namesv = GvNAMELEN(gv) == 1
788 ? newSVpvs_flags(":", SVs_TEMP)
789 : newSVpvs_flags("", SVs_TEMP);
792 namesv = sv_2mortal(newSVhek(*namep));
793 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
794 else sv_catpvs(namesv, "::");
796 if (GvNAMELEN(gv) != 1) {
798 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
799 /* skip trailing :: */
800 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
806 namesv = sv_2mortal((SV *)newAV());
807 while (name_count--) {
808 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
809 aname = GvNAMELEN(gv) == 1
815 aname = newSVhek(*namep++);
816 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
817 else sv_catpvs(aname, "::");
819 if (GvNAMELEN(gv) != 1) {
821 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
822 /* skip trailing :: */
823 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
826 av_push((AV *)namesv, aname);
830 /* Get a list of all the affected classes. */
831 /* We cannot simply pass them all to mro_isa_changed_in to avoid
832 the list, as that function assumes that only one package has
833 changed. It does not work with:
835 @foo::ISA = qw( B B::B );
836 *B:: = delete $::{"A::"};
838 as neither B nor B::B can be updated before the other, since they
839 will reset caches on foo, which will see either B or B::B with the
840 wrong name. The names must be set on *all* affected stashes before
841 we do anything else. (And linearisations must be cleared, too.)
843 stashes = (HV *) sv_2mortal((SV *)newHV());
844 mro_gather_and_rename(
845 stashes, (HV *) sv_2mortal((SV *)newHV()),
846 stash, oldstash, namesv
849 /* Once the caches have been wiped on all the classes, call
850 mro_isa_changed_in on each. */
851 hv_iterinit(stashes);
852 while((iter = hv_iternext(stashes))) {
853 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
855 /* We have to restore the original meta->isa (that
856 mro_gather_and_rename set aside for us) this way, in case
857 one class in this list is a superclass of a another class
858 that we have already encountered. In such a case, meta->isa
859 will have been overwritten without old entries being deleted
861 struct mro_meta * const meta = HvMROMETA(stash);
862 if(meta->isa != (HV *)HeVAL(iter)){
863 SvREFCNT_dec(meta->isa);
865 = HeVAL(iter) == &PL_sv_yes
868 HeVAL(iter) = NULL; /* We donated our reference count. */
870 mro_isa_changed_in(stash);
876 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
877 HV *stash, HV *oldstash, SV *namesv)
883 const bool stash_had_name = stash && HvENAME(stash);
884 bool fetched_isarev = FALSE;
889 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
891 /* We use the seen_stashes hash to keep track of which packages have
892 been encountered so far. This must be separate from the main list of
893 stashes, as we need to distinguish between stashes being assigned
894 and stashes being replaced/deleted. (A nested stash can be on both
895 sides of an assignment. We cannot simply skip iterating through a
896 stash on the right if we have seen it on the left, as it will not
897 get its ename assigned to it.)
899 To avoid allocating extra SVs, instead of a bitfield we can make
900 bizarre use of immortals:
902 &PL_sv_undef: seen on the left (oldstash)
903 &PL_sv_no : seen on the right (stash)
904 &PL_sv_yes : seen on both sides
909 /* Add to the big list. */
910 struct mro_meta * meta;
914 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
915 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
917 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
922 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
923 meta = HvMROMETA(oldstash);
926 stashes, (const char *)&oldstash, sizeof(HV *),
928 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
934 /* Update the effective name. */
935 if(HvENAME_get(oldstash)) {
936 const HEK * const enamehek = HvENAME_HEK(oldstash);
937 if(SvTYPE(namesv) == SVt_PVAV) {
938 items = AvFILLp((AV *)namesv) + 1;
939 svp = AvARRAY((AV *)namesv);
946 const U32 name_utf8 = SvUTF8(*svp);
948 const char *name = SvPVx_const(*svp, len);
950 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
952 (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
955 hv_ename_delete(oldstash, name, len, name_utf8);
957 if (!fetched_isarev) {
958 /* If the name deletion caused a name change, then we
959 * are not going to call mro_isa_changed_in with this
960 * name (and not at all if it has become anonymous) so
961 * we need to delete old isarev entries here, both
962 * those in the superclasses and this class's own list
963 * of subclasses. We simply delete the latter from
964 * PL_isarev, since we still need it. hv_delete morti-
965 * fies it for us, so sv_2mortal is not necessary. */
966 if(HvENAME_HEK(oldstash) != enamehek) {
967 if(meta->isa && HvARRAY(meta->isa))
968 mro_clean_isarev(meta->isa, name, len, 0, 0,
969 name_utf8 ? HVhek_UTF8 : 0);
970 isarev = (HV *)hv_delete(PL_isarev, name,
971 name_utf8 ? -(I32)len : (I32)len, 0);
980 if(SvTYPE(namesv) == SVt_PVAV) {
981 items = AvFILLp((AV *)namesv) + 1;
982 svp = AvARRAY((AV *)namesv);
989 const U32 name_utf8 = SvUTF8(*svp);
991 const char *name = SvPVx_const(*svp++, len);
992 hv_ename_add(stash, name, len, name_utf8);
995 /* Add it to the big list if it needs
996 * mro_isa_changed_in called on it. That happens if it was
997 * detached from the symbol table (so it had no HvENAME) before
998 * being assigned to the spot named by the 'name' variable, because
999 * its cached isa linearisation is now stale (the effective name
1000 * having changed), and subclasses will then use that cache when
1001 * mro_package_moved calls mro_isa_changed_in. (See
1004 * If it did have a name, then its previous name is still
1005 * used in isa caches, and there is no need for
1006 * mro_package_moved to call mro_isa_changed_in.
1012 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1013 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1015 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1019 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1022 struct mro_meta * const meta = HvMROMETA(stash);
1025 stashes, (const char *)&stash, sizeof(HV *),
1027 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1036 if(!stash && !oldstash)
1037 /* Both stashes have been encountered already. */
1040 /* Add all the subclasses to the big list. */
1041 if(!fetched_isarev) {
1042 /* If oldstash is not null, then we can use its HvENAME to look up
1043 the isarev hash, since all its subclasses will be listed there.
1044 It will always have an HvENAME. It the HvENAME was removed
1045 above, then fetch_isarev will be true, and this code will not be
1048 If oldstash is null, then this is an empty spot with no stash in
1049 it, so subclasses could be listed in isarev hashes belonging to
1050 any of the names, so we have to check all of them.
1052 assert(!oldstash || HvENAME(oldstash));
1054 /* Extra variable to avoid a compiler warning */
1055 const HEK * const hvename = HvENAME_HEK(oldstash);
1056 fetched_isarev = TRUE;
1057 svp = hv_fetchhek(PL_isarev, hvename, 0);
1058 if (svp) isarev = MUTABLE_HV(*svp);
1060 else if(SvTYPE(namesv) == SVt_PVAV) {
1061 items = AvFILLp((AV *)namesv) + 1;
1062 svp = AvARRAY((AV *)namesv);
1070 isarev || !fetched_isarev
1072 while (fetched_isarev || items--) {
1075 if (!fetched_isarev) {
1076 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1077 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1080 hv_iterinit(isarev);
1081 while((iter = hv_iternext(isarev))) {
1082 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1083 struct mro_meta * meta;
1085 if(!revstash) continue;
1086 meta = HvMROMETA(revstash);
1089 stashes, (const char *)&revstash, sizeof(HV *),
1091 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1098 if (fetched_isarev) break;
1102 /* This is partly based on code in hv_iternext_flags. We are not call-
1103 ing that here, as we want to avoid resetting the hash iterator. */
1105 /* Skip the entire loop if the hash is empty. */
1106 if(oldstash && HvUSEDKEYS(oldstash)) {
1107 xhv = (XPVHV*)SvANY(oldstash);
1108 seen = (HV *) sv_2mortal((SV *)newHV());
1110 /* Iterate through entries in the oldstash, adding them to the
1111 list, meanwhile doing the equivalent of $seen{$key} = 1.
1114 while (++riter <= (I32)xhv->xhv_max) {
1115 entry = (HvARRAY(oldstash))[riter];
1117 /* Iterate through the entries in this list */
1118 for(; entry; entry = HeNEXT(entry)) {
1122 /* If this entry is not a glob, ignore it.
1124 if (!isGV(HeVAL(entry))) continue;
1126 key = hv_iterkey(entry, &len);
1127 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1128 || (len == 1 && key[0] == ':')) {
1129 HV * const oldsubstash = GvHV(HeVAL(entry));
1130 SV ** const stashentry
1131 = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
1132 HV *substash = NULL;
1134 /* Avoid main::main::main::... */
1135 if(oldsubstash == oldstash) continue;
1139 stashentry && *stashentry && isGV(*stashentry)
1140 && (substash = GvHV(*stashentry))
1142 || (oldsubstash && HvENAME_get(oldsubstash))
1145 /* Add :: and the key (minus the trailing ::)
1148 if(SvTYPE(namesv) == SVt_PVAV) {
1150 items = AvFILLp((AV *)namesv) + 1;
1151 svp = AvARRAY((AV *)namesv);
1152 subname = sv_2mortal((SV *)newAV());
1154 aname = newSVsv(*svp++);
1156 sv_catpvs(aname, ":");
1158 sv_catpvs(aname, "::");
1162 ? SV_CATUTF8 : SV_CATBYTES
1165 av_push((AV *)subname, aname);
1169 subname = sv_2mortal(newSVsv(namesv));
1170 if (len == 1) sv_catpvs(subname, ":");
1172 sv_catpvs(subname, "::");
1174 subname, key, len-2,
1175 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1179 mro_gather_and_rename(
1180 stashes, seen_stashes,
1181 substash, oldsubstash, subname
1185 (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
1191 /* Skip the entire loop if the hash is empty. */
1192 if (stash && HvUSEDKEYS(stash)) {
1193 xhv = (XPVHV*)SvANY(stash);
1196 /* Iterate through the new stash, skipping $seen{$key} items,
1197 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1198 while (++riter <= (I32)xhv->xhv_max) {
1199 entry = (HvARRAY(stash))[riter];
1201 /* Iterate through the entries in this list */
1202 for(; entry; entry = HeNEXT(entry)) {
1206 /* If this entry is not a glob, ignore it.
1208 if (!isGV(HeVAL(entry))) continue;
1210 key = hv_iterkey(entry, &len);
1211 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1212 || (len == 1 && key[0] == ':')) {
1215 /* If this entry was seen when we iterated through the
1216 oldstash, skip it. */
1217 if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
1219 /* We get here only if this stash has no corresponding
1220 entry in the stash being replaced. */
1222 substash = GvHV(HeVAL(entry));
1226 /* Avoid checking main::main::main::... */
1227 if(substash == stash) continue;
1229 /* Add :: and the key (minus the trailing ::)
1231 if(SvTYPE(namesv) == SVt_PVAV) {
1233 items = AvFILLp((AV *)namesv) + 1;
1234 svp = AvARRAY((AV *)namesv);
1235 subname = sv_2mortal((SV *)newAV());
1237 aname = newSVsv(*svp++);
1239 sv_catpvs(aname, ":");
1241 sv_catpvs(aname, "::");
1245 ? SV_CATUTF8 : SV_CATBYTES
1248 av_push((AV *)subname, aname);
1252 subname = sv_2mortal(newSVsv(namesv));
1253 if (len == 1) sv_catpvs(subname, ":");
1255 sv_catpvs(subname, "::");
1257 subname, key, len-2,
1258 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1262 mro_gather_and_rename(
1263 stashes, seen_stashes,
1264 substash, NULL, subname
1274 =for apidoc mro_method_changed_in
1276 Invalidates method caching on any child classes
1277 of the given stash, so that they might notice
1278 the changes in this one.
1280 Ideally, all instances of C<PL_sub_generation++> in
1281 perl source outside of F<mro.c> should be
1282 replaced by calls to this.
1284 Perl automatically handles most of the common
1285 ways a method might be redefined. However, there
1286 are a few ways you could change a method in a stash
1287 without the cache code noticing, in which case you
1288 need to call this method afterwards:
1290 1) Directly manipulating the stash HV entries from
1293 2) Assigning a reference to a readonly scalar
1294 constant into a stash entry in order to create
1295 a constant subroutine (like constant.pm
1298 This same method is available from pure perl
1299 via, C<mro::method_changed_in(classname)>.
1304 Perl_mro_method_changed_in(pTHX_ HV *stash)
1306 const char * const stashname = HvENAME_get(stash);
1307 const STRLEN stashname_len = HvENAMELEN_get(stash);
1309 SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
1310 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1312 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1315 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1317 /* Inc the package generation, since a local method changed */
1318 HvMROMETA(stash)->pkg_gen++;
1320 /* DESTROY can be cached in SvSTASH. */
1321 if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
1323 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1324 invalidate all method caches globally */
1325 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1326 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1327 PL_sub_generation++;
1331 /* else, invalidate the method caches of all child classes,
1336 hv_iterinit(isarev);
1337 while((iter = hv_iternext(isarev))) {
1338 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1339 struct mro_meta* mrometa;
1341 if(!revstash) continue;
1342 mrometa = HvMROMETA(revstash);
1343 mrometa->cache_gen++;
1344 if(mrometa->mro_nextmethod)
1345 hv_clear(mrometa->mro_nextmethod);
1346 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
1350 /* The method change may be due to *{$package . "::()"} = \&nil; in
1353 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
1354 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
1358 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1360 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1362 PERL_ARGS_ASSERT_MRO_SET_MRO;
1365 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1367 if(meta->mro_which != which) {
1368 if (meta->mro_linear_current && !meta->mro_linear_all) {
1369 /* If we were storing something directly, put it in the hash before
1371 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1372 MUTABLE_SV(meta->mro_linear_current));
1374 meta->mro_which = which;
1375 /* Scrub our cached pointer to the private data. */
1376 meta->mro_linear_current = NULL;
1377 /* Only affects local method cache, not
1378 even child classes */
1380 if(meta->mro_nextmethod)
1381 hv_clear(meta->mro_nextmethod);
1387 XS(XS_mro_method_changed_in);
1390 Perl_boot_core_mro(pTHX)
1392 static const char file[] = __FILE__;
1394 Perl_mro_register(aTHX_ &dfs_alg);
1396 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1399 XS(XS_mro_method_changed_in)
1406 croak_xs_usage(cv, "classname");
1410 class_stash = gv_stashsv(classname, 0);
1411 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1413 mro_method_changed_in(class_stash);
1420 * c-indentation-style: bsd
1422 * indent-tabs-mode: nil
1425 * ex: set ts=8 sts=4 sw=4 et: