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"]
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 =for apidoc mro_register
119 Registers a custom mro plugin. See L<perlmroapi> for details.
125 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
126 SV *wrapper = newSVuv(PTR2UV(mro));
128 PERL_ARGS_ASSERT_MRO_REGISTER;
131 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
132 mro->name, mro->length, mro->kflags,
133 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
134 SvREFCNT_dec(wrapper);
135 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
136 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
141 Perl_mro_meta_init(pTHX_ HV* stash)
143 struct mro_meta* newmeta;
145 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));
192 #endif /* USE_ITHREADS */
195 =for apidoc mro_get_linear_isa_dfs
197 Returns the Depth-First Search linearization of @ISA
198 the given stash. The return value is a read-only AV*.
199 C<level> should be 0 (it is used internally in this
200 function's recursion).
202 You are responsible for C<SvREFCNT_inc()> on the
203 return value if you plan to store it anywhere
204 semi-permanently (otherwise it might be deleted
205 out from under you the next time the cache is
211 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
218 struct mro_meta* meta;
222 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
223 assert(HvAUX(stash));
226 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
227 ? HvENAME_HEK_NN(stash)
231 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
235 "Recursive inheritance detected in package '%"HEKf"'",
238 meta = HvMROMETA(stash);
240 /* return cache if valid */
241 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
245 /* not in cache, make a new one */
247 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
248 /* We use this later in this function, but don't need a reference to it
249 beyond the end of this function, so reference count is fine. */
250 our_name = newSVhek(stashhek);
251 av_push(retval, our_name); /* add ourselves at the top */
254 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
255 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
257 /* "stored" is used to keep track of all of the classnames we have added to
258 the MRO so far, so we can do a quick exists check and avoid adding
259 duplicate classnames to the MRO as we go.
260 It's then retained to be re-used as a fast lookup for ->isa(), by adding
261 our own name and "UNIVERSAL" to it. */
263 if(av && AvFILLp(av) >= 0) {
265 SV **svp = AvARRAY(av);
266 I32 items = AvFILLp(av) + 1;
270 SV* const sv = *svp++;
271 HV* const basestash = gv_stashsv(sv, 0);
276 /* if no stash exists for this @ISA member,
277 simply add it to the MRO and move on */
282 /* otherwise, recurse into ourselves for the MRO
283 of this @ISA member, and append their MRO to ours.
284 The recursive call could throw an exception, which
285 has memory management implications here, hence the use of
287 const AV *const subrv
288 = mro_get_linear_isa_dfs(basestash, level + 1);
290 subrv_p = AvARRAY(subrv);
291 subrv_items = AvFILLp(subrv) + 1;
294 while(subrv_items--) {
295 SV *const subsv = *subrv_p++;
296 /* LVALUE fetch will create a new undefined SV if necessary
298 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
300 if(HeVAL(he) != &PL_sv_undef) {
301 /* It was newly created. Steal it for our new SV, and
302 replace it in the hash with the "real" thing. */
303 SV *const val = HeVAL(he);
304 HEK *const key = HeKEY_hek(he);
306 HeVAL(he) = &PL_sv_undef;
307 /* Save copying by making a shared hash key scalar. We
308 inline this here rather than calling
309 Perl_newSVpvn_share because we already have the
310 scalar, and we already have the hash key. */
311 assert(SvTYPE(val) == SVt_NULL);
312 sv_upgrade(val, SVt_PV);
313 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
314 SvCUR_set(val, HEK_LEN(key));
321 av_push(retval, val);
325 /* We are the first (or only) parent. We can short cut the
326 complexity above, because our @ISA is simply us prepended
327 to our parent's @ISA, and our ->isa cache is simply our
328 parent's, with our name added. */
329 /* newSVsv() is slow. This code is only faster if we can avoid
330 it by ensuring that SVs in the arrays are shared hash key
331 scalar SVs, because we can "copy" them very efficiently.
332 Although to be fair, we can't *ensure* this, as a reference
333 to the internal array is returned by mro::get_linear_isa(),
334 so we'll have to be defensive just in case someone faffed
338 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
339 av_extend(retval, subrv_items);
340 AvFILLp(retval) = subrv_items;
341 svp = AvARRAY(retval);
342 while(subrv_items--) {
343 SV *const val = *subrv_p++;
344 *++svp = SvIsCOW_shared_hash(val)
345 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
349 /* They have no stash. So create ourselves an ->isa cache
350 as if we'd copied it from what theirs should be. */
351 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
352 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
354 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
360 /* We have no parents. */
361 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
362 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
365 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
367 SvREFCNT_inc_simple_void_NN(stored);
369 SvREADONLY_on(stored);
373 /* now that we're past the exception dangers, grab our own reference to
374 the AV we're about to use for the result. The reference owned by the
375 mortals' stack will be released soon, so everything will balance. */
376 SvREFCNT_inc_simple_void_NN(retval);
379 /* we don't want anyone modifying the cache entry but us,
380 and we do so by replacing it completely */
381 SvREADONLY_on(retval);
383 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
384 MUTABLE_SV(retval)));
388 =for apidoc mro_get_linear_isa
390 Returns the mro linearisation for the given stash. By default, this
391 will be whatever C<mro_get_linear_isa_dfs> returns unless some
392 other MRO is in effect for the stash. The return value is a
395 You are responsible for C<SvREFCNT_inc()> on the
396 return value if you plan to store it anywhere
397 semi-permanently (otherwise it might be deleted
398 out from under you the next time the cache is
404 Perl_mro_get_linear_isa(pTHX_ HV *stash)
406 struct mro_meta* meta;
409 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
411 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
413 meta = HvMROMETA(stash);
414 if (!meta->mro_which)
415 Perl_croak(aTHX_ "panic: invalid MRO!");
416 isa = meta->mro_which->resolve(aTHX_ stash, 0);
418 if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
420 (HvENAME(stash)||HvNAME(stash))
421 ? newSVhek(HvENAME_HEK(stash)
426 if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
428 AV * const old = isa;
430 SV **ovp = AvARRAY(old);
431 SV * const * const oend = ovp + AvFILLp(old) + 1;
432 isa = (AV *)sv_2mortal((SV *)newAV());
433 av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
434 *AvARRAY(isa) = namesv;
435 svp = AvARRAY(isa)+1;
436 while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
438 else SvREFCNT_dec(namesv);
442 HV *const isa_hash = newHV();
443 /* Linearisation didn't build it for us, so do it here. */
444 SV *const *svp = AvARRAY(isa);
445 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
446 const HEK *canon_name = HvENAME_HEK(stash);
447 if (!canon_name) canon_name = HvNAME_HEK(stash);
449 while (svp < svp_end) {
450 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
453 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
454 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
455 HV_FETCH_ISSTORE, &PL_sv_undef,
456 HEK_HASH(canon_name));
457 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
459 SvREADONLY_on(isa_hash);
461 meta->isa = isa_hash;
468 =for apidoc mro_isa_changed_in
470 Takes the necessary steps (cache invalidations, mostly)
471 when the @ISA of the given package has changed. Invoked
472 by the C<setisa> magic, should not need to invoke directly.
477 /* Macro to avoid repeating the code five times. */
478 #define CLEAR_LINEAR(mEta) \
479 if (mEta->mro_linear_all) { \
480 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
481 mEta->mro_linear_all = NULL; \
482 /* This is just acting as a shortcut pointer. */ \
483 mEta->mro_linear_current = NULL; \
484 } else if (mEta->mro_linear_current) { \
485 /* Only the current MRO is stored, so this owns the data. */ \
486 SvREFCNT_dec(mEta->mro_linear_current); \
487 mEta->mro_linear_current = NULL; \
491 Perl_mro_isa_changed_in(pTHX_ HV* stash)
500 struct mro_meta * meta;
503 const char * const stashname = HvENAME_get(stash);
504 const STRLEN stashname_len = HvENAMELEN_get(stash);
505 const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
507 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
510 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
513 /* wipe out the cached linearizations for this stash */
514 meta = HvMROMETA(stash);
517 /* Steal it for our own purposes. */
518 isa = (HV *)sv_2mortal((SV *)meta->isa);
522 /* Inc the package generation, since our @ISA changed */
525 /* Wipe the global method cache if this package
526 is UNIVERSAL or one of its parents */
528 svp = hv_fetch(PL_isarev, stashname,
529 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
530 isarev = svp ? MUTABLE_HV(*svp) : NULL;
532 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
533 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
537 else { /* Wipe the local method cache otherwise */
539 is_universal = FALSE;
542 /* wipe next::method cache too */
543 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
545 /* Changes to @ISA might turn overloading on */
548 /* Iterate the isarev (classes that are our children),
549 wiping out their linearization, method and isa caches
550 and upating PL_isarev. */
552 HV *isa_hashes = NULL;
554 /* We have to iterate through isarev twice to avoid a chicken and
555 * egg problem: if A inherits from B and both are in isarev, A might
556 * be processed before B and use B's previous linearisation.
559 /* First iteration: Wipe everything, but stash away the isa hashes
560 * since we still need them for updating PL_isarev.
563 if(hv_iterinit(isarev)) {
564 /* Only create the hash if we need it; i.e., if isarev has
566 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
568 while((iter = hv_iternext(isarev))) {
569 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
570 struct mro_meta* revmeta;
572 if(!revstash) continue;
573 revmeta = HvMROMETA(revstash);
574 CLEAR_LINEAR(revmeta);
576 revmeta->cache_gen++;
577 if(revmeta->mro_nextmethod)
578 hv_clear(revmeta->mro_nextmethod);
582 isa_hashes, (const char*)&revstash, sizeof(HV *),
583 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
588 /* Second pass: Update PL_isarev. We can just use isa_hashes to
589 * avoid another round of stash lookups. */
591 /* isarev might be deleted from PL_isarev during this loop, so hang
593 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
596 hv_iterinit(isa_hashes);
597 while((iter = hv_iternext(isa_hashes))) {
598 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
599 HV * const isa = (HV *)HeVAL(iter);
602 /* We're starting at the 2nd element, skipping revstash */
603 linear_mro = mro_get_linear_isa(revstash);
604 svp = AvARRAY(linear_mro) + 1;
605 items = AvFILLp(linear_mro);
607 namehek = HvENAME_HEK(revstash);
608 if (!namehek) namehek = HvNAME_HEK(revstash);
611 SV* const sv = *svp++;
614 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
616 /* That fetch should not fail. But if it had to create
617 a new SV for us, then will need to upgrade it to an
618 HV (which sv_upgrade() can now do for us). */
620 mroisarev = MUTABLE_HV(HeVAL(he));
622 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
624 /* This hash only ever contains PL_sv_yes. Storing it
625 over itself is almost as cheap as calling hv_exists,
626 so on aggregate we expect to save time by not making
627 two calls to the common HV code for the case where
632 mroisarev, HEK_KEY(namehek),
633 HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
638 if((SV *)isa != &PL_sv_undef)
640 isa, HEK_KEY(namehek), HEK_LEN(namehek),
641 HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
647 /* Now iterate our MRO (parents), adding ourselves and everything from
648 our isarev to their isarev.
651 /* We're starting at the 2nd element, skipping ourselves here */
652 linear_mro = mro_get_linear_isa(stash);
653 svp = AvARRAY(linear_mro) + 1;
654 items = AvFILLp(linear_mro);
657 SV* const sv = *svp++;
660 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
662 /* That fetch should not fail. But if it had to create a new SV for
663 us, then will need to upgrade it to an HV (which sv_upgrade() can
666 mroisarev = MUTABLE_HV(HeVAL(he));
668 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
670 /* This hash only ever contains PL_sv_yes. Storing it over itself is
671 almost as cheap as calling hv_exists, so on aggregate we expect to
672 save time by not making two calls to the common HV code for the
673 case where it doesn't exist. */
675 (void)hv_store(mroisarev, stashname,
676 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0);
679 /* Delete our name from our former parents' isarevs. */
680 if(isa && HvARRAY(isa))
681 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
682 (stashname_utf8 ? SVf_UTF8 : 0) );
685 /* Deletes name from all the isarev entries listed in isa */
687 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
688 const STRLEN len, HV * const exceptions, U32 flags)
692 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
694 /* Delete our name from our former parents' isarevs. */
695 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
697 while((iter = hv_iternext(isa))) {
699 const char * const key = hv_iterkey(iter, &klen);
700 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
702 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
704 HV * const isarev = (HV *)*svp;
705 (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, G_DISCARD);
706 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
707 (void)hv_delete(PL_isarev, key,
708 HeKUTF8(iter) ? -klen : klen, G_DISCARD);
715 =for apidoc mro_package_moved
717 Call this function to signal to a stash that it has been assigned to
718 another spot in the stash hierarchy. C<stash> is the stash that has been
719 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
720 that is actually being assigned to.
722 This can also be called with a null first argument to
723 indicate that C<oldstash> has been deleted.
725 This function invalidates isa caches on the old stash, on all subpackages
726 nested inside it, and on the subclasses of all those, including
727 non-existent packages that have corresponding entries in C<stash>.
729 It also sets the effective names (C<HvENAME>) on all the stashes as
732 If the C<gv> is present and is not in the symbol table, then this function
733 simply returns. This checked will be skipped if C<flags & 1>.
738 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
739 const GV * const gv, U32 flags)
747 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
748 assert(stash || oldstash);
750 /* Determine the name(s) of the location that stash was assigned to
751 * or from which oldstash was removed.
753 * We cannot reliably use the name in oldstash, because it may have
754 * been deleted from the location in the symbol table that its name
755 * suggests, as in this case:
757 * $globref = \*foo::bar::;
758 * Symbol::delete_package("foo");
759 * *$globref = \%baz::;
760 * *$globref = *frelp::;
761 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
763 * So we get it from the gv. But, since the gv may no longer be in the
764 * symbol table, we check that first. The only reliable way to tell is
765 * to see whether its stash has an effective name and whether the gv
766 * resides in that stash under its name. That effective name may be
767 * different from what gv_fullname4 would use.
768 * If flags & 1, the caller has asked us to skip the check.
773 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
774 !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
775 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
779 assert(SvOOK(GvSTASH(gv)));
780 assert(GvNAMELEN(gv));
781 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
782 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
783 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
786 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
789 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
790 if (name_count < 0) ++namep, name_count = -name_count - 1;
792 if (name_count == 1) {
793 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
794 namesv = GvNAMELEN(gv) == 1
795 ? newSVpvs_flags(":", SVs_TEMP)
796 : newSVpvs_flags("", SVs_TEMP);
799 namesv = sv_2mortal(newSVhek(*namep));
800 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
801 else sv_catpvs(namesv, "::");
803 if (GvNAMELEN(gv) != 1) {
805 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
806 /* skip trailing :: */
807 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
813 namesv = sv_2mortal((SV *)newAV());
814 while (name_count--) {
815 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
816 aname = GvNAMELEN(gv) == 1
822 aname = newSVhek(*namep++);
823 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
824 else sv_catpvs(aname, "::");
826 if (GvNAMELEN(gv) != 1) {
828 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
829 /* skip trailing :: */
830 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
833 av_push((AV *)namesv, aname);
837 /* Get a list of all the affected classes. */
838 /* We cannot simply pass them all to mro_isa_changed_in to avoid
839 the list, as that function assumes that only one package has
840 changed. It does not work with:
842 @foo::ISA = qw( B B::B );
843 *B:: = delete $::{"A::"};
845 as neither B nor B::B can be updated before the other, since they
846 will reset caches on foo, which will see either B or B::B with the
847 wrong name. The names must be set on *all* affected stashes before
848 we do anything else. (And linearisations must be cleared, too.)
850 stashes = (HV *) sv_2mortal((SV *)newHV());
851 mro_gather_and_rename(
852 stashes, (HV *) sv_2mortal((SV *)newHV()),
853 stash, oldstash, namesv
856 /* Once the caches have been wiped on all the classes, call
857 mro_isa_changed_in on each. */
858 hv_iterinit(stashes);
859 while((iter = hv_iternext(stashes))) {
860 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
862 /* We have to restore the original meta->isa (that
863 mro_gather_and_rename set aside for us) this way, in case
864 one class in this list is a superclass of a another class
865 that we have already encountered. In such a case, meta->isa
866 will have been overwritten without old entries being deleted
868 struct mro_meta * const meta = HvMROMETA(stash);
869 if(meta->isa != (HV *)HeVAL(iter)){
870 SvREFCNT_dec(meta->isa);
872 = HeVAL(iter) == &PL_sv_yes
875 HeVAL(iter) = NULL; /* We donated our reference count. */
877 mro_isa_changed_in(stash);
883 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
884 HV *stash, HV *oldstash, SV *namesv)
890 const bool stash_had_name = stash && HvENAME(stash);
891 bool fetched_isarev = FALSE;
896 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
898 /* We use the seen_stashes hash to keep track of which packages have
899 been encountered so far. This must be separate from the main list of
900 stashes, as we need to distinguish between stashes being assigned
901 and stashes being replaced/deleted. (A nested stash can be on both
902 sides of an assignment. We cannot simply skip iterating through a
903 stash on the right if we have seen it on the left, as it will not
904 get its ename assigned to it.)
906 To avoid allocating extra SVs, instead of a bitfield we can make
907 bizarre use of immortals:
909 &PL_sv_undef: seen on the left (oldstash)
910 &PL_sv_no : seen on the right (stash)
911 &PL_sv_yes : seen on both sides
916 /* Add to the big list. */
917 struct mro_meta * meta;
921 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
922 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
924 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
929 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
930 meta = HvMROMETA(oldstash);
933 stashes, (const char *)&oldstash, sizeof(HV *),
935 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
941 /* Update the effective name. */
942 if(HvENAME_get(oldstash)) {
943 const HEK * const enamehek = HvENAME_HEK(oldstash);
944 if(SvTYPE(namesv) == SVt_PVAV) {
945 items = AvFILLp((AV *)namesv) + 1;
946 svp = AvARRAY((AV *)namesv);
953 const U32 name_utf8 = SvUTF8(*svp);
955 const char *name = SvPVx_const(*svp++, len);
957 (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
958 hv_ename_delete(oldstash, name, len, name_utf8);
960 if (!fetched_isarev) {
961 /* If the name deletion caused a name change, then we
962 * are not going to call mro_isa_changed_in with this
963 * name (and not at all if it has become anonymous) so
964 * we need to delete old isarev entries here, both
965 * those in the superclasses and this class's own list
966 * of subclasses. We simply delete the latter from
967 * PL_isarev, since we still need it. hv_delete morti-
968 * fies it for us, so sv_2mortal is not necessary. */
969 if(HvENAME_HEK(oldstash) != enamehek) {
970 if(meta->isa && HvARRAY(meta->isa))
971 mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
972 isarev = (HV *)hv_delete(PL_isarev, name,
973 name_utf8 ? -(I32)len : (I32)len, 0);
982 if(SvTYPE(namesv) == SVt_PVAV) {
983 items = AvFILLp((AV *)namesv) + 1;
984 svp = AvARRAY((AV *)namesv);
991 const U32 name_utf8 = SvUTF8(*svp);
993 const char *name = SvPVx_const(*svp++, len);
994 hv_ename_add(stash, name, len, name_utf8);
997 /* Add it to the big list if it needs
998 * mro_isa_changed_in called on it. That happens if it was
999 * detached from the symbol table (so it had no HvENAME) before
1000 * being assigned to the spot named by the 'name' variable, because
1001 * its cached isa linearisation is now stale (the effective name
1002 * having changed), and subclasses will then use that cache when
1003 * mro_package_moved calls mro_isa_changed_in. (See
1006 * If it did have a name, then its previous name is still
1007 * used in isa caches, and there is no need for
1008 * mro_package_moved to call mro_isa_changed_in.
1014 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1015 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1017 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1021 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1024 struct mro_meta * const meta = HvMROMETA(stash);
1027 stashes, (const char *)&stash, sizeof(HV *),
1029 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1038 if(!stash && !oldstash)
1039 /* Both stashes have been encountered already. */
1042 /* Add all the subclasses to the big list. */
1043 if(!fetched_isarev) {
1044 /* If oldstash is not null, then we can use its HvENAME to look up
1045 the isarev hash, since all its subclasses will be listed there.
1046 It will always have an HvENAME. It the HvENAME was removed
1047 above, then fetch_isarev will be true, and this code will not be
1050 If oldstash is null, then this is an empty spot with no stash in
1051 it, so subclasses could be listed in isarev hashes belonging to
1052 any of the names, so we have to check all of them.
1054 assert(!oldstash || HvENAME(oldstash));
1056 /* Extra variable to avoid a compiler warning */
1057 char * const hvename = HvENAME(oldstash);
1058 fetched_isarev = TRUE;
1059 svp = hv_fetch(PL_isarev, hvename,
1060 HvENAMEUTF8(oldstash)
1061 ? -HvENAMELEN_get(oldstash)
1062 : HvENAMELEN_get(oldstash), 0);
1063 if (svp) isarev = MUTABLE_HV(*svp);
1065 else if(SvTYPE(namesv) == SVt_PVAV) {
1066 items = AvFILLp((AV *)namesv) + 1;
1067 svp = AvARRAY((AV *)namesv);
1075 isarev || !fetched_isarev
1077 while (fetched_isarev || items--) {
1080 if (!fetched_isarev) {
1081 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1082 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1085 hv_iterinit(isarev);
1086 while((iter = hv_iternext(isarev))) {
1087 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1088 struct mro_meta * meta;
1090 if(!revstash) continue;
1091 meta = HvMROMETA(revstash);
1094 stashes, (const char *)&revstash, sizeof(HV *),
1096 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1103 if (fetched_isarev) break;
1107 /* This is partly based on code in hv_iternext_flags. We are not call-
1108 ing that here, as we want to avoid resetting the hash iterator. */
1110 /* Skip the entire loop if the hash is empty. */
1111 if(oldstash && HvUSEDKEYS(oldstash)) {
1112 xhv = (XPVHV*)SvANY(oldstash);
1113 seen = (HV *) sv_2mortal((SV *)newHV());
1115 /* Iterate through entries in the oldstash, adding them to the
1116 list, meanwhile doing the equivalent of $seen{$key} = 1.
1119 while (++riter <= (I32)xhv->xhv_max) {
1120 entry = (HvARRAY(oldstash))[riter];
1122 /* Iterate through the entries in this list */
1123 for(; entry; entry = HeNEXT(entry)) {
1127 /* If this entry is not a glob, ignore it.
1129 if (!isGV(HeVAL(entry))) continue;
1131 key = hv_iterkey(entry, &len);
1132 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1133 || (len == 1 && key[0] == ':')) {
1134 HV * const oldsubstash = GvHV(HeVAL(entry));
1135 SV ** const stashentry
1136 = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
1137 HV *substash = NULL;
1139 /* Avoid main::main::main::... */
1140 if(oldsubstash == oldstash) continue;
1144 stashentry && *stashentry
1145 && (substash = GvHV(*stashentry))
1147 || (oldsubstash && HvENAME_get(oldsubstash))
1150 /* Add :: and the key (minus the trailing ::)
1153 if(SvTYPE(namesv) == SVt_PVAV) {
1155 items = AvFILLp((AV *)namesv) + 1;
1156 svp = AvARRAY((AV *)namesv);
1157 subname = sv_2mortal((SV *)newAV());
1159 aname = newSVsv(*svp++);
1161 sv_catpvs(aname, ":");
1163 sv_catpvs(aname, "::");
1167 ? SV_CATUTF8 : SV_CATBYTES
1170 av_push((AV *)subname, aname);
1174 subname = sv_2mortal(newSVsv(namesv));
1175 if (len == 1) sv_catpvs(subname, ":");
1177 sv_catpvs(subname, "::");
1179 subname, key, len-2,
1180 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1184 mro_gather_and_rename(
1185 stashes, seen_stashes,
1186 substash, oldsubstash, subname
1190 (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
1196 /* Skip the entire loop if the hash is empty. */
1197 if (stash && HvUSEDKEYS(stash)) {
1198 xhv = (XPVHV*)SvANY(stash);
1201 /* Iterate through the new stash, skipping $seen{$key} items,
1202 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1203 while (++riter <= (I32)xhv->xhv_max) {
1204 entry = (HvARRAY(stash))[riter];
1206 /* Iterate through the entries in this list */
1207 for(; entry; entry = HeNEXT(entry)) {
1211 /* If this entry is not a glob, ignore it.
1213 if (!isGV(HeVAL(entry))) continue;
1215 key = hv_iterkey(entry, &len);
1216 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1217 || (len == 1 && key[0] == ':')) {
1220 /* If this entry was seen when we iterated through the
1221 oldstash, skip it. */
1222 if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
1224 /* We get here only if this stash has no corresponding
1225 entry in the stash being replaced. */
1227 substash = GvHV(HeVAL(entry));
1231 /* Avoid checking main::main::main::... */
1232 if(substash == stash) continue;
1234 /* Add :: and the key (minus the trailing ::)
1236 if(SvTYPE(namesv) == SVt_PVAV) {
1238 items = AvFILLp((AV *)namesv) + 1;
1239 svp = AvARRAY((AV *)namesv);
1240 subname = sv_2mortal((SV *)newAV());
1242 aname = newSVsv(*svp++);
1244 sv_catpvs(aname, ":");
1246 sv_catpvs(aname, "::");
1250 ? SV_CATUTF8 : SV_CATBYTES
1253 av_push((AV *)subname, aname);
1257 subname = sv_2mortal(newSVsv(namesv));
1258 if (len == 1) sv_catpvs(subname, ":");
1260 sv_catpvs(subname, "::");
1262 subname, key, len-2,
1263 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1267 mro_gather_and_rename(
1268 stashes, seen_stashes,
1269 substash, NULL, subname
1279 =for apidoc mro_method_changed_in
1281 Invalidates method caching on any child classes
1282 of the given stash, so that they might notice
1283 the changes in this one.
1285 Ideally, all instances of C<PL_sub_generation++> in
1286 perl source outside of F<mro.c> should be
1287 replaced by calls to this.
1289 Perl automatically handles most of the common
1290 ways a method might be redefined. However, there
1291 are a few ways you could change a method in a stash
1292 without the cache code noticing, in which case you
1293 need to call this method afterwards:
1295 1) Directly manipulating the stash HV entries from
1298 2) Assigning a reference to a readonly scalar
1299 constant into a stash entry in order to create
1300 a constant subroutine (like constant.pm
1303 This same method is available from pure perl
1304 via, C<mro::method_changed_in(classname)>.
1309 Perl_mro_method_changed_in(pTHX_ HV *stash)
1311 const char * const stashname = HvENAME_get(stash);
1312 const STRLEN stashname_len = HvENAMELEN_get(stash);
1313 const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
1315 SV ** const svp = hv_fetch(PL_isarev, stashname,
1316 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
1317 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1319 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1322 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1324 /* Inc the package generation, since a local method changed */
1325 HvMROMETA(stash)->pkg_gen++;
1327 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1328 invalidate all method caches globally */
1329 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1330 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1331 PL_sub_generation++;
1335 /* else, invalidate the method caches of all child classes,
1340 hv_iterinit(isarev);
1341 while((iter = hv_iternext(isarev))) {
1342 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1343 struct mro_meta* mrometa;
1345 if(!revstash) continue;
1346 mrometa = HvMROMETA(revstash);
1347 mrometa->cache_gen++;
1348 if(mrometa->mro_nextmethod)
1349 hv_clear(mrometa->mro_nextmethod);
1353 /* The method change may be due to *{$package . "::()"} = \&nil; in
1359 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1361 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1363 PERL_ARGS_ASSERT_MRO_SET_MRO;
1366 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1368 if(meta->mro_which != which) {
1369 if (meta->mro_linear_current && !meta->mro_linear_all) {
1370 /* If we were storing something directly, put it in the hash before
1372 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1373 MUTABLE_SV(meta->mro_linear_current));
1375 meta->mro_which = which;
1376 /* Scrub our cached pointer to the private data. */
1377 meta->mro_linear_current = NULL;
1378 /* Only affects local method cache, not
1379 even child classes */
1381 if(meta->mro_nextmethod)
1382 hv_clear(meta->mro_nextmethod);
1388 XS(XS_mro_method_changed_in);
1391 Perl_boot_core_mro(pTHX)
1394 static const char file[] = __FILE__;
1396 Perl_mro_register(aTHX_ &dfs_alg);
1398 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1401 XS(XS_mro_method_changed_in)
1409 croak_xs_usage(cv, "classname");
1413 class_stash = gv_stashsv(classname, 0);
1414 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1416 mro_method_changed_in(class_stash);
1423 * c-indentation-style: bsd
1425 * indent-tabs-mode: nil
1428 * ex: set ts=8 sts=4 sw=4 et: