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_NN(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));
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;
310 /* Save copying by making a shared hash key scalar. We
311 inline this here rather than calling
312 Perl_newSVpvn_share because we already have the
313 scalar, and we already have the hash key. */
314 assert(SvTYPE(val) == SVt_NULL);
315 sv_upgrade(val, SVt_PV);
316 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
317 SvCUR_set(val, HEK_LEN(key));
323 av_push(retval, val);
327 /* We are the first (or only) parent. We can short cut the
328 complexity above, because our @ISA is simply us prepended
329 to our parent's @ISA, and our ->isa cache is simply our
330 parent's, with our name added. */
331 /* newSVsv() is slow. This code is only faster if we can avoid
332 it by ensuring that SVs in the arrays are shared hash key
333 scalar SVs, because we can "copy" them very efficiently.
334 Although to be fair, we can't *ensure* this, as a reference
335 to the internal array is returned by mro::get_linear_isa(),
336 so we'll have to be defensive just in case someone faffed
340 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
341 av_extend(retval, subrv_items);
342 AvFILLp(retval) = subrv_items;
343 svp = AvARRAY(retval);
344 while(subrv_items--) {
345 SV *const val = *subrv_p++;
346 *++svp = SvIsCOW_shared_hash(val)
347 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
351 /* They have no stash. So create ourselves an ->isa cache
352 as if we'd copied it from what theirs should be. */
353 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
354 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
356 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
362 /* We have no parents. */
363 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
364 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
367 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
369 SvREFCNT_inc_simple_void_NN(stored);
371 SvREADONLY_on(stored);
375 /* now that we're past the exception dangers, grab our own reference to
376 the AV we're about to use for the result. The reference owned by the
377 mortals' stack will be released soon, so everything will balance. */
378 SvREFCNT_inc_simple_void_NN(retval);
381 /* we don't want anyone modifying the cache entry but us,
382 and we do so by replacing it completely */
383 SvREADONLY_on(retval);
385 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
386 MUTABLE_SV(retval)));
390 =for apidoc mro_get_linear_isa
392 Returns the mro linearisation for the given stash. By default, this
393 will be whatever C<mro_get_linear_isa_dfs> returns unless some
394 other MRO is in effect for the stash. The return value is a
397 You are responsible for C<SvREFCNT_inc()> on the
398 return value if you plan to store it anywhere
399 semi-permanently (otherwise it might be deleted
400 out from under you the next time the cache is
406 Perl_mro_get_linear_isa(pTHX_ HV *stash)
408 struct mro_meta* meta;
411 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
413 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
415 meta = HvMROMETA(stash);
416 if (!meta->mro_which)
417 Perl_croak(aTHX_ "panic: invalid MRO!");
418 isa = meta->mro_which->resolve(aTHX_ stash, 0);
420 if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
422 (HvENAME(stash)||HvNAME(stash))
423 ? newSVhek(HvENAME_HEK(stash)
428 if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
430 AV * const old = isa;
432 SV **ovp = AvARRAY(old);
433 SV * const * const oend = ovp + AvFILLp(old) + 1;
434 isa = (AV *)sv_2mortal((SV *)newAV());
435 av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
436 *AvARRAY(isa) = namesv;
437 svp = AvARRAY(isa)+1;
438 while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
440 else SvREFCNT_dec(namesv);
444 HV *const isa_hash = newHV();
445 /* Linearisation didn't build it for us, so do it here. */
446 SV *const *svp = AvARRAY(isa);
447 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
448 const HEK *canon_name = HvENAME_HEK(stash);
449 if (!canon_name) canon_name = HvNAME_HEK(stash);
451 while (svp < svp_end) {
452 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
455 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
456 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
457 HV_FETCH_ISSTORE, &PL_sv_undef,
458 HEK_HASH(canon_name));
459 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
461 SvREADONLY_on(isa_hash);
463 meta->isa = isa_hash;
470 =for apidoc mro_isa_changed_in
472 Takes the necessary steps (cache invalidations, mostly)
473 when the @ISA of the given package has changed. Invoked
474 by the C<setisa> magic, should not need to invoke directly.
479 /* Macro to avoid repeating the code five times. */
480 #define CLEAR_LINEAR(mEta) \
481 if (mEta->mro_linear_all) { \
482 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
483 mEta->mro_linear_all = NULL; \
484 /* This is just acting as a shortcut pointer. */ \
485 mEta->mro_linear_current = NULL; \
486 } else if (mEta->mro_linear_current) { \
487 /* Only the current MRO is stored, so this owns the data. */ \
488 SvREFCNT_dec(mEta->mro_linear_current); \
489 mEta->mro_linear_current = NULL; \
493 Perl_mro_isa_changed_in(pTHX_ HV* stash)
502 struct mro_meta * meta;
505 const char * const stashname = HvENAME_get(stash);
506 const STRLEN stashname_len = HvENAMELEN_get(stash);
507 const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
509 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
512 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
515 /* wipe out the cached linearizations for this stash */
516 meta = HvMROMETA(stash);
519 /* Steal it for our own purposes. */
520 isa = (HV *)sv_2mortal((SV *)meta->isa);
524 /* Inc the package generation, since our @ISA changed */
527 /* Wipe the global method cache if this package
528 is UNIVERSAL or one of its parents */
530 svp = hv_fetch(PL_isarev, stashname,
531 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
532 isarev = svp ? MUTABLE_HV(*svp) : NULL;
534 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
535 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
539 else { /* Wipe the local method cache otherwise */
541 is_universal = FALSE;
544 /* wipe next::method cache too */
545 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
547 /* Changes to @ISA might turn overloading on */
550 /* DESTROY can be cached in SvSTASH. */
551 if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
553 /* Iterate the isarev (classes that are our children),
554 wiping out their linearization, method and isa caches
555 and upating PL_isarev. */
557 HV *isa_hashes = NULL;
559 /* We have to iterate through isarev twice to avoid a chicken and
560 * egg problem: if A inherits from B and both are in isarev, A might
561 * be processed before B and use B's previous linearisation.
564 /* First iteration: Wipe everything, but stash away the isa hashes
565 * since we still need them for updating PL_isarev.
568 if(hv_iterinit(isarev)) {
569 /* Only create the hash if we need it; i.e., if isarev has
571 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
573 while((iter = hv_iternext(isarev))) {
574 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
575 struct mro_meta* revmeta;
577 if(!revstash) continue;
578 revmeta = HvMROMETA(revstash);
579 CLEAR_LINEAR(revmeta);
581 revmeta->cache_gen++;
582 if(revmeta->mro_nextmethod)
583 hv_clear(revmeta->mro_nextmethod);
584 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
588 isa_hashes, (const char*)&revstash, sizeof(HV *),
589 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
594 /* Second pass: Update PL_isarev. We can just use isa_hashes to
595 * avoid another round of stash lookups. */
597 /* isarev might be deleted from PL_isarev during this loop, so hang
599 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
602 hv_iterinit(isa_hashes);
603 while((iter = hv_iternext(isa_hashes))) {
604 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
605 HV * const isa = (HV *)HeVAL(iter);
608 /* We're starting at the 2nd element, skipping revstash */
609 linear_mro = mro_get_linear_isa(revstash);
610 svp = AvARRAY(linear_mro) + 1;
611 items = AvFILLp(linear_mro);
613 namehek = HvENAME_HEK(revstash);
614 if (!namehek) namehek = HvNAME_HEK(revstash);
617 SV* const sv = *svp++;
620 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
622 /* That fetch should not fail. But if it had to create
623 a new SV for us, then will need to upgrade it to an
624 HV (which sv_upgrade() can now do for us). */
626 mroisarev = MUTABLE_HV(HeVAL(he));
628 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
630 /* This hash only ever contains PL_sv_yes. Storing it
631 over itself is almost as cheap as calling hv_exists,
632 so on aggregate we expect to save time by not making
633 two calls to the common HV code for the case where
638 mroisarev, HEK_KEY(namehek),
639 HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
644 if((SV *)isa != &PL_sv_undef)
646 isa, HEK_KEY(namehek), HEK_LEN(namehek),
647 HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
653 /* Now iterate our MRO (parents), adding ourselves and everything from
654 our isarev to their isarev.
657 /* We're starting at the 2nd element, skipping ourselves here */
658 linear_mro = mro_get_linear_isa(stash);
659 svp = AvARRAY(linear_mro) + 1;
660 items = AvFILLp(linear_mro);
663 SV* const sv = *svp++;
666 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
668 /* That fetch should not fail. But if it had to create a new SV for
669 us, then will need to upgrade it to an HV (which sv_upgrade() can
672 mroisarev = MUTABLE_HV(HeVAL(he));
674 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
676 /* This hash only ever contains PL_sv_yes. Storing it over itself is
677 almost as cheap as calling hv_exists, so on aggregate we expect to
678 save time by not making two calls to the common HV code for the
679 case where it doesn't exist. */
681 (void)hv_store(mroisarev, stashname,
682 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0);
685 /* Delete our name from our former parents' isarevs. */
686 if(isa && HvARRAY(isa))
687 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
688 (stashname_utf8 ? SVf_UTF8 : 0) );
691 /* Deletes name from all the isarev entries listed in isa */
693 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
694 const STRLEN len, HV * const exceptions, U32 flags)
698 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
700 /* Delete our name from our former parents' isarevs. */
701 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
703 while((iter = hv_iternext(isa))) {
705 const char * const key = hv_iterkey(iter, &klen);
706 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
708 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
710 HV * const isarev = (HV *)*svp;
711 (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, G_DISCARD);
712 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
713 (void)hv_delete(PL_isarev, key,
714 HeKUTF8(iter) ? -klen : klen, G_DISCARD);
721 =for apidoc mro_package_moved
723 Call this function to signal to a stash that it has been assigned to
724 another spot in the stash hierarchy. C<stash> is the stash that has been
725 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
726 that is actually being assigned to.
728 This can also be called with a null first argument to
729 indicate that C<oldstash> has been deleted.
731 This function invalidates isa caches on the old stash, on all subpackages
732 nested inside it, and on the subclasses of all those, including
733 non-existent packages that have corresponding entries in C<stash>.
735 It also sets the effective names (C<HvENAME>) on all the stashes as
738 If the C<gv> is present and is not in the symbol table, then this function
739 simply returns. This checked will be skipped if C<flags & 1>.
744 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
745 const GV * const gv, U32 flags)
753 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
754 assert(stash || oldstash);
756 /* Determine the name(s) of the location that stash was assigned to
757 * or from which oldstash was removed.
759 * We cannot reliably use the name in oldstash, because it may have
760 * been deleted from the location in the symbol table that its name
761 * suggests, as in this case:
763 * $globref = \*foo::bar::;
764 * Symbol::delete_package("foo");
765 * *$globref = \%baz::;
766 * *$globref = *frelp::;
767 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
769 * So we get it from the gv. But, since the gv may no longer be in the
770 * symbol table, we check that first. The only reliable way to tell is
771 * to see whether its stash has an effective name and whether the gv
772 * resides in that stash under its name. That effective name may be
773 * different from what gv_fullname4 would use.
774 * If flags & 1, the caller has asked us to skip the check.
779 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
780 !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
781 GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
785 assert(SvOOK(GvSTASH(gv)));
786 assert(GvNAMELEN(gv));
787 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
788 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
789 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
792 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
795 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
796 if (name_count < 0) ++namep, name_count = -name_count - 1;
798 if (name_count == 1) {
799 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
800 namesv = GvNAMELEN(gv) == 1
801 ? newSVpvs_flags(":", SVs_TEMP)
802 : newSVpvs_flags("", SVs_TEMP);
805 namesv = sv_2mortal(newSVhek(*namep));
806 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
807 else sv_catpvs(namesv, "::");
809 if (GvNAMELEN(gv) != 1) {
811 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
812 /* skip trailing :: */
813 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
819 namesv = sv_2mortal((SV *)newAV());
820 while (name_count--) {
821 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
822 aname = GvNAMELEN(gv) == 1
828 aname = newSVhek(*namep++);
829 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
830 else sv_catpvs(aname, "::");
832 if (GvNAMELEN(gv) != 1) {
834 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
835 /* skip trailing :: */
836 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
839 av_push((AV *)namesv, aname);
843 /* Get a list of all the affected classes. */
844 /* We cannot simply pass them all to mro_isa_changed_in to avoid
845 the list, as that function assumes that only one package has
846 changed. It does not work with:
848 @foo::ISA = qw( B B::B );
849 *B:: = delete $::{"A::"};
851 as neither B nor B::B can be updated before the other, since they
852 will reset caches on foo, which will see either B or B::B with the
853 wrong name. The names must be set on *all* affected stashes before
854 we do anything else. (And linearisations must be cleared, too.)
856 stashes = (HV *) sv_2mortal((SV *)newHV());
857 mro_gather_and_rename(
858 stashes, (HV *) sv_2mortal((SV *)newHV()),
859 stash, oldstash, namesv
862 /* Once the caches have been wiped on all the classes, call
863 mro_isa_changed_in on each. */
864 hv_iterinit(stashes);
865 while((iter = hv_iternext(stashes))) {
866 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
868 /* We have to restore the original meta->isa (that
869 mro_gather_and_rename set aside for us) this way, in case
870 one class in this list is a superclass of a another class
871 that we have already encountered. In such a case, meta->isa
872 will have been overwritten without old entries being deleted
874 struct mro_meta * const meta = HvMROMETA(stash);
875 if(meta->isa != (HV *)HeVAL(iter)){
876 SvREFCNT_dec(meta->isa);
878 = HeVAL(iter) == &PL_sv_yes
881 HeVAL(iter) = NULL; /* We donated our reference count. */
883 mro_isa_changed_in(stash);
889 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
890 HV *stash, HV *oldstash, SV *namesv)
896 const bool stash_had_name = stash && HvENAME(stash);
897 bool fetched_isarev = FALSE;
902 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
904 /* We use the seen_stashes hash to keep track of which packages have
905 been encountered so far. This must be separate from the main list of
906 stashes, as we need to distinguish between stashes being assigned
907 and stashes being replaced/deleted. (A nested stash can be on both
908 sides of an assignment. We cannot simply skip iterating through a
909 stash on the right if we have seen it on the left, as it will not
910 get its ename assigned to it.)
912 To avoid allocating extra SVs, instead of a bitfield we can make
913 bizarre use of immortals:
915 &PL_sv_undef: seen on the left (oldstash)
916 &PL_sv_no : seen on the right (stash)
917 &PL_sv_yes : seen on both sides
922 /* Add to the big list. */
923 struct mro_meta * meta;
927 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
928 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
930 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
935 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
936 meta = HvMROMETA(oldstash);
939 stashes, (const char *)&oldstash, sizeof(HV *),
941 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
947 /* Update the effective name. */
948 if(HvENAME_get(oldstash)) {
949 const HEK * const enamehek = HvENAME_HEK(oldstash);
950 if(SvTYPE(namesv) == SVt_PVAV) {
951 items = AvFILLp((AV *)namesv) + 1;
952 svp = AvARRAY((AV *)namesv);
959 const U32 name_utf8 = SvUTF8(*svp);
961 const char *name = SvPVx_const(*svp, len);
963 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
965 (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
968 hv_ename_delete(oldstash, name, len, name_utf8);
970 if (!fetched_isarev) {
971 /* If the name deletion caused a name change, then we
972 * are not going to call mro_isa_changed_in with this
973 * name (and not at all if it has become anonymous) so
974 * we need to delete old isarev entries here, both
975 * those in the superclasses and this class's own list
976 * of subclasses. We simply delete the latter from
977 * PL_isarev, since we still need it. hv_delete morti-
978 * fies it for us, so sv_2mortal is not necessary. */
979 if(HvENAME_HEK(oldstash) != enamehek) {
980 if(meta->isa && HvARRAY(meta->isa))
981 mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
982 isarev = (HV *)hv_delete(PL_isarev, name,
983 name_utf8 ? -(I32)len : (I32)len, 0);
992 if(SvTYPE(namesv) == SVt_PVAV) {
993 items = AvFILLp((AV *)namesv) + 1;
994 svp = AvARRAY((AV *)namesv);
1001 const U32 name_utf8 = SvUTF8(*svp);
1003 const char *name = SvPVx_const(*svp++, len);
1004 hv_ename_add(stash, name, len, name_utf8);
1007 /* Add it to the big list if it needs
1008 * mro_isa_changed_in called on it. That happens if it was
1009 * detached from the symbol table (so it had no HvENAME) before
1010 * being assigned to the spot named by the 'name' variable, because
1011 * its cached isa linearisation is now stale (the effective name
1012 * having changed), and subclasses will then use that cache when
1013 * mro_package_moved calls mro_isa_changed_in. (See
1016 * If it did have a name, then its previous name is still
1017 * used in isa caches, and there is no need for
1018 * mro_package_moved to call mro_isa_changed_in.
1024 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1025 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1027 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1031 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1034 struct mro_meta * const meta = HvMROMETA(stash);
1037 stashes, (const char *)&stash, sizeof(HV *),
1039 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1048 if(!stash && !oldstash)
1049 /* Both stashes have been encountered already. */
1052 /* Add all the subclasses to the big list. */
1053 if(!fetched_isarev) {
1054 /* If oldstash is not null, then we can use its HvENAME to look up
1055 the isarev hash, since all its subclasses will be listed there.
1056 It will always have an HvENAME. It the HvENAME was removed
1057 above, then fetch_isarev will be true, and this code will not be
1060 If oldstash is null, then this is an empty spot with no stash in
1061 it, so subclasses could be listed in isarev hashes belonging to
1062 any of the names, so we have to check all of them.
1064 assert(!oldstash || HvENAME(oldstash));
1066 /* Extra variable to avoid a compiler warning */
1067 char * const hvename = HvENAME(oldstash);
1068 fetched_isarev = TRUE;
1069 svp = hv_fetch(PL_isarev, hvename,
1070 HvENAMEUTF8(oldstash)
1071 ? -HvENAMELEN_get(oldstash)
1072 : HvENAMELEN_get(oldstash), 0);
1073 if (svp) isarev = MUTABLE_HV(*svp);
1075 else if(SvTYPE(namesv) == SVt_PVAV) {
1076 items = AvFILLp((AV *)namesv) + 1;
1077 svp = AvARRAY((AV *)namesv);
1085 isarev || !fetched_isarev
1087 while (fetched_isarev || items--) {
1090 if (!fetched_isarev) {
1091 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1092 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1095 hv_iterinit(isarev);
1096 while((iter = hv_iternext(isarev))) {
1097 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1098 struct mro_meta * meta;
1100 if(!revstash) continue;
1101 meta = HvMROMETA(revstash);
1104 stashes, (const char *)&revstash, sizeof(HV *),
1106 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1113 if (fetched_isarev) break;
1117 /* This is partly based on code in hv_iternext_flags. We are not call-
1118 ing that here, as we want to avoid resetting the hash iterator. */
1120 /* Skip the entire loop if the hash is empty. */
1121 if(oldstash && HvUSEDKEYS(oldstash)) {
1122 xhv = (XPVHV*)SvANY(oldstash);
1123 seen = (HV *) sv_2mortal((SV *)newHV());
1125 /* Iterate through entries in the oldstash, adding them to the
1126 list, meanwhile doing the equivalent of $seen{$key} = 1.
1129 while (++riter <= (I32)xhv->xhv_max) {
1130 entry = (HvARRAY(oldstash))[riter];
1132 /* Iterate through the entries in this list */
1133 for(; entry; entry = HeNEXT(entry)) {
1137 /* If this entry is not a glob, ignore it.
1139 if (!isGV(HeVAL(entry))) continue;
1141 key = hv_iterkey(entry, &len);
1142 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1143 || (len == 1 && key[0] == ':')) {
1144 HV * const oldsubstash = GvHV(HeVAL(entry));
1145 SV ** const stashentry
1146 = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
1147 HV *substash = NULL;
1149 /* Avoid main::main::main::... */
1150 if(oldsubstash == oldstash) continue;
1154 stashentry && *stashentry
1155 && (substash = GvHV(*stashentry))
1157 || (oldsubstash && HvENAME_get(oldsubstash))
1160 /* Add :: and the key (minus the trailing ::)
1163 if(SvTYPE(namesv) == SVt_PVAV) {
1165 items = AvFILLp((AV *)namesv) + 1;
1166 svp = AvARRAY((AV *)namesv);
1167 subname = sv_2mortal((SV *)newAV());
1169 aname = newSVsv(*svp++);
1171 sv_catpvs(aname, ":");
1173 sv_catpvs(aname, "::");
1177 ? SV_CATUTF8 : SV_CATBYTES
1180 av_push((AV *)subname, aname);
1184 subname = sv_2mortal(newSVsv(namesv));
1185 if (len == 1) sv_catpvs(subname, ":");
1187 sv_catpvs(subname, "::");
1189 subname, key, len-2,
1190 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1194 mro_gather_and_rename(
1195 stashes, seen_stashes,
1196 substash, oldsubstash, subname
1200 (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
1206 /* Skip the entire loop if the hash is empty. */
1207 if (stash && HvUSEDKEYS(stash)) {
1208 xhv = (XPVHV*)SvANY(stash);
1211 /* Iterate through the new stash, skipping $seen{$key} items,
1212 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1213 while (++riter <= (I32)xhv->xhv_max) {
1214 entry = (HvARRAY(stash))[riter];
1216 /* Iterate through the entries in this list */
1217 for(; entry; entry = HeNEXT(entry)) {
1221 /* If this entry is not a glob, ignore it.
1223 if (!isGV(HeVAL(entry))) continue;
1225 key = hv_iterkey(entry, &len);
1226 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1227 || (len == 1 && key[0] == ':')) {
1230 /* If this entry was seen when we iterated through the
1231 oldstash, skip it. */
1232 if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
1234 /* We get here only if this stash has no corresponding
1235 entry in the stash being replaced. */
1237 substash = GvHV(HeVAL(entry));
1241 /* Avoid checking main::main::main::... */
1242 if(substash == stash) continue;
1244 /* Add :: and the key (minus the trailing ::)
1246 if(SvTYPE(namesv) == SVt_PVAV) {
1248 items = AvFILLp((AV *)namesv) + 1;
1249 svp = AvARRAY((AV *)namesv);
1250 subname = sv_2mortal((SV *)newAV());
1252 aname = newSVsv(*svp++);
1254 sv_catpvs(aname, ":");
1256 sv_catpvs(aname, "::");
1260 ? SV_CATUTF8 : SV_CATBYTES
1263 av_push((AV *)subname, aname);
1267 subname = sv_2mortal(newSVsv(namesv));
1268 if (len == 1) sv_catpvs(subname, ":");
1270 sv_catpvs(subname, "::");
1272 subname, key, len-2,
1273 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1277 mro_gather_and_rename(
1278 stashes, seen_stashes,
1279 substash, NULL, subname
1289 =for apidoc mro_method_changed_in
1291 Invalidates method caching on any child classes
1292 of the given stash, so that they might notice
1293 the changes in this one.
1295 Ideally, all instances of C<PL_sub_generation++> in
1296 perl source outside of F<mro.c> should be
1297 replaced by calls to this.
1299 Perl automatically handles most of the common
1300 ways a method might be redefined. However, there
1301 are a few ways you could change a method in a stash
1302 without the cache code noticing, in which case you
1303 need to call this method afterwards:
1305 1) Directly manipulating the stash HV entries from
1308 2) Assigning a reference to a readonly scalar
1309 constant into a stash entry in order to create
1310 a constant subroutine (like constant.pm
1313 This same method is available from pure perl
1314 via, C<mro::method_changed_in(classname)>.
1319 Perl_mro_method_changed_in(pTHX_ HV *stash)
1321 const char * const stashname = HvENAME_get(stash);
1322 const STRLEN stashname_len = HvENAMELEN_get(stash);
1323 const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
1325 SV ** const svp = hv_fetch(PL_isarev, stashname,
1326 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
1327 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1329 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1332 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1334 /* Inc the package generation, since a local method changed */
1335 HvMROMETA(stash)->pkg_gen++;
1337 /* DESTROY can be cached in SvSTASH. */
1338 if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
1340 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1341 invalidate all method caches globally */
1342 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1343 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1344 PL_sub_generation++;
1348 /* else, invalidate the method caches of all child classes,
1353 hv_iterinit(isarev);
1354 while((iter = hv_iternext(isarev))) {
1355 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1356 struct mro_meta* mrometa;
1358 if(!revstash) continue;
1359 mrometa = HvMROMETA(revstash);
1360 mrometa->cache_gen++;
1361 if(mrometa->mro_nextmethod)
1362 hv_clear(mrometa->mro_nextmethod);
1363 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
1367 /* The method change may be due to *{$package . "::()"} = \&nil; in
1373 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1375 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1377 PERL_ARGS_ASSERT_MRO_SET_MRO;
1380 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1382 if(meta->mro_which != which) {
1383 if (meta->mro_linear_current && !meta->mro_linear_all) {
1384 /* If we were storing something directly, put it in the hash before
1386 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1387 MUTABLE_SV(meta->mro_linear_current));
1389 meta->mro_which = which;
1390 /* Scrub our cached pointer to the private data. */
1391 meta->mro_linear_current = NULL;
1392 /* Only affects local method cache, not
1393 even child classes */
1395 if(meta->mro_nextmethod)
1396 hv_clear(meta->mro_nextmethod);
1402 XS(XS_mro_method_changed_in);
1405 Perl_boot_core_mro(pTHX)
1408 static const char file[] = __FILE__;
1410 Perl_mro_register(aTHX_ &dfs_alg);
1412 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1415 XS(XS_mro_method_changed_in)
1423 croak_xs_usage(cv, "classname");
1427 class_stash = gv_stashsv(classname, 0);
1428 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1430 mro_method_changed_in(class_stash);
1437 * c-indentation-style: bsd
1439 * indent-tabs-mode: nil
1442 * ex: set ts=8 sts=4 sw=4 et: