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.
9 * This was 'mro.c', but changed because there is another mro.c in /ext, and
10 * the os390 loader can't cope with this situation (which involves the two
11 * files calling functions defined in the other)
15 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
16 * You'll be last either way, Master Peregrin.'
18 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
23 These functions are related to the method resolution order of perl classes
24 Also see L<perlmroapi>.
33 static const struct mro_alg dfs_alg =
34 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
37 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
38 const struct mro_alg *const which)
41 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
43 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
44 which->name, which->length, which->kflags,
45 HV_FETCH_JUST_SV, NULL, which->hash);
49 /* If we've been asked to look up the private data for the current MRO, then
51 if (smeta->mro_which == which)
52 smeta->mro_linear_current = *data;
58 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
59 const struct mro_alg *const which, SV *const data)
61 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
63 if (!smeta->mro_linear_all) {
64 if (smeta->mro_which == which) {
65 /* If all we need to store is the current MRO's data, then don't use
66 memory on a hash with 1 element - store it direct, and signal
67 this by leaving the would-be-hash NULL. */
68 smeta->mro_linear_current = data;
71 HV *const hv = newHV();
72 /* Start with 2 buckets. It's unlikely we'll need more. */
74 smeta->mro_linear_all = hv;
76 if (smeta->mro_linear_current) {
77 /* If we were storing something directly, put it in the hash
79 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
80 smeta->mro_linear_current);
85 /* We get here if we're storing more than one linearisation for this stash,
86 or the linearisation we are storing is not that if its current MRO. */
88 if (smeta->mro_which == which) {
89 /* If we've been asked to store the private data for the current MRO,
91 smeta->mro_linear_current = data;
94 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
95 which->name, which->length, which->kflags,
96 HV_FETCH_ISSTORE, data, which->hash)) {
97 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
98 "for '%.*s' %d", (int) which->length, which->name,
105 const struct mro_alg *
106 Perl_mro_get_from_name(pTHX_ SV *name) {
109 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
111 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
112 HV_FETCH_JUST_SV, NULL, 0);
115 assert(SvTYPE(*data) == SVt_IV);
116 assert(SvIOK(*data));
117 return INT2PTR(const struct mro_alg *, SvUVX(*data));
121 =for apidoc mro_register
122 Registers a custom mro plugin. See L<perlmroapi> for details on this and other
129 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
130 SV *wrapper = newSVuv(PTR2UV(mro));
132 PERL_ARGS_ASSERT_MRO_REGISTER;
135 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
136 mro->name, mro->length, mro->kflags,
137 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
138 SvREFCNT_dec_NN(wrapper);
139 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
140 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
145 Perl_mro_meta_init(pTHX_ HV* stash)
147 struct mro_meta* newmeta;
149 PERL_ARGS_ASSERT_MRO_META_INIT;
151 assert(HvAUX(stash));
152 assert(!(HvAUX(stash)->xhv_mro_meta));
153 Newxz(newmeta, 1, struct mro_meta);
154 HvAUX(stash)->xhv_mro_meta = newmeta;
155 newmeta->cache_gen = 1;
156 newmeta->pkg_gen = 1;
157 newmeta->mro_which = &dfs_alg;
162 #if defined(USE_ITHREADS)
164 /* for sv_dup on new threads */
166 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
168 struct mro_meta* newmeta;
170 PERL_ARGS_ASSERT_MRO_META_DUP;
172 Newx(newmeta, 1, struct mro_meta);
173 Copy(smeta, newmeta, 1, struct mro_meta);
175 if (newmeta->mro_linear_all) {
176 newmeta->mro_linear_all
177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
178 /* This is just acting as a shortcut pointer, and will be automatically
179 updated on the first get. */
180 newmeta->mro_linear_current = NULL;
181 } else if (newmeta->mro_linear_current) {
182 /* Only the current MRO is stored, so this owns the data. */
183 newmeta->mro_linear_current
184 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
187 if (newmeta->mro_nextmethod)
188 newmeta->mro_nextmethod
189 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
192 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
194 newmeta->super = NULL;
196 /* clear the destructor cache */
197 newmeta->destroy = NULL;
198 newmeta->destroy_gen = 0;
203 #endif /* USE_ITHREADS */
206 =for apidoc mro_get_linear_isa_dfs
208 Returns the Depth-First Search linearization of C<@ISA>
209 the given stash. The return value is a read-only AV*.
210 C<level> should be 0 (it is used internally in this
211 function's recursion).
213 You are responsible for C<SvREFCNT_inc()> on the
214 return value if you plan to store it anywhere
215 semi-permanently (otherwise it might be deleted
216 out from under you the next time the cache is
222 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
229 struct mro_meta* meta;
233 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
234 assert(HvAUX(stash));
237 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
238 ? HvENAME_HEK_NN(stash)
242 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
246 "Recursive inheritance detected in package '%" HEKf "'",
249 meta = HvMROMETA(stash);
251 /* return cache if valid */
252 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
256 /* not in cache, make a new one */
258 retval = MUTABLE_AV(newSV_type_mortal(SVt_PVAV));
259 /* We use this later in this function, but don't need a reference to it
260 beyond the end of this function, so reference count is fine. */
261 our_name = newSVhek(stashhek);
262 av_push(retval, our_name); /* add ourselves at the top */
265 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
266 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
268 /* "stored" is used to keep track of all of the classnames we have added to
269 the MRO so far, so we can do a quick exists check and avoid adding
270 duplicate classnames to the MRO as we go.
271 It's then retained to be re-used as a fast lookup for ->isa(), by adding
272 our own name and "UNIVERSAL" to it. */
274 if(av && AvFILLp(av) >= 0) {
276 SV **svp = AvARRAY(av);
277 I32 items = AvFILLp(av) + 1;
281 SV* const sv = *svp ? *svp : &PL_sv_undef;
282 HV* const basestash = gv_stashsv(sv, 0);
288 /* if no stash exists for this @ISA member,
289 simply add it to the MRO and move on */
294 /* otherwise, recurse into ourselves for the MRO
295 of this @ISA member, and append their MRO to ours.
296 The recursive call could throw an exception, which
297 has memory management implications here, hence the use of
299 const AV *const subrv
300 = mro_get_linear_isa_dfs(basestash, level + 1);
302 subrv_p = AvARRAY(subrv);
303 subrv_items = AvFILLp(subrv) + 1;
306 while(subrv_items--) {
307 SV *const subsv = *subrv_p++;
308 /* LVALUE fetch will create a new undefined SV if necessary
310 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
312 if(HeVAL(he) != &PL_sv_undef) {
313 /* It was newly created. Steal it for our new SV, and
314 replace it in the hash with the "real" thing. */
315 SV *const val = HeVAL(he);
316 HEK *const key = HeKEY_hek(he);
318 HeVAL(he) = &PL_sv_undef;
320 av_push(retval, val);
324 /* We are the first (or only) parent. We can short cut the
325 complexity above, because our @ISA is simply us prepended
326 to our parent's @ISA, and our ->isa cache is simply our
327 parent's, with our name added. */
328 /* newSVsv() is slow. This code is only faster if we can avoid
329 it by ensuring that SVs in the arrays are shared hash key
330 scalar SVs, because we can "copy" them very efficiently.
331 Although to be fair, we can't *ensure* this, as a reference
332 to the internal array is returned by mro::get_linear_isa(),
333 so we'll have to be defensive just in case someone faffed
337 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
338 av_extend(retval, subrv_items);
339 AvFILLp(retval) = subrv_items;
340 svp = AvARRAY(retval);
341 while(subrv_items--) {
342 SV *const val = *subrv_p++;
343 *++svp = SvIsCOW_shared_hash(val)
344 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
348 /* They have no stash. So create ourselves an ->isa cache
349 as if we'd copied it from what theirs should be. */
350 stored = MUTABLE_HV(newSV_type_mortal(SVt_PVHV));
351 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef);
353 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
359 /* We have no parents. */
360 stored = MUTABLE_HV(newSV_type_mortal(SVt_PVHV));
361 (void) hv_stores(stored, "UNIVERSAL", &PL_sv_undef);
364 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
366 SvREFCNT_inc_simple_void_NN(stored);
368 SvREADONLY_on(stored);
372 /* now that we're past the exception dangers, grab our own reference to
373 the AV we're about to use for the result. The reference owned by the
374 mortals' stack will be released soon, so everything will balance. */
375 SvREFCNT_inc_simple_void_NN(retval);
378 /* we don't want anyone modifying the cache entry but us,
379 and we do so by replacing it completely */
380 SvREADONLY_on(retval);
382 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
383 MUTABLE_SV(retval)));
387 =for apidoc mro_get_linear_isa
389 Returns the mro linearisation for the given stash. By default, this
390 will be whatever C<mro_get_linear_isa_dfs> returns unless some
391 other MRO is in effect for the stash. The return value is a
394 You are responsible for C<SvREFCNT_inc()> on the
395 return value if you plan to store it anywhere
396 semi-permanently (otherwise it might be deleted
397 out from under you the next time the cache is
403 Perl_mro_get_linear_isa(pTHX_ HV *stash)
405 struct mro_meta* meta;
408 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
410 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
412 meta = HvMROMETA(stash);
413 if (!meta->mro_which)
414 Perl_croak(aTHX_ "panic: invalid MRO!");
415 isa = meta->mro_which->resolve(aTHX_ stash, 0);
417 if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
419 (HvENAME(stash)||HvNAME(stash))
420 ? newSVhek(HvENAME_HEK(stash)
425 if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
427 AV * const old = isa;
429 SV **ovp = AvARRAY(old);
430 SV * const * const oend = ovp + AvFILLp(old) + 1;
431 isa = (AV *)newSV_type_mortal(SVt_PVAV);
432 av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
433 *AvARRAY(isa) = namesv;
434 svp = AvARRAY(isa)+1;
435 while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
437 else SvREFCNT_dec(namesv);
441 HV *const isa_hash = newHV();
442 /* Linearisation didn't build it for us, so do it here. */
443 I32 count = AvFILLp(isa) + 1;
444 SV *const *svp = AvARRAY(isa);
445 SV *const *const svp_end = svp + count;
446 const HEK *canon_name = HvENAME_HEK(stash);
447 if (!canon_name) canon_name = HvNAME_HEK(stash);
449 if (count > PERL_HASH_DEFAULT_HvMAX) {
450 hv_ksplit(isa_hash, count);
453 while (svp < svp_end) {
454 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
457 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
458 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
459 HV_FETCH_ISSTORE, &PL_sv_undef,
460 HEK_HASH(canon_name));
461 (void) hv_stores(isa_hash, "UNIVERSAL", &PL_sv_undef);
463 SvREADONLY_on(isa_hash);
465 meta->isa = isa_hash;
472 =for apidoc mro_isa_changed_in
474 Takes the necessary steps (cache invalidations, mostly)
475 when the C<@ISA> of the given package has changed. Invoked
476 by the C<setisa> magic, should not need to invoke directly.
481 /* Macro to avoid repeating the code five times. */
482 #define CLEAR_LINEAR(mEta) \
483 if (mEta->mro_linear_all) { \
484 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
485 mEta->mro_linear_all = NULL; \
486 /* This is just acting as a shortcut pointer. */ \
487 mEta->mro_linear_current = NULL; \
488 } else if (mEta->mro_linear_current) { \
489 /* Only the current MRO is stored, so this owns the data. */ \
490 SvREFCNT_dec(mEta->mro_linear_current); \
491 mEta->mro_linear_current = NULL; \
495 Perl_mro_isa_changed_in(pTHX_ HV* stash)
503 struct mro_meta * meta;
506 const HEK * const stashhek = HvENAME_HEK(stash);
507 const char * const stashname = HvENAME_get(stash);
508 const STRLEN stashname_len = HvENAMELEN_get(stash);
510 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
513 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
516 /* wipe out the cached linearizations for this stash */
517 meta = HvMROMETA(stash);
520 /* Steal it for our own purposes. */
521 isa = (HV *)sv_2mortal((SV *)meta->isa);
525 /* Inc the package generation, since our @ISA changed */
528 /* Wipe the global method cache if this package
529 is UNIVERSAL or one of its parents */
531 svp = hv_fetchhek(PL_isarev, stashhek, 0);
532 isarev = svp ? MUTABLE_HV(*svp) : NULL;
534 if((memEQs(stashname, stashname_len, "UNIVERSAL"))
535 || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
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 */
549 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
550 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
552 /* DESTROY can be cached in meta. */
553 meta->destroy_gen = 0;
555 /* Iterate the isarev (classes that are our children),
556 wiping out their linearization, method and isa caches
557 and upating PL_isarev. */
559 HV *isa_hashes = NULL;
561 /* We have to iterate through isarev twice to avoid a chicken and
562 * egg problem: if A inherits from B and both are in isarev, A might
563 * be processed before B and use B's previous linearisation.
566 /* First iteration: Wipe everything, but stash away the isa hashes
567 * since we still need them for updating PL_isarev.
570 if(hv_iterinit(isarev)) {
571 /* Only create the hash if we need it; i.e., if isarev has
573 isa_hashes = (HV *)newSV_type_mortal(SVt_PVHV);
575 while((iter = hv_iternext(isarev))) {
576 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
577 struct mro_meta* revmeta;
579 if(!revstash) continue;
580 revmeta = HvMROMETA(revstash);
581 CLEAR_LINEAR(revmeta);
583 revmeta->cache_gen++;
584 if(revmeta->mro_nextmethod)
585 hv_clear(revmeta->mro_nextmethod);
586 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
590 isa_hashes, (const char*)&revstash, sizeof(HV *),
591 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
596 /* Second pass: Update PL_isarev. We can just use isa_hashes to
597 * avoid another round of stash lookups. */
599 /* isarev might be deleted from PL_isarev during this loop, so hang
601 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
604 hv_iterinit(isa_hashes);
605 while((iter = hv_iternext(isa_hashes))) {
606 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
607 HV * const isa = (HV *)HeVAL(iter);
610 /* We're starting at the 2nd element, skipping revstash */
611 linear_mro = mro_get_linear_isa(revstash);
612 svp = AvARRAY(linear_mro) + 1;
613 items = AvFILLp(linear_mro);
615 namehek = HvENAME_HEK(revstash);
616 if (!namehek) namehek = HvNAME_HEK(revstash);
619 SV* const sv = *svp++;
622 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
624 /* That fetch should not fail. But if it had to create
625 a new SV for us, then will need to upgrade it to an
626 HV (which sv_upgrade() can now do for us). */
628 mroisarev = MUTABLE_HV(HeVAL(he));
630 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
632 /* This hash only ever contains PL_sv_yes. Storing it
633 over itself is almost as cheap as calling hv_exists,
634 so on aggregate we expect to save time by not making
635 two calls to the common HV code for the case where
639 hv_storehek(mroisarev, namehek, &PL_sv_yes);
642 if ((SV *)isa != &PL_sv_undef && HvTOTALKEYS(isa)) {
645 isa, HEK_KEY(namehek), HEK_LEN(namehek),
646 HvMROMETA(revstash)->isa, HEK_HASH(namehek),
654 /* Now iterate our MRO (parents), adding ourselves and everything from
655 our isarev to their isarev.
658 /* We're starting at the 2nd element, skipping ourselves here */
659 linear_mro = mro_get_linear_isa(stash);
660 svp = AvARRAY(linear_mro) + 1;
661 items = AvFILLp(linear_mro);
664 SV* const sv = *svp++;
667 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
669 /* That fetch should not fail. But if it had to create a new SV for
670 us, then will need to upgrade it to an HV (which sv_upgrade() can
673 mroisarev = MUTABLE_HV(HeVAL(he));
675 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
677 /* This hash only ever contains PL_sv_yes. Storing it over itself is
678 almost as cheap as calling hv_exists, so on aggregate we expect to
679 save time by not making two calls to the common HV code for the
680 case where it doesn't exist. */
682 (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
685 /* Delete our name from our former parents' isarevs. */
686 if(isa && HvTOTALKEYS(isa))
687 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
688 HEK_HASH(stashhek), HEK_UTF8(stashhek));
691 /* Deletes name from all the isarev entries listed in isa.
692 Don't call this if isa is already empty. */
694 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
695 const STRLEN len, HV * const exceptions, U32 hash,
700 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
702 assert(HvTOTALKEYS(isa));
703 /* Delete our name from our former parents' isarevs. */
706 while((iter = hv_iternext(isa))) {
708 HEK *key = HeKEY_hek(iter);
709 if(exceptions && hv_existshek(exceptions, key))
711 svp = hv_fetchhek(PL_isarev, key, 0);
713 HV * const isarev = (HV *)*svp;
714 (void)hv_common(isarev, NULL, name, len, flags,
715 G_DISCARD|HV_DELETE, NULL, hash);
716 if(!HvTOTALKEYS(isarev))
717 (void)hv_deletehek(PL_isarev, key, G_DISCARD);
723 =for apidoc mro_package_moved
725 Call this function to signal to a stash that it has been assigned to
726 another spot in the stash hierarchy. C<stash> is the stash that has been
727 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
728 that is actually being assigned to.
730 This can also be called with a null first argument to
731 indicate that C<oldstash> has been deleted.
733 This function invalidates isa caches on the old stash, on all subpackages
734 nested inside it, and on the subclasses of all those, including
735 non-existent packages that have corresponding entries in C<stash>.
737 It also sets the effective names (C<HvENAME>) on all the stashes as
740 If the C<gv> is present and is not in the symbol table, then this function
741 simply returns. This checked will be skipped if C<flags & 1>.
746 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
747 const GV * const gv, U32 flags)
755 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
756 assert(stash || oldstash);
758 /* Determine the name(s) of the location that stash was assigned to
759 * or from which oldstash was removed.
761 * We cannot reliably use the name in oldstash, because it may have
762 * been deleted from the location in the symbol table that its name
763 * suggests, as in this case:
765 * $globref = \*foo::bar::;
766 * Symbol::delete_package("foo");
767 * *$globref = \%baz::;
768 * *$globref = *frelp::;
769 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
771 * So we get it from the gv. But, since the gv may no longer be in the
772 * symbol table, we check that first. The only reliable way to tell is
773 * to see whether its stash has an effective name and whether the gv
774 * resides in that stash under its name. That effective name may be
775 * different from what gv_fullname4 would use.
776 * If flags & 1, the caller has asked us to skip the check.
781 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
782 !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
786 assert(SvOOK(GvSTASH(gv)));
787 assert(GvNAMELEN(gv));
788 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
789 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
790 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
793 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
796 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
797 if (name_count < 0) ++namep, name_count = -name_count - 1;
799 if (name_count == 1) {
800 if (memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")) {
801 namesv = GvNAMELEN(gv) == 1
802 ? newSVpvs_flags(":", SVs_TEMP)
803 : newSVpvs_flags("", SVs_TEMP);
806 namesv = sv_2mortal(newSVhek(*namep));
807 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
808 else sv_catpvs(namesv, "::");
810 if (GvNAMELEN(gv) != 1) {
812 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
813 /* skip trailing :: */
814 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
820 namesv = newSV_type_mortal(SVt_PVAV);
821 while (name_count--) {
822 if(memEQs(HEK_KEY(*namep), HEK_LEN(*namep), "main")){
823 aname = GvNAMELEN(gv) == 1
829 aname = newSVhek(*namep++);
830 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
831 else sv_catpvs(aname, "::");
833 if (GvNAMELEN(gv) != 1) {
835 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
836 /* skip trailing :: */
837 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
840 av_push((AV *)namesv, aname);
844 /* Get a list of all the affected classes. */
845 /* We cannot simply pass them all to mro_isa_changed_in to avoid
846 the list, as that function assumes that only one package has
847 changed. It does not work with:
849 @foo::ISA = qw( B B::B );
850 *B:: = delete $::{"A::"};
852 as neither B nor B::B can be updated before the other, since they
853 will reset caches on foo, which will see either B or B::B with the
854 wrong name. The names must be set on *all* affected stashes before
855 we do anything else. (And linearisations must be cleared, too.)
857 stashes = (HV *) newSV_type_mortal(SVt_PVHV);
858 mro_gather_and_rename(
859 stashes, (HV *) newSV_type_mortal(SVt_PVHV),
860 stash, oldstash, namesv
863 /* Once the caches have been wiped on all the classes, call
864 mro_isa_changed_in on each. */
865 hv_iterinit(stashes);
866 while((iter = hv_iternext(stashes))) {
867 HV * const this_stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
868 if(HvENAME(this_stash)) {
869 /* We have to restore the original meta->isa (that
870 mro_gather_and_rename set aside for us) this way, in case
871 one class in this list is a superclass of a another class
872 that we have already encountered. In such a case, meta->isa
873 will have been overwritten without old entries being deleted
875 struct mro_meta * const meta = HvMROMETA(this_stash);
876 if(meta->isa != (HV *)HeVAL(iter)){
877 SvREFCNT_dec(meta->isa);
879 = HeVAL(iter) == &PL_sv_yes
882 HeVAL(iter) = NULL; /* We donated our reference count. */
884 mro_isa_changed_in(this_stash);
890 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
891 HV *stash, HV *oldstash, SV *namesv)
897 const bool stash_had_name = stash && HvENAME(stash);
898 bool fetched_isarev = FALSE;
903 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
905 /* We use the seen_stashes hash to keep track of which packages have
906 been encountered so far. This must be separate from the main list of
907 stashes, as we need to distinguish between stashes being assigned
908 and stashes being replaced/deleted. (A nested stash can be on both
909 sides of an assignment. We cannot simply skip iterating through a
910 stash on the right if we have seen it on the left, as it will not
911 get its ename assigned to it.)
913 To avoid allocating extra SVs, instead of a bitfield we can make
914 bizarre use of immortals:
916 &PL_sv_undef: seen on the left (oldstash)
917 &PL_sv_no : seen on the right (stash)
918 &PL_sv_yes : seen on both sides
923 /* Add to the big list. */
924 struct mro_meta * meta;
928 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
929 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
931 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
936 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
937 meta = HvMROMETA(oldstash);
940 stashes, (const char *)&oldstash, sizeof(HV *),
942 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
948 /* Update the effective name. */
949 if(HvENAME_get(oldstash)) {
950 const HEK * const enamehek = HvENAME_HEK(oldstash);
951 if(SvTYPE(namesv) == SVt_PVAV) {
952 items = AvFILLp((AV *)namesv) + 1;
953 svp = AvARRAY((AV *)namesv);
960 const U32 name_utf8 = SvUTF8(*svp);
962 const char *name = SvPVx_const(*svp, len);
964 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%" SVf "'\n",
966 (void)hv_delete_ent(PL_stashcache, *svp, G_DISCARD, 0);
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 && HvTOTALKEYS(meta->isa))
981 mro_clean_isarev(meta->isa, name, len, 0, 0,
982 name_utf8 ? HVhek_UTF8 : 0);
983 isarev = (HV *)hv_delete_ent(PL_isarev, *svp, 0, 0);
994 if(SvTYPE(namesv) == SVt_PVAV) {
995 items = AvFILLp((AV *)namesv) + 1;
996 svp = AvARRAY((AV *)namesv);
1003 const U32 name_utf8 = SvUTF8(*svp);
1005 const char *name = SvPVx_const(*svp++, len);
1006 hv_ename_add(stash, name, len, name_utf8);
1009 /* Add it to the big list if it needs
1010 * mro_isa_changed_in called on it. That happens if it was
1011 * detached from the symbol table (so it had no HvENAME) before
1012 * being assigned to the spot named by the 'name' variable, because
1013 * its cached isa linearisation is now stale (the effective name
1014 * having changed), and subclasses will then use that cache when
1015 * mro_package_moved calls mro_isa_changed_in. (See
1018 * If it did have a name, then its previous name is still
1019 * used in isa caches, and there is no need for
1020 * mro_package_moved to call mro_isa_changed_in.
1026 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1027 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1029 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1033 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1036 struct mro_meta * const meta = HvMROMETA(stash);
1039 stashes, (const char *)&stash, sizeof(HV *),
1041 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1050 if(!stash && !oldstash)
1051 /* Both stashes have been encountered already. */
1054 /* Add all the subclasses to the big list. */
1055 if(!fetched_isarev) {
1056 /* If oldstash is not null, then we can use its HvENAME to look up
1057 the isarev hash, since all its subclasses will be listed there.
1058 It will always have an HvENAME. It the HvENAME was removed
1059 above, then fetch_isarev will be true, and this code will not be
1062 If oldstash is null, then this is an empty spot with no stash in
1063 it, so subclasses could be listed in isarev hashes belonging to
1064 any of the names, so we have to check all of them.
1066 assert(!oldstash || HvENAME(oldstash));
1068 /* Extra variable to avoid a compiler warning */
1069 const HEK * const hvename = HvENAME_HEK(oldstash);
1070 fetched_isarev = TRUE;
1071 svp = hv_fetchhek(PL_isarev, hvename, 0);
1072 if (svp) isarev = MUTABLE_HV(*svp);
1074 else if(SvTYPE(namesv) == SVt_PVAV) {
1075 items = AvFILLp((AV *)namesv) + 1;
1076 svp = AvARRAY((AV *)namesv);
1084 isarev || !fetched_isarev
1086 while (fetched_isarev || items--) {
1089 if (!fetched_isarev) {
1090 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1091 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1094 hv_iterinit(isarev);
1095 while((iter = hv_iternext(isarev))) {
1096 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1097 struct mro_meta * meta;
1099 if(!revstash) continue;
1100 meta = HvMROMETA(revstash);
1103 stashes, (const char *)&revstash, sizeof(HV *),
1105 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1112 if (fetched_isarev) break;
1116 /* This is partly based on code in hv_iternext_flags. We are not call-
1117 ing that here, as we want to avoid resetting the hash iterator. */
1119 /* Skip the entire loop if the hash is empty. */
1120 if(oldstash && HvTOTALKEYS(oldstash)) {
1121 xhv = (XPVHV*)SvANY(oldstash);
1122 seen = (HV *) newSV_type_mortal(SVt_PVHV);
1124 /* Iterate through entries in the oldstash, adding them to the
1125 list, meanwhile doing the equivalent of $seen{$key} = 1.
1128 while (++riter <= (I32)xhv->xhv_max) {
1129 entry = (HvARRAY(oldstash))[riter];
1131 /* Iterate through the entries in this list */
1132 for(; entry; entry = HeNEXT(entry)) {
1136 /* If this entry is not a glob, ignore it.
1138 if (!isGV(HeVAL(entry))) continue;
1140 key = hv_iterkey(entry, &len);
1141 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1142 || (len == 1 && key[0] == ':')) {
1143 HV * const oldsubstash = GvHV(HeVAL(entry));
1145 HV *substash = NULL;
1147 /* Avoid main::main::main::... */
1148 if(oldsubstash == oldstash) continue;
1150 stashentry = stash ? hv_fetchhek(stash, HeKEY_hek(entry), 0) : NULL;
1154 stashentry && *stashentry && isGV(*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 = newSV_type_mortal(SVt_PVAV);
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_storehek(seen, HeKEY_hek(entry), &PL_sv_yes);
1206 /* Skip the entire loop if the hash is empty. */
1207 if (stash && HvTOTALKEYS(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_existshek(seen, HeKEY_hek(entry))) 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 = newSV_type_mortal(SVt_PVAV);
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 F<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);
1324 SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
1325 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1327 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1330 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1332 /* Inc the package generation, since a local method changed */
1333 HvMROMETA(stash)->pkg_gen++;
1335 /* DESTROY can be cached in meta */
1336 HvMROMETA(stash)->destroy_gen = 0;
1338 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1339 invalidate all method caches globally */
1340 if((memEQs(stashname, stashname_len, "UNIVERSAL"))
1341 || (isarev && hv_existss(isarev, "UNIVERSAL"))) {
1342 PL_sub_generation++;
1346 /* else, invalidate the method caches of all child classes,
1351 hv_iterinit(isarev);
1352 while((iter = hv_iternext(isarev))) {
1353 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1354 struct mro_meta* mrometa;
1356 if(!revstash) continue;
1357 mrometa = HvMROMETA(revstash);
1358 mrometa->cache_gen++;
1359 if(mrometa->mro_nextmethod)
1360 hv_clear(mrometa->mro_nextmethod);
1361 mrometa->destroy_gen = 0;
1365 /* The method change may be due to *{$package . "::()"} = \&nil; in
1368 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
1369 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
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)
1407 static const char file[] = __FILE__;
1409 Perl_mro_register(aTHX_ &dfs_alg);
1411 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1414 XS(XS_mro_method_changed_in)
1421 croak_xs_usage(cv, "classname");
1425 class_stash = gv_stashsv(classname, 0);
1426 if(!class_stash) Perl_croak(aTHX_ "No such class: '%" SVf "'!", SVfARG(classname));
1428 mro_method_changed_in(class_stash);
1434 * ex: set ts=8 sts=4 sw=4 et: