3 * Copyright (c) 2007 Brandon L Black
4 * Copyright (c) 2007, 2008 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
13 * You'll be last either way, Master Peregrin.'
15 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
21 These functions are related to the method resolution order of perl classes
30 static const struct mro_alg dfs_alg =
31 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
34 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35 const struct mro_alg *const which)
38 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
40 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
41 which->name, which->length, which->kflags,
42 HV_FETCH_JUST_SV, NULL, which->hash);
46 /* If we've been asked to look up the private data for the current MRO, then
48 if (smeta->mro_which == which)
49 smeta->mro_linear_current = *data;
55 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56 const struct mro_alg *const which, SV *const data)
58 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
60 if (!smeta->mro_linear_all) {
61 if (smeta->mro_which == which) {
62 /* If all we need to store is the current MRO's data, then don't use
63 memory on a hash with 1 element - store it direct, and signal
64 this by leaving the would-be-hash NULL. */
65 smeta->mro_linear_current = data;
68 HV *const hv = newHV();
69 /* Start with 2 buckets. It's unlikely we'll need more. */
71 smeta->mro_linear_all = hv;
73 if (smeta->mro_linear_current) {
74 /* If we were storing something directly, put it in the hash
76 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
77 smeta->mro_linear_current);
82 /* We get here if we're storing more than one linearisation for this stash,
83 or the linearisation we are storing is not that if its current MRO. */
85 if (smeta->mro_which == which) {
86 /* If we've been asked to store the private data for the current MRO,
88 smeta->mro_linear_current = data;
91 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
92 which->name, which->length, which->kflags,
93 HV_FETCH_ISSTORE, data, which->hash)) {
94 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
95 "for '%.*s' %d", (int) which->length, which->name,
102 const struct mro_alg *
103 Perl_mro_get_from_name(pTHX_ SV *name) {
106 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
108 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109 HV_FETCH_JUST_SV, NULL, 0);
112 assert(SvTYPE(*data) == SVt_IV);
113 assert(SvIOK(*data));
114 return INT2PTR(const struct mro_alg *, SvUVX(*data));
118 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
119 SV *wrapper = newSVuv(PTR2UV(mro));
121 PERL_ARGS_ASSERT_MRO_REGISTER;
124 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
125 mro->name, mro->length, mro->kflags,
126 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
127 SvREFCNT_dec(wrapper);
128 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
129 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
134 Perl_mro_meta_init(pTHX_ HV* stash)
136 struct mro_meta* newmeta;
138 PERL_ARGS_ASSERT_MRO_META_INIT;
139 assert(HvAUX(stash));
140 assert(!(HvAUX(stash)->xhv_mro_meta));
141 Newxz(newmeta, 1, struct mro_meta);
142 HvAUX(stash)->xhv_mro_meta = newmeta;
143 newmeta->cache_gen = 1;
144 newmeta->pkg_gen = 1;
145 newmeta->mro_which = &dfs_alg;
150 #if defined(USE_ITHREADS)
152 /* for sv_dup on new threads */
154 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
156 struct mro_meta* newmeta;
158 PERL_ARGS_ASSERT_MRO_META_DUP;
160 Newx(newmeta, 1, struct mro_meta);
161 Copy(smeta, newmeta, 1, struct mro_meta);
163 if (newmeta->mro_linear_all) {
164 newmeta->mro_linear_all
165 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
166 /* This is just acting as a shortcut pointer, and will be automatically
167 updated on the first get. */
168 newmeta->mro_linear_current = NULL;
169 } else if (newmeta->mro_linear_current) {
170 /* Only the current MRO is stored, so this owns the data. */
171 newmeta->mro_linear_current
172 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
175 if (newmeta->mro_nextmethod)
176 newmeta->mro_nextmethod
177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
180 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
185 #endif /* USE_ITHREADS */
188 =for apidoc mro_get_linear_isa_dfs
190 Returns the Depth-First Search linearization of @ISA
191 the given stash. The return value is a read-only AV*.
192 C<level> should be 0 (it is used internally in this
193 function's recursion).
195 You are responsible for C<SvREFCNT_inc()> on the
196 return value if you plan to store it anywhere
197 semi-permanently (otherwise it might be deleted
198 out from under you the next time the cache is
204 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
211 struct mro_meta* meta;
215 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
216 assert(HvAUX(stash));
219 = HvAUX(stash)->xhv_name && HvENAME_HEK_NN(stash)
220 ? HvENAME_HEK_NN(stash)
224 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
227 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
230 meta = HvMROMETA(stash);
232 /* return cache if valid */
233 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
237 /* not in cache, make a new one */
239 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
240 /* We use this later in this function, but don't need a reference to it
241 beyond the end of this function, so reference count is fine. */
242 our_name = newSVhek(stashhek);
243 av_push(retval, our_name); /* add ourselves at the top */
246 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
247 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
249 /* "stored" is used to keep track of all of the classnames we have added to
250 the MRO so far, so we can do a quick exists check and avoid adding
251 duplicate classnames to the MRO as we go.
252 It's then retained to be re-used as a fast lookup for ->isa(), by adding
253 our own name and "UNIVERSAL" to it. */
255 if(av && AvFILLp(av) >= 0) {
257 SV **svp = AvARRAY(av);
258 I32 items = AvFILLp(av) + 1;
262 SV* const sv = *svp++;
263 HV* const basestash = gv_stashsv(sv, 0);
268 /* if no stash exists for this @ISA member,
269 simply add it to the MRO and move on */
274 /* otherwise, recurse into ourselves for the MRO
275 of this @ISA member, and append their MRO to ours.
276 The recursive call could throw an exception, which
277 has memory management implications here, hence the use of
279 const AV *const subrv
280 = mro_get_linear_isa_dfs(basestash, level + 1);
282 subrv_p = AvARRAY(subrv);
283 subrv_items = AvFILLp(subrv) + 1;
286 while(subrv_items--) {
287 SV *const subsv = *subrv_p++;
288 /* LVALUE fetch will create a new undefined SV if necessary
290 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
292 if(HeVAL(he) != &PL_sv_undef) {
293 /* It was newly created. Steal it for our new SV, and
294 replace it in the hash with the "real" thing. */
295 SV *const val = HeVAL(he);
296 HEK *const key = HeKEY_hek(he);
298 HeVAL(he) = &PL_sv_undef;
299 /* Save copying by making a shared hash key scalar. We
300 inline this here rather than calling
301 Perl_newSVpvn_share because we already have the
302 scalar, and we already have the hash key. */
303 assert(SvTYPE(val) == SVt_NULL);
304 sv_upgrade(val, SVt_PV);
305 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
306 SvCUR_set(val, HEK_LEN(key));
313 av_push(retval, val);
317 /* We are the first (or only) parent. We can short cut the
318 complexity above, because our @ISA is simply us prepended
319 to our parent's @ISA, and our ->isa cache is simply our
320 parent's, with our name added. */
321 /* newSVsv() is slow. This code is only faster if we can avoid
322 it by ensuring that SVs in the arrays are shared hash key
323 scalar SVs, because we can "copy" them very efficiently.
324 Although to be fair, we can't *ensure* this, as a reference
325 to the internal array is returned by mro::get_linear_isa(),
326 so we'll have to be defensive just in case someone faffed
330 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
331 av_extend(retval, subrv_items);
332 AvFILLp(retval) = subrv_items;
333 svp = AvARRAY(retval);
334 while(subrv_items--) {
335 SV *const val = *subrv_p++;
336 *++svp = SvIsCOW_shared_hash(val)
337 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
341 /* They have no stash. So create ourselves an ->isa cache
342 as if we'd copied it from what theirs should be. */
343 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
344 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
346 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
352 /* We have no parents. */
353 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
354 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
357 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
359 SvREFCNT_inc_simple_void_NN(stored);
361 SvREADONLY_on(stored);
365 /* now that we're past the exception dangers, grab our own reference to
366 the AV we're about to use for the result. The reference owned by the
367 mortals' stack will be released soon, so everything will balance. */
368 SvREFCNT_inc_simple_void_NN(retval);
371 /* we don't want anyone modifying the cache entry but us,
372 and we do so by replacing it completely */
373 SvREADONLY_on(retval);
375 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
376 MUTABLE_SV(retval)));
380 =for apidoc mro_get_linear_isa
382 Returns either C<mro_get_linear_isa_c3> or
383 C<mro_get_linear_isa_dfs> for the given stash,
384 dependant upon which MRO is in effect
385 for that stash. The return value is a
388 You are responsible for C<SvREFCNT_inc()> on the
389 return value if you plan to store it anywhere
390 semi-permanently (otherwise it might be deleted
391 out from under you the next time the cache is
397 Perl_mro_get_linear_isa(pTHX_ HV *stash)
399 struct mro_meta* meta;
402 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
404 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
406 meta = HvMROMETA(stash);
407 if (!meta->mro_which)
408 Perl_croak(aTHX_ "panic: invalid MRO!");
409 isa = meta->mro_which->resolve(aTHX_ stash, 0);
412 HV *const isa_hash = newHV();
413 /* Linearisation didn't build it for us, so do it here. */
414 SV *const *svp = AvARRAY(isa);
415 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
416 const HEK *canon_name = HvENAME_HEK(stash);
417 if (!canon_name) canon_name = HvNAME_HEK(stash);
419 while (svp < svp_end) {
420 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
423 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
424 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
425 HV_FETCH_ISSTORE, &PL_sv_undef,
426 HEK_HASH(canon_name));
427 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
429 SvREADONLY_on(isa_hash);
431 meta->isa = isa_hash;
438 =for apidoc mro_isa_changed_in
440 Takes the necessary steps (cache invalidations, mostly)
441 when the @ISA of the given package has changed. Invoked
442 by the C<setisa> magic, should not need to invoke directly.
447 Perl_mro_isa_changed_in(pTHX_ HV* stash)
456 struct mro_meta * meta;
459 const char * const stashname = HvENAME_get(stash);
460 const STRLEN stashname_len = HvENAMELEN_get(stash);
462 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
465 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
468 /* wipe out the cached linearizations for this stash */
469 meta = HvMROMETA(stash);
470 if (meta->mro_linear_all) {
471 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
472 meta->mro_linear_all = NULL;
473 /* This is just acting as a shortcut pointer. */
474 meta->mro_linear_current = NULL;
475 } else if (meta->mro_linear_current) {
476 /* Only the current MRO is stored, so this owns the data. */
477 SvREFCNT_dec(meta->mro_linear_current);
478 meta->mro_linear_current = NULL;
481 /* Steal it for our own purposes. */
482 isa = (HV *)sv_2mortal((SV *)meta->isa);
486 /* Inc the package generation, since our @ISA changed */
489 /* Wipe the global method cache if this package
490 is UNIVERSAL or one of its parents */
492 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
493 isarev = svp ? MUTABLE_HV(*svp) : NULL;
495 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
496 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
500 else { /* Wipe the local method cache otherwise */
502 is_universal = FALSE;
505 /* wipe next::method cache too */
506 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
508 /* Iterate the isarev (classes that are our children),
509 wiping out their linearization, method and isa caches
510 and upating PL_isarev. */
512 HV *isa_hashes = NULL;
514 /* We have to iterate through isarev twice to avoid a chicken and
515 * egg problem: if A inherits from B and both are in isarev, A might
516 * be processed before B and use B’s previous linearisation.
519 /* First iteration: Wipe everything, but stash away the isa hashes
520 * since we still need them for updating PL_isarev.
523 if(hv_iterinit(isarev)) {
524 /* Only create the hash if we need it; i.e., if isarev has
526 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
528 while((iter = hv_iternext(isarev))) {
530 const char* const revkey = hv_iterkey(iter, &len);
531 HV* revstash = gv_stashpvn(revkey, len, 0);
532 struct mro_meta* revmeta;
534 if(!revstash) continue;
535 revmeta = HvMROMETA(revstash);
536 if (revmeta->mro_linear_all) {
537 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
538 revmeta->mro_linear_all = NULL;
539 /* This is just acting as a shortcut pointer. */
540 revmeta->mro_linear_current = NULL;
541 } else if (revmeta->mro_linear_current) {
542 /* Only the current MRO is stored, so this owns the data. */
543 SvREFCNT_dec(revmeta->mro_linear_current);
544 revmeta->mro_linear_current = NULL;
547 revmeta->cache_gen++;
548 if(revmeta->mro_nextmethod)
549 hv_clear(revmeta->mro_nextmethod);
553 isa_hashes, (const char*)&revstash, sizeof(HV *),
554 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
559 /* Second pass: Update PL_isarev. We can just use isa_hashes to
560 * avoid another round of stash lookups. */
562 /* isarev might be deleted from PL_isarev during this loop, so hang
564 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
567 hv_iterinit(isa_hashes);
568 while((iter = hv_iternext(isa_hashes))) {
569 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
570 HV * const isa = (HV *)HeVAL(iter);
573 /* Re-calculate the linearisation, unless a previous iter-
574 ation was for a subclass of this class. */
575 if(!HvMROMETA(revstash)->isa)
576 (void)mro_get_linear_isa(revstash);
578 /* We're starting at the 2nd element, skipping revstash */
579 linear_mro = mro_get_linear_isa(revstash);
580 svp = AvARRAY(linear_mro) + 1;
581 items = AvFILLp(linear_mro);
583 namehek = HvENAME_HEK(revstash);
584 if (!namehek) namehek = HvNAME_HEK(revstash);
587 SV* const sv = *svp++;
590 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
592 /* That fetch should not fail. But if it had to create
593 a new SV for us, then will need to upgrade it to an
594 HV (which sv_upgrade() can now do for us). */
596 mroisarev = MUTABLE_HV(HeVAL(he));
598 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
600 /* This hash only ever contains PL_sv_yes. Storing it
601 over itself is almost as cheap as calling hv_exists,
602 so on aggregate we expect to save time by not making
603 two calls to the common HV code for the case where
608 mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
613 if((SV *)isa != &PL_sv_undef)
615 isa, HEK_KEY(namehek), HEK_LEN(namehek),
616 HvMROMETA(revstash)->isa
622 /* Now iterate our MRO (parents), adding ourselves and everything from
623 our isarev to their isarev.
626 /* We're starting at the 2nd element, skipping ourselves here */
627 linear_mro = mro_get_linear_isa(stash);
628 svp = AvARRAY(linear_mro) + 1;
629 items = AvFILLp(linear_mro);
632 SV* const sv = *svp++;
635 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
637 /* That fetch should not fail. But if it had to create a new SV for
638 us, then will need to upgrade it to an HV (which sv_upgrade() can
641 mroisarev = MUTABLE_HV(HeVAL(he));
643 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
645 /* This hash only ever contains PL_sv_yes. Storing it over itself is
646 almost as cheap as calling hv_exists, so on aggregate we expect to
647 save time by not making two calls to the common HV code for the
648 case where it doesn't exist. */
650 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
653 /* Delete our name from our former parents’ isarevs. */
654 if(isa && HvARRAY(isa))
655 mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
658 /* Deletes name from all the isarev entries listed in isa */
660 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
661 const STRLEN len, HV * const exceptions)
665 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
667 /* Delete our name from our former parents’ isarevs. */
668 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
670 while((iter = hv_iternext(isa))) {
672 const char * const key = hv_iterkey(iter, &klen);
673 if(exceptions && hv_exists(exceptions, key, klen)) continue;
674 svp = hv_fetch(PL_isarev, key, klen, 0);
676 HV * const isarev = (HV *)*svp;
677 (void)hv_delete(isarev, name, len, G_DISCARD);
678 if(!HvARRAY(isarev) || !HvKEYS(isarev))
679 (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
686 =for apidoc mro_package_moved
688 Call this function to signal to a stash that it has been assigned to
689 another spot in the stash hierarchy. C<stash> is the stash that has been
690 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
691 that is actually being assigned to. C<newname> and C<newname_len> are the
692 full name of the GV. If these last two arguments are omitted, they can be
693 inferred from C<gv>. C<gv> can be omitted if C<newname> is given.
695 This can also be called with a null first argument to
696 indicate that C<oldstash> has been deleted.
698 This function invalidates isa caches on the old stash, on all subpackages
699 nested inside it, and on the subclasses of all those, including
700 non-existent packages that have corresponding entries in C<stash>.
702 It also sets the effective names (C<HvENAME>) on all the stashes as
708 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
709 const GV *gv, const char *newname,
715 assert(stash || oldstash);
716 assert(gv || newname);
718 /* Determine the name of the location that stash was assigned to
719 * or from which oldstash was removed.
721 * We cannot reliably use the name in oldstash, because it may have
722 * been deleted from the location in the symbol table that its name
723 * suggests, as in this case:
725 * $globref = \*foo::bar::;
726 * Symbol::delete_package("foo");
727 * *$globref = \%baz::;
728 * *$globref = *frelp::;
729 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
731 * If newname is not null, then we trust that the caller gave us the
732 * right name. Otherwise, we get it from the gv. But if the gv is not
733 * in the symbol table, then we just return.
736 SV * const namesv = sv_newmortal();
738 gv_fullname4(namesv, gv, NULL, 0);
739 if(gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv) return;
740 newname = SvPV_const(namesv, len);
741 newname_len = len - 2; /* skip trailing :: */
743 if(newname_len < 0) newname_len = -newname_len;
745 /* Get a list of all the affected classes. */
746 /* We cannot simply pass them all to mro_isa_changed_in to avoid
747 the list, as that function assumes that only one package has
748 changed. It does not work with:
750 @foo::ISA = qw( B B::B );
751 *B:: = delete $::{"A::"};
753 as neither B nor B::B can be updated before the other, since they
754 will reset caches on foo, which will see either B or B::B with the
755 wrong name. The names must be set on *all* affected stashes before
758 stashes = (HV *) sv_2mortal((SV *)newHV());
759 mro_gather_and_rename(
760 stashes, (HV *) sv_2mortal((SV *)newHV()),
761 stash, oldstash, newname, newname_len
764 /* Iterate through the stashes, wiping isa linearisations, but leaving
765 the isa hash (which mro_isa_changed_in needs for adjusting the
766 isarev hashes belonging to parent classes). */
767 hv_iterinit(stashes);
768 while((iter = hv_iternext(stashes))) {
769 if(HeVAL(iter) != &PL_sv_yes && HvENAME(HeVAL(iter))) {
770 struct mro_meta* meta;
771 meta = HvMROMETA((HV *)HeVAL(iter));
772 if (meta->mro_linear_all) {
773 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
774 meta->mro_linear_all = NULL;
775 /* This is just acting as a shortcut pointer. */
776 meta->mro_linear_current = NULL;
777 } else if (meta->mro_linear_current) {
778 /* Only the current MRO is stored, so this owns the data. */
779 SvREFCNT_dec(meta->mro_linear_current);
780 meta->mro_linear_current = NULL;
785 /* Once the caches have been wiped on all the classes, call
786 mro_isa_changed_in on each. */
787 hv_iterinit(stashes);
788 while((iter = hv_iternext(stashes))) {
789 if(HvENAME(HeVAL(iter)))
790 mro_isa_changed_in((HV *)HeVAL(iter));
795 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
796 HV *stash, HV *oldstash, const char *name,
802 const bool stash_had_name = stash && HvENAME(stash);
807 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
809 /* We use the seen_stashes hash to keep track of which packages have
810 been encountered so far. This must be separate from the main list of
811 stashes, as we need to distinguish between stashes being assigned
812 and stashes being replaced/deleted. (A nested stash can be on both
813 sides of an assignment. We cannot simply skip iterating through a
814 stash on the right if we have seen it on the left, as it will not
815 get its ename assigned to it.)
817 To avoid allocating extra SVs, instead of a bitfield we can make
818 bizarre use of immortals:
820 &PL_sv_undef: seen on the left (oldstash)
821 &PL_sv_no : seen on the right (stash)
822 &PL_sv_yes : seen on both sides
827 /* Add to the big list. */
831 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
832 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
834 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
839 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
842 stashes, (const char *)&oldstash, sizeof(HV *),
843 SvREFCNT_inc_simple_NN((SV*)oldstash), 0
846 /* Update the effective name. */
847 if(HvENAME_get(oldstash)) {
848 const HEK * const enamehek = HvENAME_HEK(oldstash);
851 hv_delete(PL_stashcache, name, namlen, G_DISCARD);
852 hv_ename_delete(oldstash, name, namlen);
854 /* If the name deletion caused a name change, then we are not
855 * going to call mro_isa_changed_in with this name (and not at all
856 * if it has become anonymous) so we need to delete old isarev
857 * entries here, both those in the superclasses and this class’s
858 * own list of subclasses. We simply delete the latter from
859 * from PL_isarev, since we still need it. hv_delete mortifies it
860 * for us, so sv_2mortal is not necessary. */
861 if(HvENAME_HEK(oldstash) != enamehek) {
862 const struct mro_meta * meta = HvMROMETA(oldstash);
863 if(meta->isa && HvARRAY(meta->isa))
864 mro_clean_isarev(meta->isa, name, namlen, NULL);
865 isarev = (HV *)hv_delete(PL_isarev, name, namlen, 0);
871 hv_ename_add(stash, name, namlen);
873 /* Add it to the big list if it needs
874 * mro_isa_changed_in called on it. That happens if it was
875 * detached from the symbol table (so it had no HvENAME) before
876 * being assigned to the spot named by the ‘name’ variable, because
877 * its cached isa linerisation is now stale (the effective name
878 * having changed), and subclasses will then use that cache when
879 * mro_package_moved calls mro_isa_changed_in. (See
882 * If it did have a name, then its previous name is still
883 * used in isa caches, and there is no need for
884 * mro_package_moved to call mro_isa_changed_in.
890 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
891 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
893 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
897 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
901 stashes, (const char *)&stash, sizeof(HV *),
902 SvREFCNT_inc_simple_NN((SV *)stash), 0
907 if(!stash && !oldstash)
908 /* Both stashes have been encountered already. */
911 /* Add all the subclasses to the big list. */
915 (svp = hv_fetch(PL_isarev, name, namlen, 0))
916 && (isarev = MUTABLE_HV(*svp))
921 while((iter = hv_iternext(isarev))) {
923 const char* const revkey = hv_iterkey(iter, &len);
924 HV* revstash = gv_stashpvn(revkey, len, 0);
926 if(!revstash) continue;
929 stashes, (const char *)&revstash, sizeof(HV *),
930 SvREFCNT_inc_simple_NN((SV *)revstash), 0
936 (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
939 /* This is partly based on code in hv_iternext_flags. We are not call-
940 ing that here, as we want to avoid resetting the hash iterator. */
942 /* Skip the entire loop if the hash is empty. */
943 if(oldstash && HvUSEDKEYS(oldstash)) {
944 xhv = (XPVHV*)SvANY(oldstash);
945 seen = (HV *) sv_2mortal((SV *)newHV());
947 /* Iterate through entries in the oldstash, adding them to the
948 list, meanwhile doing the equivalent of $seen{$key} = 1.
951 while (++riter <= (I32)xhv->xhv_max) {
952 entry = (HvARRAY(oldstash))[riter];
954 /* Iterate through the entries in this list */
955 for(; entry; entry = HeNEXT(entry)) {
959 /* If this entry is not a glob, ignore it.
961 if (!isGV(HeVAL(entry))) continue;
963 key = hv_iterkey(entry, &len);
964 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
965 HV * const oldsubstash = GvHV(HeVAL(entry));
966 SV ** const stashentry
967 = stash ? hv_fetch(stash, key, len, 0) : NULL;
970 /* Avoid main::main::main::... */
971 if(oldsubstash == oldstash) continue;
975 stashentry && *stashentry
976 && (substash = GvHV(*stashentry))
978 || (oldsubstash && HvENAME_get(oldsubstash))
981 /* Add :: and the key (minus the trailing ::)
984 = newSVpvn_flags(name, namlen, SVs_TEMP);
988 sv_catpvs(namesv, "::");
989 sv_catpvn(namesv, key, len-2);
990 name = SvPV_const(namesv, namlen);
991 mro_gather_and_rename(
992 stashes, seen_stashes,
993 substash, oldsubstash, name, namlen
998 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
1004 /* Skip the entire loop if the hash is empty. */
1005 if (stash && HvUSEDKEYS(stash)) {
1006 xhv = (XPVHV*)SvANY(stash);
1009 /* Iterate through the new stash, skipping $seen{$key} items,
1010 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1011 while (++riter <= (I32)xhv->xhv_max) {
1012 entry = (HvARRAY(stash))[riter];
1014 /* Iterate through the entries in this list */
1015 for(; entry; entry = HeNEXT(entry)) {
1019 /* If this entry is not a glob, ignore it.
1021 if (!isGV(HeVAL(entry))) continue;
1023 key = hv_iterkey(entry, &len);
1024 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
1027 /* If this entry was seen when we iterated through the
1028 oldstash, skip it. */
1029 if(seen && hv_exists(seen, key, len)) continue;
1031 /* We get here only if this stash has no corresponding
1032 entry in the stash being replaced. */
1034 substash = GvHV(HeVAL(entry));
1037 const char *subname;
1040 /* Avoid checking main::main::main::... */
1041 if(substash == stash) continue;
1043 /* Add :: and the key (minus the trailing ::)
1046 = newSVpvn_flags(name, namlen, SVs_TEMP);
1047 sv_catpvs(namesv, "::");
1048 sv_catpvn(namesv, key, len-2);
1049 subname = SvPV_const(namesv, subnamlen);
1050 mro_gather_and_rename(
1051 stashes, seen_stashes,
1052 substash, NULL, subname, subnamlen
1062 =for apidoc mro_method_changed_in
1064 Invalidates method caching on any child classes
1065 of the given stash, so that they might notice
1066 the changes in this one.
1068 Ideally, all instances of C<PL_sub_generation++> in
1069 perl source outside of C<mro.c> should be
1070 replaced by calls to this.
1072 Perl automatically handles most of the common
1073 ways a method might be redefined. However, there
1074 are a few ways you could change a method in a stash
1075 without the cache code noticing, in which case you
1076 need to call this method afterwards:
1078 1) Directly manipulating the stash HV entries from
1081 2) Assigning a reference to a readonly scalar
1082 constant into a stash entry in order to create
1083 a constant subroutine (like constant.pm
1086 This same method is available from pure perl
1087 via, C<mro::method_changed_in(classname)>.
1092 Perl_mro_method_changed_in(pTHX_ HV *stash)
1094 const char * const stashname = HvENAME_get(stash);
1095 const STRLEN stashname_len = HvENAMELEN_get(stash);
1097 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
1098 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1100 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1103 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1105 /* Inc the package generation, since a local method changed */
1106 HvMROMETA(stash)->pkg_gen++;
1108 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1109 invalidate all method caches globally */
1110 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1111 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1112 PL_sub_generation++;
1116 /* else, invalidate the method caches of all child classes,
1121 hv_iterinit(isarev);
1122 while((iter = hv_iternext(isarev))) {
1124 const char* const revkey = hv_iterkey(iter, &len);
1125 HV* const revstash = gv_stashpvn(revkey, len, 0);
1126 struct mro_meta* mrometa;
1128 if(!revstash) continue;
1129 mrometa = HvMROMETA(revstash);
1130 mrometa->cache_gen++;
1131 if(mrometa->mro_nextmethod)
1132 hv_clear(mrometa->mro_nextmethod);
1138 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1140 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1142 PERL_ARGS_ASSERT_MRO_SET_MRO;
1145 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1147 if(meta->mro_which != which) {
1148 if (meta->mro_linear_current && !meta->mro_linear_all) {
1149 /* If we were storing something directly, put it in the hash before
1151 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1152 MUTABLE_SV(meta->mro_linear_current));
1154 meta->mro_which = which;
1155 /* Scrub our cached pointer to the private data. */
1156 meta->mro_linear_current = NULL;
1157 /* Only affects local method cache, not
1158 even child classes */
1160 if(meta->mro_nextmethod)
1161 hv_clear(meta->mro_nextmethod);
1167 XS(XS_mro_method_changed_in);
1170 Perl_boot_core_mro(pTHX)
1173 static const char file[] = __FILE__;
1175 Perl_mro_register(aTHX_ &dfs_alg);
1177 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1180 XS(XS_mro_method_changed_in)
1188 croak_xs_usage(cv, "classname");
1192 class_stash = gv_stashsv(classname, 0);
1193 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1195 mro_method_changed_in(class_stash);
1202 * c-indentation-style: bsd
1204 * indent-tabs-mode: t
1207 * ex: set ts=8 sts=4 sw=4 noet: