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.
444 =for apidoc mro_isa_changed_in3
446 Takes the necessary steps (cache invalidations, mostly)
447 when the @ISA of the given package has changed. Invoked
448 by the C<setisa> magic, should not need to invoke directly.
450 The stash can be passed as the first argument, or its name and length as
451 the second and third (or both). If just the name is passed and the stash
452 does not exist, then only the subclasses' method and isa caches will be
458 Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
459 STRLEN stashname_len)
468 struct mro_meta * meta = NULL;
470 if(!stashname && stash) {
471 stashname = HvENAME_get(stash);
472 stashname_len = HvENAMELEN_get(stash);
475 stash = gv_stashpvn(stashname, stashname_len, 0 /* don't add */);
478 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
481 /* wipe out the cached linearizations for this stash */
482 meta = HvMROMETA(stash);
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;
494 SvREFCNT_dec(meta->isa);
498 /* Inc the package generation, since our @ISA changed */
502 /* Wipe the global method cache if this package
503 is UNIVERSAL or one of its parents */
505 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
506 isarev = svp ? MUTABLE_HV(*svp) : NULL;
508 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
509 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
513 else { /* Wipe the local method cache otherwise */
514 if(meta) meta->cache_gen++;
515 is_universal = FALSE;
518 /* wipe next::method cache too */
519 if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
521 /* Iterate the isarev (classes that are our children),
522 wiping out their linearization, method and isa caches */
525 while((iter = hv_iternext(isarev))) {
527 const char* const revkey = hv_iterkey(iter, &len);
528 HV* revstash = gv_stashpvn(revkey, len, 0);
529 struct mro_meta* revmeta;
531 if(!revstash) continue;
532 revmeta = HvMROMETA(revstash);
533 if (revmeta->mro_linear_all) {
534 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
535 revmeta->mro_linear_all = NULL;
536 /* This is just acting as a shortcut pointer. */
537 revmeta->mro_linear_current = NULL;
538 } else if (revmeta->mro_linear_current) {
539 /* Only the current MRO is stored, so this owns the data. */
540 SvREFCNT_dec(revmeta->mro_linear_current);
541 revmeta->mro_linear_current = NULL;
544 revmeta->cache_gen++;
545 if(revmeta->mro_nextmethod)
546 hv_clear(revmeta->mro_nextmethod);
548 SvREFCNT_dec(revmeta->isa);
554 /* Now iterate our MRO (parents), and do a few things:
555 1) instantiate with the "fake" flag if they don't exist
556 2) flag them as universal if we are universal
557 3) Add everything from our isarev to their isarev
560 /* This only applies if the stash exists. */
563 /* We're starting at the 2nd element, skipping ourselves here */
564 linear_mro = mro_get_linear_isa(stash);
565 svp = AvARRAY(linear_mro) + 1;
566 items = AvFILLp(linear_mro);
569 SV* const sv = *svp++;
572 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
574 /* That fetch should not fail. But if it had to create a new SV for
575 us, then will need to upgrade it to an HV (which sv_upgrade() can
578 mroisarev = MUTABLE_HV(HeVAL(he));
580 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
582 /* This hash only ever contains PL_sv_yes. Storing it over itself is
583 almost as cheap as calling hv_exists, so on aggregate we expect to
584 save time by not making two calls to the common HV code for the
585 case where it doesn't exist. */
587 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
591 while((iter = hv_iternext(isarev))) {
593 char* const revkey = hv_iterkey(iter, &revkeylen);
594 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
601 =for apidoc mro_package_moved
603 Call this function to signal to a stash that it has been assigned to
604 another spot in the stash hierarchy. C<stash> is the stash that has been
605 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
606 that is actually being assigned to. C<newname> and C<newname_len> are the
607 full name of the GV. If these last two arguments are omitted, they can be
608 inferred from C<gv>. C<gv> can be omitted if C<newname> is given.
610 This can also be called with a null first argument to
611 indicate that C<oldstash> has been deleted.
613 This function invalidates isa caches on the old stash, on all subpackages
614 nested inside it, and on the subclasses of all those, including
615 non-existent packages that have corresponding entries in C<stash>.
620 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
621 const GV *gv, const char *newname,
628 HV *seen_stashes = NULL;
629 const bool stash_had_name = stash && HvENAME(stash);
631 /* If newname_len is negative, then gv is actually the caller’s hash of
632 stashes that have been seen so far. */
634 assert(stash || oldstash);
635 assert((gv && newname_len >= 0) || newname);
637 if(newname_len < 0) seen_stashes = (HV *)gv, gv = NULL;
639 /* Determine the name of the location that stash was assigned to
640 * or from which oldstash was removed.
642 * We cannot reliably use the name in oldstash, because it may have
643 * been deleted from the location in the symbol table that its name
644 * suggests, as in this case:
646 * $globref = \*foo::bar::;
647 * Symbol::delete_package("foo");
648 * *$globref = \%baz::;
649 * *$globref = *frelp::;
650 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
652 * If newname is not null, then we trust that the caller gave us the
653 * right name. Otherwise, we get it from the gv. But if the gv is not
654 * in the symbol table, then we just return.
657 SV * const namesv = sv_newmortal();
659 gv_fullname4(namesv, gv, NULL, 0);
660 if(gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv) return;
661 newname = SvPV_const(namesv, len);
662 newname_len = len - 2; /* skip trailing :: */
664 if(newname_len < 0) newname_len = -newname_len;
666 if(oldstash && HvENAME_get(oldstash)) {
669 hv_delete(PL_stashcache, newname, newname_len, G_DISCARD);
670 hv_ename_delete(oldstash, newname, newname_len);
673 hv_ename_add(stash, newname, newname_len);
675 /* If this stash had been detached from the symbol table (so it
676 * had no HvENAME) before being assigned to spot whose name is in
677 * newname, then its isa cache would be stale (the effective name
678 * having changed), and subclasses of newname would then use that
679 * cache in the mro_isa_changed_in3(oldstash...) call below. (See
681 * If it did have a name, then its previous name is still
682 * used in isa caches, and there is no need for this call.
684 if(!stash_had_name) mro_isa_changed_in(stash);
687 mro_isa_changed_in3((HV *)oldstash, newname, newname_len);
690 (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
693 /* This is partly based on code in hv_iternext_flags. We are not call-
694 ing that here, as we want to avoid resetting the hash iterator. */
696 /* Skip the entire loop if the hash is empty. */
697 if(oldstash && HvUSEDKEYS(oldstash)) {
698 xhv = (XPVHV*)SvANY(oldstash);
699 seen = (HV *) sv_2mortal((SV *)newHV());
700 if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
702 /* Iterate through entries in the oldstash, calling
704 corresponding_entry_in_new_stash, current_entry, ...
706 meanwhile doing the equivalent of $seen{$key} = 1.
709 while (++riter <= (I32)xhv->xhv_max) {
710 entry = (HvARRAY(oldstash))[riter];
712 /* Iterate through the entries in this list */
713 for(; entry; entry = HeNEXT(entry)) {
717 /* If this entry is not a glob, ignore it.
719 if (!isGV(HeVAL(entry))) continue;
721 key = hv_iterkey(entry, &len);
722 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
723 HV * const oldsubstash = GvHV(HeVAL(entry));
724 SV ** const stashentry
725 = stash ? hv_fetch(stash, key, len, 0) : NULL;
728 /* Avoid main::main::main::... */
729 if(oldsubstash == oldstash) continue;
735 (const char *)&oldsubstash, sizeof(HV *), 0,
736 HV_FETCH_LVALUE, NULL, 0
738 if(HeVAL(entry) == &PL_sv_yes) continue;
739 HeVAL(entry) = &PL_sv_yes;
744 stashentry && *stashentry
745 && (substash = GvHV(*stashentry))
747 || (oldsubstash && HvENAME_get(oldsubstash))
750 /* Add :: and the key (minus the trailing ::)
753 = newSVpvn_flags(newname, newname_len, SVs_TEMP);
756 sv_catpvs(namesv, "::");
757 sv_catpvn(namesv, key, len-2);
758 name = SvPV_const(namesv, namlen);
760 substash, oldsubstash,
761 (GV *)seen_stashes, name, -namlen
765 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
771 /* Skip the entire loop if the hash is empty. */
772 if (stash && HvUSEDKEYS(stash)) {
773 xhv = (XPVHV*)SvANY(stash);
774 if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
776 /* Iterate through the new stash, skipping $seen{$key} items,
777 calling mro_package_moved(entry, NULL, ...). */
778 while (++riter <= (I32)xhv->xhv_max) {
779 entry = (HvARRAY(stash))[riter];
781 /* Iterate through the entries in this list */
782 for(; entry; entry = HeNEXT(entry)) {
786 /* If this entry is not a glob, ignore it.
788 if (!isGV(HeVAL(entry))) continue;
790 key = hv_iterkey(entry, &len);
791 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
794 /* If this entry was seen when we iterated through the
795 oldstash, skip it. */
796 if(seen && hv_exists(seen, key, len)) continue;
798 /* We get here only if this stash has no corresponding
799 entry in the stash being replaced. */
801 substash = GvHV(HeVAL(entry));
808 /* Avoid checking main::main::main::... */
809 if(substash == stash) continue;
814 (const char *)&substash, sizeof(HV *), 0,
815 HV_FETCH_LVALUE, NULL, 0
817 if(HeVAL(entry) == &PL_sv_yes) continue;
818 HeVAL(entry) = &PL_sv_yes;
820 /* Add :: and the key (minus the trailing ::)
823 = newSVpvn_flags(newname, newname_len, SVs_TEMP);
824 sv_catpvs(namesv, "::");
825 sv_catpvn(namesv, key, len-2);
826 name = SvPV_const(namesv, namlen);
828 substash, NULL, (GV *)seen_stashes, name, -namlen
838 =for apidoc mro_method_changed_in
840 Invalidates method caching on any child classes
841 of the given stash, so that they might notice
842 the changes in this one.
844 Ideally, all instances of C<PL_sub_generation++> in
845 perl source outside of C<mro.c> should be
846 replaced by calls to this.
848 Perl automatically handles most of the common
849 ways a method might be redefined. However, there
850 are a few ways you could change a method in a stash
851 without the cache code noticing, in which case you
852 need to call this method afterwards:
854 1) Directly manipulating the stash HV entries from
857 2) Assigning a reference to a readonly scalar
858 constant into a stash entry in order to create
859 a constant subroutine (like constant.pm
862 This same method is available from pure perl
863 via, C<mro::method_changed_in(classname)>.
868 Perl_mro_method_changed_in(pTHX_ HV *stash)
870 const char * const stashname = HvENAME_get(stash);
871 const STRLEN stashname_len = HvENAMELEN_get(stash);
873 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
874 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
876 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
879 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
881 /* Inc the package generation, since a local method changed */
882 HvMROMETA(stash)->pkg_gen++;
884 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
885 invalidate all method caches globally */
886 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
887 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
892 /* else, invalidate the method caches of all child classes,
898 while((iter = hv_iternext(isarev))) {
900 const char* const revkey = hv_iterkey(iter, &len);
901 HV* const revstash = gv_stashpvn(revkey, len, 0);
902 struct mro_meta* mrometa;
904 if(!revstash) continue;
905 mrometa = HvMROMETA(revstash);
906 mrometa->cache_gen++;
907 if(mrometa->mro_nextmethod)
908 hv_clear(mrometa->mro_nextmethod);
914 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
916 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
918 PERL_ARGS_ASSERT_MRO_SET_MRO;
921 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
923 if(meta->mro_which != which) {
924 if (meta->mro_linear_current && !meta->mro_linear_all) {
925 /* If we were storing something directly, put it in the hash before
927 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
928 MUTABLE_SV(meta->mro_linear_current));
930 meta->mro_which = which;
931 /* Scrub our cached pointer to the private data. */
932 meta->mro_linear_current = NULL;
933 /* Only affects local method cache, not
934 even child classes */
936 if(meta->mro_nextmethod)
937 hv_clear(meta->mro_nextmethod);
943 XS(XS_mro_method_changed_in);
946 Perl_boot_core_mro(pTHX)
949 static const char file[] = __FILE__;
951 Perl_mro_register(aTHX_ &dfs_alg);
953 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
956 XS(XS_mro_method_changed_in)
964 croak_xs_usage(cv, "classname");
968 class_stash = gv_stashsv(classname, 0);
969 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
971 mro_method_changed_in(class_stash);
978 * c-indentation-style: bsd
980 * indent-tabs-mode: t
983 * ex: set ts=8 sts=4 sw=4 noet: