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