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