This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
1264754128389789e60574be767e496e55a4a939
[perl5.git] / mro.c
1 /*    mro.c
2  *
3  *    Copyright (c) 2007 Brandon L Black
4  *    Copyright (c) 2007, 2008, 2009, 2010, 2011 Larry Wall and others
5  *
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.
8  *
9  */
10
11 /*
12  * 'Which order shall we go in?' said Frodo.  'Eldest first, or quickest first?
13  *  You'll be last either way, Master Peregrin.'
14  *
15  *     [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
16  */
17
18 /*
19 =head1 MRO Functions
20
21 These functions are related to the method resolution order of perl classes
22
23 =cut
24 */
25
26 #include "EXTERN.h"
27 #define PERL_IN_MRO_C
28 #include "perl.h"
29
30 static const struct mro_alg dfs_alg =
31     {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
32
33 SV *
34 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35                           const struct mro_alg *const which)
36 {
37     SV **data;
38     PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
39
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);
43     if (!data)
44         return NULL;
45
46     /* If we've been asked to look up the private data for the current MRO, then
47        cache it.  */
48     if (smeta->mro_which == which)
49         smeta->mro_linear_current = *data;
50
51     return *data;
52 }
53
54 SV *
55 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56                           const struct mro_alg *const which, SV *const data)
57 {
58     PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
59
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;
66             return data;
67         } else {
68             HV *const hv = newHV();
69             /* Start with 2 buckets. It's unlikely we'll need more. */
70             HvMAX(hv) = 1;      
71             smeta->mro_linear_all = hv;
72
73             if (smeta->mro_linear_current) {
74                 /* If we were storing something directly, put it in the hash
75                    before we lose it. */
76                 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, 
77                                           smeta->mro_linear_current);
78             }
79         }
80     }
81
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.  */
84
85     if (smeta->mro_which == which) {
86         /* If we've been asked to store the private data for the current MRO,
87            then cache it.  */
88         smeta->mro_linear_current = data;
89     }
90
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,
96                    which->kflags);
97     }
98
99     return data;
100 }
101
102 const struct mro_alg *
103 Perl_mro_get_from_name(pTHX_ SV *name) {
104     SV **data;
105
106     PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
107
108     data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109                                  HV_FETCH_JUST_SV, NULL, 0);
110     if (!data)
111         return NULL;
112     assert(SvTYPE(*data) == SVt_IV);
113     assert(SvIOK(*data));
114     return INT2PTR(const struct mro_alg *, SvUVX(*data));
115 }
116
117 /*
118 =for apidoc mro_register
119 Registers a custom mro plugin.  See L<perlmroapi> for details.
120
121 =cut
122 */
123
124 void
125 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
126     SV *wrapper = newSVuv(PTR2UV(mro));
127
128     PERL_ARGS_ASSERT_MRO_REGISTER;
129
130     
131     if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
132                         mro->name, mro->length, mro->kflags,
133                         HV_FETCH_ISSTORE, wrapper, mro->hash)) {
134         SvREFCNT_dec(wrapper);
135         Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
136                    "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
137     }
138 }
139
140 struct mro_meta*
141 Perl_mro_meta_init(pTHX_ HV* stash)
142 {
143     struct mro_meta* newmeta;
144
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;
153
154     return newmeta;
155 }
156
157 #if defined(USE_ITHREADS)
158
159 /* for sv_dup on new threads */
160 struct mro_meta*
161 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
162 {
163     struct mro_meta* newmeta;
164
165     PERL_ARGS_ASSERT_MRO_META_DUP;
166
167     Newx(newmeta, 1, struct mro_meta);
168     Copy(smeta, newmeta, 1, struct mro_meta);
169
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);
180     }
181
182     if (newmeta->mro_nextmethod)
183         newmeta->mro_nextmethod
184             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
185     if (newmeta->isa)
186         newmeta->isa
187             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
188
189     return newmeta;
190 }
191
192 #endif /* USE_ITHREADS */
193
194 /*
195 =for apidoc mro_get_linear_isa_dfs
196
197 Returns the Depth-First Search linearization of @ISA
198 the given stash.  The return value is a read-only AV*.
199 C<level> should be 0 (it is used internally in this
200 function's recursion).
201
202 You are responsible for C<SvREFCNT_inc()> on the
203 return value if you plan to store it anywhere
204 semi-permanently (otherwise it might be deleted
205 out from under you the next time the cache is
206 invalidated).
207
208 =cut
209 */
210 static AV*
211 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
212 {
213     AV* retval;
214     GV** gvp;
215     GV* gv;
216     AV* av;
217     const HEK* stashhek;
218     struct mro_meta* meta;
219     SV *our_name;
220     HV *stored = NULL;
221
222     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
223     assert(HvAUX(stash));
224
225     stashhek
226      = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
227         ? HvENAME_HEK_NN(stash)
228         : HvNAME_HEK(stash);
229
230     if (!stashhek)
231       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
232
233     if (level > 100)
234         Perl_croak(aTHX_
235                   "Recursive inheritance detected in package '%"HEKf"'",
236                    HEKfARG(stashhek));
237
238     meta = HvMROMETA(stash);
239
240     /* return cache if valid */
241     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
242         return retval;
243     }
244
245     /* not in cache, make a new one */
246
247     retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
248     /* We use this later in this function, but don't need a reference to it
249        beyond the end of this function, so reference count is fine.  */
250     our_name = newSVhek(stashhek);
251     av_push(retval, our_name); /* add ourselves at the top */
252
253     /* fetch our @ISA */
254     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
255     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
256
257     /* "stored" is used to keep track of all of the classnames we have added to
258        the MRO so far, so we can do a quick exists check and avoid adding
259        duplicate classnames to the MRO as we go.
260        It's then retained to be re-used as a fast lookup for ->isa(), by adding
261        our own name and "UNIVERSAL" to it.  */
262
263     if(av && AvFILLp(av) >= 0) {
264
265         SV **svp = AvARRAY(av);
266         I32 items = AvFILLp(av) + 1;
267
268         /* foreach(@ISA) */
269         while (items--) {
270             SV* const sv = *svp++;
271             HV* const basestash = gv_stashsv(sv, 0);
272             SV *const *subrv_p;
273             I32 subrv_items;
274
275             if (!basestash) {
276                 /* if no stash exists for this @ISA member,
277                    simply add it to the MRO and move on */
278                 subrv_p = &sv;
279                 subrv_items = 1;
280             }
281             else {
282                 /* otherwise, recurse into ourselves for the MRO
283                    of this @ISA member, and append their MRO to ours.
284                    The recursive call could throw an exception, which
285                    has memory management implications here, hence the use of
286                    the mortal.  */
287                 const AV *const subrv
288                     = mro_get_linear_isa_dfs(basestash, level + 1);
289
290                 subrv_p = AvARRAY(subrv);
291                 subrv_items = AvFILLp(subrv) + 1;
292             }
293             if (stored) {
294                 while(subrv_items--) {
295                     SV *const subsv = *subrv_p++;
296                     /* LVALUE fetch will create a new undefined SV if necessary
297                      */
298                     HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
299                     assert(he);
300                     if(HeVAL(he) != &PL_sv_undef) {
301                         /* It was newly created.  Steal it for our new SV, and
302                            replace it in the hash with the "real" thing.  */
303                         SV *const val = HeVAL(he);
304                         HEK *const key = HeKEY_hek(he);
305
306                         HeVAL(he) = &PL_sv_undef;
307                         /* Save copying by making a shared hash key scalar. We
308                            inline this here rather than calling
309                            Perl_newSVpvn_share because we already have the
310                            scalar, and we already have the hash key.  */
311                         assert(SvTYPE(val) == SVt_NULL);
312                         sv_upgrade(val, SVt_PV);
313                         SvPV_set(val, HEK_KEY(share_hek_hek(key)));
314                         SvCUR_set(val, HEK_LEN(key));
315                         SvIsCOW_on(val);
316                         SvPOK_on(val);
317                         if (HEK_UTF8(key))
318                             SvUTF8_on(val);
319
320                         av_push(retval, val);
321                     }
322                 }
323             } else {
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
334                    with it.  */
335                 if (basestash) {
336                     SV **svp;
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)))
345                             : newSVsv(val);
346                     }
347                 } else {
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(sv_2mortal(MUTABLE_SV(newHV())));
351                     (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
352                     av_push(retval,
353                             newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
354                                                             &PL_sv_undef, 0))));
355                 }
356             }
357         }
358     } else {
359         /* We have no parents.  */
360         stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
361         (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
362     }
363
364     (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
365
366     SvREFCNT_inc_simple_void_NN(stored);
367     SvTEMP_off(stored);
368     SvREADONLY_on(stored);
369
370     meta->isa = stored;
371
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);
376     SvTEMP_off(retval);
377
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);
381
382     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
383                                                 MUTABLE_SV(retval)));
384 }
385
386 /*
387 =for apidoc mro_get_linear_isa
388
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
392 read-only AV*.
393
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
398 invalidated).
399
400 =cut
401 */
402 AV*
403 Perl_mro_get_linear_isa(pTHX_ HV *stash)
404 {
405     struct mro_meta* meta;
406     AV *isa;
407
408     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
409     if(!SvOOK(stash))
410         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
411
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);
416
417     if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
418         SV * const namesv =
419             (HvENAME(stash)||HvNAME(stash))
420               ? newSVhek(HvENAME_HEK(stash)
421                           ? HvENAME_HEK(stash)
422                           : HvNAME_HEK(stash))
423               : NULL;
424
425         if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
426         {
427             AV * const old = isa;
428             SV **svp;
429             SV **ovp = AvARRAY(old);
430             SV * const * const oend = ovp + AvFILLp(old) + 1;
431             isa = (AV *)sv_2mortal((SV *)newAV());
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++);
436         }
437         else SvREFCNT_dec(namesv);
438     }
439
440     if (!meta->isa) {
441             HV *const isa_hash = newHV();
442             /* Linearisation didn't build it for us, so do it here.  */
443             SV *const *svp = AvARRAY(isa);
444             SV *const *const svp_end = svp + AvFILLp(isa) + 1;
445             const HEK *canon_name = HvENAME_HEK(stash);
446             if (!canon_name) canon_name = HvNAME_HEK(stash);
447
448             while (svp < svp_end) {
449                 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
450             }
451
452             (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
453                              HEK_LEN(canon_name), HEK_FLAGS(canon_name),
454                              HV_FETCH_ISSTORE, &PL_sv_undef,
455                              HEK_HASH(canon_name));
456             (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
457
458             SvREADONLY_on(isa_hash);
459
460             meta->isa = isa_hash;
461     }
462
463     return isa;
464 }
465
466 /*
467 =for apidoc mro_isa_changed_in
468
469 Takes the necessary steps (cache invalidations, mostly)
470 when the @ISA of the given package has changed.  Invoked
471 by the C<setisa> magic, should not need to invoke directly.
472
473 =cut
474 */
475
476 /* Macro to avoid repeating the code five times. */
477 #define CLEAR_LINEAR(mEta)                                     \
478     if (mEta->mro_linear_all) {                                 \
479         SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all));          \
480         mEta->mro_linear_all = NULL;                              \
481         /* This is just acting as a shortcut pointer.  */          \
482         mEta->mro_linear_current = NULL;                            \
483     } else if (mEta->mro_linear_current) {                           \
484         /* Only the current MRO is stored, so this owns the data.  */ \
485         SvREFCNT_dec(mEta->mro_linear_current);                        \
486         mEta->mro_linear_current = NULL;                                \
487     }
488
489 void
490 Perl_mro_isa_changed_in(pTHX_ HV* stash)
491 {
492     dVAR;
493     HV* isarev;
494     AV* linear_mro;
495     HE* iter;
496     SV** svp;
497     I32 items;
498     bool is_universal;
499     struct mro_meta * meta;
500     HV *isa = NULL;
501
502     const char * const stashname = HvENAME_get(stash);
503     const STRLEN stashname_len = HvENAMELEN_get(stash);
504     const bool stashname_utf8  = HvENAMEUTF8(stash) ? 1 : 0;
505
506     PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
507
508     if(!stashname)
509         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
510
511
512     /* wipe out the cached linearizations for this stash */
513     meta = HvMROMETA(stash);
514     CLEAR_LINEAR(meta);
515     if (meta->isa) {
516         /* Steal it for our own purposes. */
517         isa = (HV *)sv_2mortal((SV *)meta->isa);
518         meta->isa = NULL;
519     }
520
521     /* Inc the package generation, since our @ISA changed */
522     meta->pkg_gen++;
523
524     /* Wipe the global method cache if this package
525        is UNIVERSAL or one of its parents */
526
527     svp = hv_fetch(PL_isarev, stashname,
528                         stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
529     isarev = svp ? MUTABLE_HV(*svp) : NULL;
530
531     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
532         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
533         PL_sub_generation++;
534         is_universal = TRUE;
535     }
536     else { /* Wipe the local method cache otherwise */
537         meta->cache_gen++;
538         is_universal = FALSE;
539     }
540
541     /* wipe next::method cache too */
542     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
543
544     /* Changes to @ISA might turn overloading on */
545     HvAMAGIC_on(stash);
546
547     /* Iterate the isarev (classes that are our children),
548        wiping out their linearization, method and isa caches
549        and upating PL_isarev. */
550     if(isarev) {
551         HV *isa_hashes = NULL;
552
553        /* We have to iterate through isarev twice to avoid a chicken and
554         * egg problem: if A inherits from B and both are in isarev, A might
555         * be processed before B and use B's previous linearisation.
556         */
557
558        /* First iteration: Wipe everything, but stash away the isa hashes
559         * since we still need them for updating PL_isarev.
560         */
561
562         if(hv_iterinit(isarev)) {
563             /* Only create the hash if we need it; i.e., if isarev has
564                any elements. */
565             isa_hashes = (HV *)sv_2mortal((SV *)newHV());
566         }
567         while((iter = hv_iternext(isarev))) {
568             HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
569             struct mro_meta* revmeta;
570
571             if(!revstash) continue;
572             revmeta = HvMROMETA(revstash);
573             CLEAR_LINEAR(revmeta);
574             if(!is_universal)
575                 revmeta->cache_gen++;
576             if(revmeta->mro_nextmethod)
577                 hv_clear(revmeta->mro_nextmethod);
578
579             (void)
580               hv_store(
581                isa_hashes, (const char*)&revstash, sizeof(HV *),
582                revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
583               );
584             revmeta->isa = NULL;
585         }
586
587        /* Second pass: Update PL_isarev. We can just use isa_hashes to
588         * avoid another round of stash lookups. */
589
590        /* isarev might be deleted from PL_isarev during this loop, so hang
591         * on to it. */
592         SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
593
594         if(isa_hashes) {
595             hv_iterinit(isa_hashes);
596             while((iter = hv_iternext(isa_hashes))) {
597                 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
598                 HV * const isa = (HV *)HeVAL(iter);
599                 const HEK *namehek;
600
601                 /* We're starting at the 2nd element, skipping revstash */
602                 linear_mro = mro_get_linear_isa(revstash);
603                 svp = AvARRAY(linear_mro) + 1;
604                 items = AvFILLp(linear_mro);
605
606                 namehek = HvENAME_HEK(revstash);
607                 if (!namehek) namehek = HvNAME_HEK(revstash);
608
609                 while (items--) {
610                     SV* const sv = *svp++;
611                     HV* mroisarev;
612
613                     HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
614
615                     /* That fetch should not fail.  But if it had to create
616                        a new SV for us, then will need to upgrade it to an
617                        HV (which sv_upgrade() can now do for us). */
618
619                     mroisarev = MUTABLE_HV(HeVAL(he));
620
621                     SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
622
623                     /* This hash only ever contains PL_sv_yes. Storing it
624                        over itself is almost as cheap as calling hv_exists,
625                        so on aggregate we expect to save time by not making
626                        two calls to the common HV code for the case where
627                        it doesn't exist.  */
628            
629                     (void)
630                       hv_store(
631                        mroisarev, HEK_KEY(namehek),
632                        HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
633                        &PL_sv_yes, 0
634                       );
635                 }
636
637                 if((SV *)isa != &PL_sv_undef)
638                     mro_clean_isarev(
639                      isa, HEK_KEY(namehek), HEK_LEN(namehek),
640                      HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
641                     );
642             }
643         }
644     }
645
646     /* Now iterate our MRO (parents), adding ourselves and everything from
647        our isarev to their isarev.
648     */
649
650     /* We're starting at the 2nd element, skipping ourselves here */
651     linear_mro = mro_get_linear_isa(stash);
652     svp = AvARRAY(linear_mro) + 1;
653     items = AvFILLp(linear_mro);
654
655     while (items--) {
656         SV* const sv = *svp++;
657         HV* mroisarev;
658
659         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
660
661         /* That fetch should not fail.  But if it had to create a new SV for
662            us, then will need to upgrade it to an HV (which sv_upgrade() can
663            now do for us. */
664
665         mroisarev = MUTABLE_HV(HeVAL(he));
666
667         SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
668
669         /* This hash only ever contains PL_sv_yes. Storing it over itself is
670            almost as cheap as calling hv_exists, so on aggregate we expect to
671            save time by not making two calls to the common HV code for the
672            case where it doesn't exist.  */
673            
674         (void)hv_store(mroisarev, stashname,
675                 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0);
676     }
677
678     /* Delete our name from our former parents' isarevs. */
679     if(isa && HvARRAY(isa))
680         mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
681                                 (stashname_utf8 ? SVf_UTF8 : 0) );
682 }
683
684 /* Deletes name from all the isarev entries listed in isa */
685 STATIC void
686 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
687                          const STRLEN len, HV * const exceptions, U32 flags)
688 {
689     HE* iter;
690
691     PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
692
693     /* Delete our name from our former parents' isarevs. */
694     if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
695         SV **svp;
696         while((iter = hv_iternext(isa))) {
697             I32 klen;
698             const char * const key = hv_iterkey(iter, &klen);
699             if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
700                 continue;
701             svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
702             if(svp) {
703                 HV * const isarev = (HV *)*svp;
704                 (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, G_DISCARD);
705                 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
706                     (void)hv_delete(PL_isarev, key,
707                                         HeKUTF8(iter) ? -klen : klen, G_DISCARD);
708             }
709         }
710     }
711 }
712
713 /*
714 =for apidoc mro_package_moved
715
716 Call this function to signal to a stash that it has been assigned to
717 another spot in the stash hierarchy.  C<stash> is the stash that has been
718 assigned. C<oldstash> is the stash it replaces, if any.  C<gv> is the glob
719 that is actually being assigned to.
720
721 This can also be called with a null first argument to
722 indicate that C<oldstash> has been deleted.
723
724 This function invalidates isa caches on the old stash, on all subpackages
725 nested inside it, and on the subclasses of all those, including
726 non-existent packages that have corresponding entries in C<stash>.
727
728 It also sets the effective names (C<HvENAME>) on all the stashes as
729 appropriate.
730
731 If the C<gv> is present and is not in the symbol table, then this function
732 simply returns.  This checked will be skipped if C<flags & 1>.
733
734 =cut
735 */
736 void
737 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
738                        const GV * const gv, U32 flags)
739 {
740     SV *namesv;
741     HEK **namep;
742     I32 name_count;
743     HV *stashes;
744     HE* iter;
745
746     PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
747     assert(stash || oldstash);
748
749     /* Determine the name(s) of the location that stash was assigned to
750      * or from which oldstash was removed.
751      *
752      * We cannot reliably use the name in oldstash, because it may have
753      * been deleted from the location in the symbol table that its name
754      * suggests, as in this case:
755      *
756      *   $globref = \*foo::bar::;
757      *   Symbol::delete_package("foo");
758      *   *$globref = \%baz::;
759      *   *$globref = *frelp::;
760      *      # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
761      *
762      * So we get it from the gv. But, since the gv may no longer be in the
763      * symbol table, we check that first. The only reliable way to tell is
764      * to see whether its stash has an effective name and whether the gv
765      * resides in that stash under its name. That effective name may be
766      * different from what gv_fullname4 would use.
767      * If flags & 1, the caller has asked us to skip the check.
768      */
769     if(!(flags & 1)) {
770         SV **svp;
771         if(
772          !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
773          !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
774                             GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
775          *svp != (SV *)gv
776         ) return;
777     }
778     assert(SvOOK(GvSTASH(gv)));
779     assert(GvNAMELEN(gv));
780     assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
781     assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
782     name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
783     if (!name_count) {
784         name_count = 1;
785         namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
786     }
787     else {
788         namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
789         if (name_count < 0) ++namep, name_count = -name_count - 1;
790     }
791     if (name_count == 1) {
792         if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
793             namesv = GvNAMELEN(gv) == 1
794                 ? newSVpvs_flags(":", SVs_TEMP)
795                 : newSVpvs_flags("",  SVs_TEMP);
796         }
797         else {
798             namesv = sv_2mortal(newSVhek(*namep));
799             if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
800             else                    sv_catpvs(namesv, "::");
801         }
802         if (GvNAMELEN(gv) != 1) {
803             sv_catpvn_flags(
804                 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
805                                           /* skip trailing :: */
806                 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
807             );
808         }
809     }
810     else {
811         SV *aname;
812         namesv = sv_2mortal((SV *)newAV());
813         while (name_count--) {
814             if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
815                 aname = GvNAMELEN(gv) == 1
816                          ? newSVpvs(":")
817                          : newSVpvs("");
818                 namep++;
819             }
820             else {
821                 aname = newSVhek(*namep++);
822                 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
823                 else                    sv_catpvs(aname, "::");
824             }
825             if (GvNAMELEN(gv) != 1) {
826                 sv_catpvn_flags(
827                     aname, GvNAME(gv), GvNAMELEN(gv) - 2,
828                                           /* skip trailing :: */
829                     GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
830                 );
831             }
832             av_push((AV *)namesv, aname);
833         }
834     }
835
836     /* Get a list of all the affected classes. */
837     /* We cannot simply pass them all to mro_isa_changed_in to avoid
838        the list, as that function assumes that only one package has
839        changed. It does not work with:
840
841           @foo::ISA = qw( B B::B );
842           *B:: = delete $::{"A::"};
843
844        as neither B nor B::B can be updated before the other, since they
845        will reset caches on foo, which will see either B or B::B with the
846        wrong name. The names must be set on *all* affected stashes before
847        we do anything else. (And linearisations must be cleared, too.)
848      */
849     stashes = (HV *) sv_2mortal((SV *)newHV());
850     mro_gather_and_rename(
851      stashes, (HV *) sv_2mortal((SV *)newHV()),
852      stash, oldstash, namesv
853     );
854
855     /* Once the caches have been wiped on all the classes, call
856        mro_isa_changed_in on each. */
857     hv_iterinit(stashes);
858     while((iter = hv_iternext(stashes))) {
859         HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
860         if(HvENAME(stash)) {
861             /* We have to restore the original meta->isa (that
862                mro_gather_and_rename set aside for us) this way, in case
863                one class in this list is a superclass of a another class
864                that we have already encountered. In such a case, meta->isa
865                will have been overwritten without old entries being deleted 
866                from PL_isarev. */
867             struct mro_meta * const meta = HvMROMETA(stash);
868             if(meta->isa != (HV *)HeVAL(iter)){
869                 SvREFCNT_dec(meta->isa);
870                 meta->isa
871                  = HeVAL(iter) == &PL_sv_yes
872                     ? NULL
873                     : (HV *)HeVAL(iter);
874                 HeVAL(iter) = NULL; /* We donated our reference count. */
875             }
876             mro_isa_changed_in(stash);
877         }
878     }
879 }
880
881 STATIC void
882 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
883                               HV *stash, HV *oldstash, SV *namesv)
884 {
885     XPVHV* xhv;
886     HE *entry;
887     I32 riter = -1;
888     I32 items = 0;
889     const bool stash_had_name = stash && HvENAME(stash);
890     bool fetched_isarev = FALSE;
891     HV *seen = NULL;
892     HV *isarev = NULL;
893     SV **svp = NULL;
894
895     PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
896
897     /* We use the seen_stashes hash to keep track of which packages have
898        been encountered so far. This must be separate from the main list of
899        stashes, as we need to distinguish between stashes being assigned
900        and stashes being replaced/deleted. (A nested stash can be on both
901        sides of an assignment. We cannot simply skip iterating through a
902        stash on the right if we have seen it on the left, as it will not
903        get its ename assigned to it.)
904
905        To avoid allocating extra SVs, instead of a bitfield we can make
906        bizarre use of immortals:
907
908         &PL_sv_undef:  seen on the left  (oldstash)
909         &PL_sv_no   :  seen on the right (stash)
910         &PL_sv_yes  :  seen on both sides
911
912      */
913
914     if(oldstash) {
915         /* Add to the big list. */
916         struct mro_meta * meta;
917         HE * const entry
918          = (HE *)
919              hv_common(
920               seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
921               HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
922              );
923         if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
924             oldstash = NULL;
925             goto check_stash;
926         }
927         HeVAL(entry)
928          = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
929         meta = HvMROMETA(oldstash);
930         (void)
931           hv_store(
932            stashes, (const char *)&oldstash, sizeof(HV *),
933            meta->isa
934             ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
935             : &PL_sv_yes,
936            0
937           );
938         CLEAR_LINEAR(meta);
939
940         /* Update the effective name. */
941         if(HvENAME_get(oldstash)) {
942             const HEK * const enamehek = HvENAME_HEK(oldstash);
943             if(SvTYPE(namesv) == SVt_PVAV) {
944                 items = AvFILLp((AV *)namesv) + 1;
945                 svp = AvARRAY((AV *)namesv);
946             }
947             else {
948                 items = 1;
949                 svp = &namesv;
950             }
951             while (items--) {
952                 const U32 name_utf8 = SvUTF8(*svp);
953                 STRLEN len;
954                 const char *name = SvPVx_const(*svp, len);
955                 if(PL_stashcache) {
956                     DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
957                                      *svp));
958                    (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
959                 }
960                 ++svp;
961                 hv_ename_delete(oldstash, name, len, name_utf8);
962
963                 if (!fetched_isarev) {
964                     /* If the name deletion caused a name change, then we
965                      * are not going to call mro_isa_changed_in with this
966                      * name (and not at all if it has become anonymous) so
967                      * we need to delete old isarev entries here, both
968                      * those in the superclasses and this class's own list
969                      * of subclasses. We simply delete the latter from
970                      * PL_isarev, since we still need it. hv_delete morti-
971                      * fies it for us, so sv_2mortal is not necessary. */
972                     if(HvENAME_HEK(oldstash) != enamehek) {
973                         if(meta->isa && HvARRAY(meta->isa))
974                             mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
975                         isarev = (HV *)hv_delete(PL_isarev, name,
976                                                     name_utf8 ? -(I32)len : (I32)len, 0);
977                         fetched_isarev=TRUE;
978                     }
979                 }
980             }
981         }
982     }
983    check_stash:
984     if(stash) {
985         if(SvTYPE(namesv) == SVt_PVAV) {
986             items = AvFILLp((AV *)namesv) + 1;
987             svp = AvARRAY((AV *)namesv);
988         }
989         else {
990             items = 1;
991             svp = &namesv;
992         }
993         while (items--) {
994             const U32 name_utf8 = SvUTF8(*svp);
995             STRLEN len;
996             const char *name = SvPVx_const(*svp++, len);
997             hv_ename_add(stash, name, len, name_utf8);
998         }
999
1000        /* Add it to the big list if it needs
1001         * mro_isa_changed_in called on it. That happens if it was
1002         * detached from the symbol table (so it had no HvENAME) before
1003         * being assigned to the spot named by the 'name' variable, because
1004         * its cached isa linearisation is now stale (the effective name
1005         * having changed), and subclasses will then use that cache when
1006         * mro_package_moved calls mro_isa_changed_in. (See
1007         * [perl #77358].)
1008         *
1009         * If it did have a name, then its previous name is still
1010         * used in isa caches, and there is no need for
1011         * mro_package_moved to call mro_isa_changed_in.
1012         */
1013
1014         entry
1015          = (HE *)
1016              hv_common(
1017               seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1018               HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1019              );
1020         if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1021             stash = NULL;
1022         else {
1023             HeVAL(entry)
1024              = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1025             if(!stash_had_name)
1026             {
1027                 struct mro_meta * const meta = HvMROMETA(stash);
1028                 (void)
1029                   hv_store(
1030                    stashes, (const char *)&stash, sizeof(HV *),
1031                    meta->isa
1032                     ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1033                     : &PL_sv_yes,
1034                    0
1035                   );
1036                 CLEAR_LINEAR(meta);
1037             }
1038         }
1039     }
1040
1041     if(!stash && !oldstash)
1042         /* Both stashes have been encountered already. */
1043         return;
1044
1045     /* Add all the subclasses to the big list. */
1046     if(!fetched_isarev) {
1047         /* If oldstash is not null, then we can use its HvENAME to look up
1048            the isarev hash, since all its subclasses will be listed there.
1049            It will always have an HvENAME. It the HvENAME was removed
1050            above, then fetch_isarev will be true, and this code will not be
1051            reached.
1052
1053            If oldstash is null, then this is an empty spot with no stash in
1054            it, so subclasses could be listed in isarev hashes belonging to
1055            any of the names, so we have to check all of them.
1056          */
1057         assert(!oldstash || HvENAME(oldstash));
1058         if (oldstash) {
1059             /* Extra variable to avoid a compiler warning */
1060             char * const hvename = HvENAME(oldstash);
1061             fetched_isarev = TRUE;
1062             svp = hv_fetch(PL_isarev, hvename,
1063                             HvENAMEUTF8(oldstash)
1064                                 ? -HvENAMELEN_get(oldstash)
1065                                 : HvENAMELEN_get(oldstash), 0);
1066             if (svp) isarev = MUTABLE_HV(*svp);
1067         }
1068         else if(SvTYPE(namesv) == SVt_PVAV) {
1069             items = AvFILLp((AV *)namesv) + 1;
1070             svp = AvARRAY((AV *)namesv);
1071         }
1072         else {
1073             items = 1;
1074             svp = &namesv;
1075         }
1076     }
1077     if(
1078         isarev || !fetched_isarev
1079     ) {
1080       while (fetched_isarev || items--) {
1081         HE *iter;
1082
1083         if (!fetched_isarev) {
1084             HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1085             if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1086         }
1087
1088         hv_iterinit(isarev);
1089         while((iter = hv_iternext(isarev))) {
1090             HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1091             struct mro_meta * meta;
1092
1093             if(!revstash) continue;
1094             meta = HvMROMETA(revstash);
1095             (void)
1096               hv_store(
1097                stashes, (const char *)&revstash, sizeof(HV *),
1098                meta->isa
1099                 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1100                 : &PL_sv_yes,
1101                0
1102               );
1103             CLEAR_LINEAR(meta);
1104         }
1105
1106         if (fetched_isarev) break;
1107       }
1108     }
1109
1110     /* This is partly based on code in hv_iternext_flags. We are not call-
1111        ing that here, as we want to avoid resetting the hash iterator. */
1112
1113     /* Skip the entire loop if the hash is empty.   */
1114     if(oldstash && HvUSEDKEYS(oldstash)) { 
1115         xhv = (XPVHV*)SvANY(oldstash);
1116         seen = (HV *) sv_2mortal((SV *)newHV());
1117
1118         /* Iterate through entries in the oldstash, adding them to the
1119            list, meanwhile doing the equivalent of $seen{$key} = 1.
1120          */
1121
1122         while (++riter <= (I32)xhv->xhv_max) {
1123             entry = (HvARRAY(oldstash))[riter];
1124
1125             /* Iterate through the entries in this list */
1126             for(; entry; entry = HeNEXT(entry)) {
1127                 const char* key;
1128                 I32 len;
1129
1130                 /* If this entry is not a glob, ignore it.
1131                    Try the next.  */
1132                 if (!isGV(HeVAL(entry))) continue;
1133
1134                 key = hv_iterkey(entry, &len);
1135                 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1136                  || (len == 1 && key[0] == ':')) {
1137                     HV * const oldsubstash = GvHV(HeVAL(entry));
1138                     SV ** const stashentry
1139                      = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
1140                     HV *substash = NULL;
1141
1142                     /* Avoid main::main::main::... */
1143                     if(oldsubstash == oldstash) continue;
1144
1145                     if(
1146                         (
1147                             stashentry && *stashentry
1148                          && (substash = GvHV(*stashentry))
1149                         )
1150                      || (oldsubstash && HvENAME_get(oldsubstash))
1151                     )
1152                     {
1153                         /* Add :: and the key (minus the trailing ::)
1154                            to each name. */
1155                         SV *subname;
1156                         if(SvTYPE(namesv) == SVt_PVAV) {
1157                             SV *aname;
1158                             items = AvFILLp((AV *)namesv) + 1;
1159                             svp = AvARRAY((AV *)namesv);
1160                             subname = sv_2mortal((SV *)newAV());
1161                             while (items--) {
1162                                 aname = newSVsv(*svp++);
1163                                 if (len == 1)
1164                                     sv_catpvs(aname, ":");
1165                                 else {
1166                                     sv_catpvs(aname, "::");
1167                                     sv_catpvn_flags(
1168                                         aname, key, len-2,
1169                                         HeUTF8(entry)
1170                                            ? SV_CATUTF8 : SV_CATBYTES
1171                                     );
1172                                 }
1173                                 av_push((AV *)subname, aname);
1174                             }
1175                         }
1176                         else {
1177                             subname = sv_2mortal(newSVsv(namesv));
1178                             if (len == 1) sv_catpvs(subname, ":");
1179                             else {
1180                                 sv_catpvs(subname, "::");
1181                                 sv_catpvn_flags(
1182                                    subname, key, len-2,
1183                                    HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1184                                 );
1185                             }
1186                         }
1187                         mro_gather_and_rename(
1188                              stashes, seen_stashes,
1189                              substash, oldsubstash, subname
1190                         );
1191                     }
1192
1193                     (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
1194                 }
1195             }
1196         }
1197     }
1198
1199     /* Skip the entire loop if the hash is empty.   */
1200     if (stash && HvUSEDKEYS(stash)) {
1201         xhv = (XPVHV*)SvANY(stash);
1202         riter = -1;
1203
1204         /* Iterate through the new stash, skipping $seen{$key} items,
1205            calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1206         while (++riter <= (I32)xhv->xhv_max) {
1207             entry = (HvARRAY(stash))[riter];
1208
1209             /* Iterate through the entries in this list */
1210             for(; entry; entry = HeNEXT(entry)) {
1211                 const char* key;
1212                 I32 len;
1213
1214                 /* If this entry is not a glob, ignore it.
1215                    Try the next.  */
1216                 if (!isGV(HeVAL(entry))) continue;
1217
1218                 key = hv_iterkey(entry, &len);
1219                 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1220                  || (len == 1 && key[0] == ':')) {
1221                     HV *substash;
1222
1223                     /* If this entry was seen when we iterated through the
1224                        oldstash, skip it. */
1225                     if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
1226
1227                     /* We get here only if this stash has no corresponding
1228                        entry in the stash being replaced. */
1229
1230                     substash = GvHV(HeVAL(entry));
1231                     if(substash) {
1232                         SV *subname;
1233
1234                         /* Avoid checking main::main::main::... */
1235                         if(substash == stash) continue;
1236
1237                         /* Add :: and the key (minus the trailing ::)
1238                            to each name. */
1239                         if(SvTYPE(namesv) == SVt_PVAV) {
1240                             SV *aname;
1241                             items = AvFILLp((AV *)namesv) + 1;
1242                             svp = AvARRAY((AV *)namesv);
1243                             subname = sv_2mortal((SV *)newAV());
1244                             while (items--) {
1245                                 aname = newSVsv(*svp++);
1246                                 if (len == 1)
1247                                     sv_catpvs(aname, ":");
1248                                 else {
1249                                     sv_catpvs(aname, "::");
1250                                     sv_catpvn_flags(
1251                                         aname, key, len-2,
1252                                         HeUTF8(entry)
1253                                            ? SV_CATUTF8 : SV_CATBYTES
1254                                     );
1255                                 }
1256                                 av_push((AV *)subname, aname);
1257                             }
1258                         }
1259                         else {
1260                             subname = sv_2mortal(newSVsv(namesv));
1261                             if (len == 1) sv_catpvs(subname, ":");
1262                             else {
1263                                 sv_catpvs(subname, "::");
1264                                 sv_catpvn_flags(
1265                                    subname, key, len-2,
1266                                    HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1267                                 );
1268                             }
1269                         }
1270                         mro_gather_and_rename(
1271                           stashes, seen_stashes,
1272                           substash, NULL, subname
1273                         );
1274                     }
1275                 }
1276             }
1277         }
1278     }
1279 }
1280
1281 /*
1282 =for apidoc mro_method_changed_in
1283
1284 Invalidates method caching on any child classes
1285 of the given stash, so that they might notice
1286 the changes in this one.
1287
1288 Ideally, all instances of C<PL_sub_generation++> in
1289 perl source outside of F<mro.c> should be
1290 replaced by calls to this.
1291
1292 Perl automatically handles most of the common
1293 ways a method might be redefined.  However, there
1294 are a few ways you could change a method in a stash
1295 without the cache code noticing, in which case you
1296 need to call this method afterwards:
1297
1298 1) Directly manipulating the stash HV entries from
1299 XS code.
1300
1301 2) Assigning a reference to a readonly scalar
1302 constant into a stash entry in order to create
1303 a constant subroutine (like constant.pm
1304 does).
1305
1306 This same method is available from pure perl
1307 via, C<mro::method_changed_in(classname)>.
1308
1309 =cut
1310 */
1311 void
1312 Perl_mro_method_changed_in(pTHX_ HV *stash)
1313 {
1314     const char * const stashname = HvENAME_get(stash);
1315     const STRLEN stashname_len = HvENAMELEN_get(stash);
1316     const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
1317
1318     SV ** const svp = hv_fetch(PL_isarev, stashname,
1319                                     stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
1320     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1321
1322     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1323
1324     if(!stashname)
1325         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1326
1327     /* Inc the package generation, since a local method changed */
1328     HvMROMETA(stash)->pkg_gen++;
1329
1330     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1331        invalidate all method caches globally */
1332     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1333         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1334         PL_sub_generation++;
1335         return;
1336     }
1337
1338     /* else, invalidate the method caches of all child classes,
1339        but not itself */
1340     if(isarev) {
1341         HE* iter;
1342
1343         hv_iterinit(isarev);
1344         while((iter = hv_iternext(isarev))) {
1345             HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1346             struct mro_meta* mrometa;
1347
1348             if(!revstash) continue;
1349             mrometa = HvMROMETA(revstash);
1350             mrometa->cache_gen++;
1351             if(mrometa->mro_nextmethod)
1352                 hv_clear(mrometa->mro_nextmethod);
1353         }
1354     }
1355
1356     /* The method change may be due to *{$package . "::()"} = \&nil; in
1357        overload.pm. */
1358     HvAMAGIC_on(stash);
1359 }
1360
1361 void
1362 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1363 {
1364     const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1365  
1366     PERL_ARGS_ASSERT_MRO_SET_MRO;
1367
1368     if (!which)
1369         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1370
1371     if(meta->mro_which != which) {
1372         if (meta->mro_linear_current && !meta->mro_linear_all) {
1373             /* If we were storing something directly, put it in the hash before
1374                we lose it. */
1375             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
1376                                       MUTABLE_SV(meta->mro_linear_current));
1377         }
1378         meta->mro_which = which;
1379         /* Scrub our cached pointer to the private data.  */
1380         meta->mro_linear_current = NULL;
1381         /* Only affects local method cache, not
1382            even child classes */
1383         meta->cache_gen++;
1384         if(meta->mro_nextmethod)
1385             hv_clear(meta->mro_nextmethod);
1386     }
1387 }
1388
1389 #include "XSUB.h"
1390
1391 XS(XS_mro_method_changed_in);
1392
1393 void
1394 Perl_boot_core_mro(pTHX)
1395 {
1396     dVAR;
1397     static const char file[] = __FILE__;
1398
1399     Perl_mro_register(aTHX_ &dfs_alg);
1400
1401     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1402 }
1403
1404 XS(XS_mro_method_changed_in)
1405 {
1406     dVAR;
1407     dXSARGS;
1408     SV* classname;
1409     HV* class_stash;
1410
1411     if(items != 1)
1412         croak_xs_usage(cv, "classname");
1413     
1414     classname = ST(0);
1415
1416     class_stash = gv_stashsv(classname, 0);
1417     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1418
1419     mro_method_changed_in(class_stash);
1420
1421     XSRETURN_EMPTY;
1422 }
1423
1424 /*
1425  * Local variables:
1426  * c-indentation-style: bsd
1427  * c-basic-offset: 4
1428  * indent-tabs-mode: nil
1429  * End:
1430  *
1431  * ex: set ts=8 sts=4 sw=4 et:
1432  */