This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Eliminate (X|F) convention from perldiag.
[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 /*
118 =for apidoc mro_register
119 Registers a custom mro plugin.  See L<perlmroapi> for details.
120 */
121
122 void
123 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
124     SV *wrapper = newSVuv(PTR2UV(mro));
125
126     PERL_ARGS_ASSERT_MRO_REGISTER;
127
128     
129     if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
130                         mro->name, mro->length, mro->kflags,
131                         HV_FETCH_ISSTORE, wrapper, mro->hash)) {
132         SvREFCNT_dec(wrapper);
133         Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
134                    "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
135     }
136 }
137
138 struct mro_meta*
139 Perl_mro_meta_init(pTHX_ HV* stash)
140 {
141     struct mro_meta* newmeta;
142
143     PERL_ARGS_ASSERT_MRO_META_INIT;
144     assert(HvAUX(stash));
145     assert(!(HvAUX(stash)->xhv_mro_meta));
146     Newxz(newmeta, 1, struct mro_meta);
147     HvAUX(stash)->xhv_mro_meta = newmeta;
148     newmeta->cache_gen = 1;
149     newmeta->pkg_gen = 1;
150     newmeta->mro_which = &dfs_alg;
151
152     return newmeta;
153 }
154
155 #if defined(USE_ITHREADS)
156
157 /* for sv_dup on new threads */
158 struct mro_meta*
159 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
160 {
161     struct mro_meta* newmeta;
162
163     PERL_ARGS_ASSERT_MRO_META_DUP;
164
165     Newx(newmeta, 1, struct mro_meta);
166     Copy(smeta, newmeta, 1, struct mro_meta);
167
168     if (newmeta->mro_linear_all) {
169         newmeta->mro_linear_all
170             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
171         /* This is just acting as a shortcut pointer, and will be automatically
172            updated on the first get.  */
173         newmeta->mro_linear_current = NULL;
174     } else if (newmeta->mro_linear_current) {
175         /* Only the current MRO is stored, so this owns the data.  */
176         newmeta->mro_linear_current
177             = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
178     }
179
180     if (newmeta->mro_nextmethod)
181         newmeta->mro_nextmethod
182             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
183     if (newmeta->isa)
184         newmeta->isa
185             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
186
187     return newmeta;
188 }
189
190 #endif /* USE_ITHREADS */
191
192 /*
193 =for apidoc mro_get_linear_isa_dfs
194
195 Returns the Depth-First Search linearization of @ISA
196 the given stash.  The return value is a read-only AV*.
197 C<level> should be 0 (it is used internally in this
198 function's recursion).
199
200 You are responsible for C<SvREFCNT_inc()> on the
201 return value if you plan to store it anywhere
202 semi-permanently (otherwise it might be deleted
203 out from under you the next time the cache is
204 invalidated).
205
206 =cut
207 */
208 static AV*
209 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
210 {
211     AV* retval;
212     GV** gvp;
213     GV* gv;
214     AV* av;
215     const HEK* stashhek;
216     struct mro_meta* meta;
217     SV *our_name;
218     HV *stored = NULL;
219
220     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
221     assert(HvAUX(stash));
222
223     stashhek
224      = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
225         ? HvENAME_HEK_NN(stash)
226         : HvNAME_HEK(stash);
227
228     if (!stashhek)
229       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
230
231     if (level > 100)
232         Perl_croak(aTHX_
233                   "Recursive inheritance detected in package '%"HEKf"'",
234                    HEKfARG(stashhek));
235
236     meta = HvMROMETA(stash);
237
238     /* return cache if valid */
239     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
240         return retval;
241     }
242
243     /* not in cache, make a new one */
244
245     retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
246     /* We use this later in this function, but don't need a reference to it
247        beyond the end of this function, so reference count is fine.  */
248     our_name = newSVhek(stashhek);
249     av_push(retval, our_name); /* add ourselves at the top */
250
251     /* fetch our @ISA */
252     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
253     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
254
255     /* "stored" is used to keep track of all of the classnames we have added to
256        the MRO so far, so we can do a quick exists check and avoid adding
257        duplicate classnames to the MRO as we go.
258        It's then retained to be re-used as a fast lookup for ->isa(), by adding
259        our own name and "UNIVERSAL" to it.  */
260
261     if(av && AvFILLp(av) >= 0) {
262
263         SV **svp = AvARRAY(av);
264         I32 items = AvFILLp(av) + 1;
265
266         /* foreach(@ISA) */
267         while (items--) {
268             SV* const sv = *svp++;
269             HV* const basestash = gv_stashsv(sv, 0);
270             SV *const *subrv_p;
271             I32 subrv_items;
272
273             if (!basestash) {
274                 /* if no stash exists for this @ISA member,
275                    simply add it to the MRO and move on */
276                 subrv_p = &sv;
277                 subrv_items = 1;
278             }
279             else {
280                 /* otherwise, recurse into ourselves for the MRO
281                    of this @ISA member, and append their MRO to ours.
282                    The recursive call could throw an exception, which
283                    has memory management implications here, hence the use of
284                    the mortal.  */
285                 const AV *const subrv
286                     = mro_get_linear_isa_dfs(basestash, level + 1);
287
288                 subrv_p = AvARRAY(subrv);
289                 subrv_items = AvFILLp(subrv) + 1;
290             }
291             if (stored) {
292                 while(subrv_items--) {
293                     SV *const subsv = *subrv_p++;
294                     /* LVALUE fetch will create a new undefined SV if necessary
295                      */
296                     HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
297                     assert(he);
298                     if(HeVAL(he) != &PL_sv_undef) {
299                         /* It was newly created.  Steal it for our new SV, and
300                            replace it in the hash with the "real" thing.  */
301                         SV *const val = HeVAL(he);
302                         HEK *const key = HeKEY_hek(he);
303
304                         HeVAL(he) = &PL_sv_undef;
305                         /* Save copying by making a shared hash key scalar. We
306                            inline this here rather than calling
307                            Perl_newSVpvn_share because we already have the
308                            scalar, and we already have the hash key.  */
309                         assert(SvTYPE(val) == SVt_NULL);
310                         sv_upgrade(val, SVt_PV);
311                         SvPV_set(val, HEK_KEY(share_hek_hek(key)));
312                         SvCUR_set(val, HEK_LEN(key));
313                         SvREADONLY_on(val);
314                         SvFAKE_on(val);
315                         SvPOK_on(val);
316                         if (HEK_UTF8(key))
317                             SvUTF8_on(val);
318
319                         av_push(retval, val);
320                     }
321                 }
322             } else {
323                 /* We are the first (or only) parent. We can short cut the
324                    complexity above, because our @ISA is simply us prepended
325                    to our parent's @ISA, and our ->isa cache is simply our
326                    parent's, with our name added.  */
327                 /* newSVsv() is slow. This code is only faster if we can avoid
328                    it by ensuring that SVs in the arrays are shared hash key
329                    scalar SVs, because we can "copy" them very efficiently.
330                    Although to be fair, we can't *ensure* this, as a reference
331                    to the internal array is returned by mro::get_linear_isa(),
332                    so we'll have to be defensive just in case someone faffed
333                    with it.  */
334                 if (basestash) {
335                     SV **svp;
336                     stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
337                     av_extend(retval, subrv_items);
338                     AvFILLp(retval) = subrv_items;
339                     svp = AvARRAY(retval);
340                     while(subrv_items--) {
341                         SV *const val = *subrv_p++;
342                         *++svp = SvIsCOW_shared_hash(val)
343                             ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
344                             : newSVsv(val);
345                     }
346                 } else {
347                     /* They have no stash.  So create ourselves an ->isa cache
348                        as if we'd copied it from what theirs should be.  */
349                     stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
350                     (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
351                     av_push(retval,
352                             newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
353                                                             &PL_sv_undef, 0))));
354                 }
355             }
356         }
357     } else {
358         /* We have no parents.  */
359         stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
360         (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
361     }
362
363     (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
364
365     SvREFCNT_inc_simple_void_NN(stored);
366     SvTEMP_off(stored);
367     SvREADONLY_on(stored);
368
369     meta->isa = stored;
370
371     /* now that we're past the exception dangers, grab our own reference to
372        the AV we're about to use for the result. The reference owned by the
373        mortals' stack will be released soon, so everything will balance.  */
374     SvREFCNT_inc_simple_void_NN(retval);
375     SvTEMP_off(retval);
376
377     /* we don't want anyone modifying the cache entry but us,
378        and we do so by replacing it completely */
379     SvREADONLY_on(retval);
380
381     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
382                                                 MUTABLE_SV(retval)));
383 }
384
385 /*
386 =for apidoc mro_get_linear_isa
387
388 Returns the mro linearisation for the given stash.  By default, this
389 will be whatever C<mro_get_linear_isa_dfs> returns unless some
390 other MRO is in effect for the stash.  The return value is a
391 read-only AV*.
392
393 You are responsible for C<SvREFCNT_inc()> on the
394 return value if you plan to store it anywhere
395 semi-permanently (otherwise it might be deleted
396 out from under you the next time the cache is
397 invalidated).
398
399 =cut
400 */
401 AV*
402 Perl_mro_get_linear_isa(pTHX_ HV *stash)
403 {
404     struct mro_meta* meta;
405     AV *isa;
406
407     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
408     if(!SvOOK(stash))
409         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
410
411     meta = HvMROMETA(stash);
412     if (!meta->mro_which)
413         Perl_croak(aTHX_ "panic: invalid MRO!");
414     isa = meta->mro_which->resolve(aTHX_ stash, 0);
415
416     if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
417         SV * const namesv =
418             (HvENAME(stash)||HvNAME(stash))
419               ? newSVhek(HvENAME_HEK(stash)
420                           ? HvENAME_HEK(stash)
421                           : HvNAME_HEK(stash))
422               : NULL;
423
424         if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
425         {
426             AV * const old = isa;
427             SV **svp;
428             SV **ovp = AvARRAY(old);
429             SV * const * const oend = ovp + AvFILLp(old) + 1;
430             isa = (AV *)sv_2mortal((SV *)newAV());
431             av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
432             *AvARRAY(isa) = namesv;
433             svp = AvARRAY(isa)+1;
434             while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
435         }
436         else SvREFCNT_dec(namesv);
437     }
438
439     if (!meta->isa) {
440             HV *const isa_hash = newHV();
441             /* Linearisation didn't build it for us, so do it here.  */
442             SV *const *svp = AvARRAY(isa);
443             SV *const *const svp_end = svp + AvFILLp(isa) + 1;
444             const HEK *canon_name = HvENAME_HEK(stash);
445             if (!canon_name) canon_name = HvNAME_HEK(stash);
446
447             while (svp < svp_end) {
448                 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
449             }
450
451             (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
452                              HEK_LEN(canon_name), HEK_FLAGS(canon_name),
453                              HV_FETCH_ISSTORE, &PL_sv_undef,
454                              HEK_HASH(canon_name));
455             (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
456
457             SvREADONLY_on(isa_hash);
458
459             meta->isa = isa_hash;
460     }
461
462     return isa;
463 }
464
465 /*
466 =for apidoc mro_isa_changed_in
467
468 Takes the necessary steps (cache invalidations, mostly)
469 when the @ISA of the given package has changed.  Invoked
470 by the C<setisa> magic, should not need to invoke directly.
471
472 =cut
473 */
474
475 /* Macro to avoid repeating the code five times. */
476 #define CLEAR_LINEAR(mEta)                                     \
477     if (mEta->mro_linear_all) {                                 \
478         SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all));          \
479         mEta->mro_linear_all = NULL;                              \
480         /* This is just acting as a shortcut pointer.  */          \
481         mEta->mro_linear_current = NULL;                            \
482     } else if (mEta->mro_linear_current) {                           \
483         /* Only the current MRO is stored, so this owns the data.  */ \
484         SvREFCNT_dec(mEta->mro_linear_current);                        \
485         mEta->mro_linear_current = NULL;                                \
486     }
487
488 void
489 Perl_mro_isa_changed_in(pTHX_ HV* stash)
490 {
491     dVAR;
492     HV* isarev;
493     AV* linear_mro;
494     HE* iter;
495     SV** svp;
496     I32 items;
497     bool is_universal;
498     struct mro_meta * meta;
499     HV *isa = NULL;
500
501     const char * const stashname = HvENAME_get(stash);
502     const STRLEN stashname_len = HvENAMELEN_get(stash);
503     const bool stashname_utf8  = HvENAMEUTF8(stash) ? 1 : 0;
504
505     PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
506
507     if(!stashname)
508         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
509
510
511     /* wipe out the cached linearizations for this stash */
512     meta = HvMROMETA(stash);
513     CLEAR_LINEAR(meta);
514     if (meta->isa) {
515         /* Steal it for our own purposes. */
516         isa = (HV *)sv_2mortal((SV *)meta->isa);
517         meta->isa = NULL;
518     }
519
520     /* Inc the package generation, since our @ISA changed */
521     meta->pkg_gen++;
522
523     /* Wipe the global method cache if this package
524        is UNIVERSAL or one of its parents */
525
526     svp = hv_fetch(PL_isarev, stashname,
527                         stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
528     isarev = svp ? MUTABLE_HV(*svp) : NULL;
529
530     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
531         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
532         PL_sub_generation++;
533         is_universal = TRUE;
534     }
535     else { /* Wipe the local method cache otherwise */
536         meta->cache_gen++;
537         is_universal = FALSE;
538     }
539
540     /* wipe next::method cache too */
541     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
542
543     /* Iterate the isarev (classes that are our children),
544        wiping out their linearization, method and isa caches
545        and upating PL_isarev. */
546     if(isarev) {
547         HV *isa_hashes = NULL;
548
549        /* We have to iterate through isarev twice to avoid a chicken and
550         * egg problem: if A inherits from B and both are in isarev, A might
551         * be processed before B and use B’s previous linearisation.
552         */
553
554        /* First iteration: Wipe everything, but stash away the isa hashes
555         * since we still need them for updating PL_isarev.
556         */
557
558         if(hv_iterinit(isarev)) {
559             /* Only create the hash if we need it; i.e., if isarev has
560                any elements. */
561             isa_hashes = (HV *)sv_2mortal((SV *)newHV());
562         }
563         while((iter = hv_iternext(isarev))) {
564             HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
565             struct mro_meta* revmeta;
566
567             if(!revstash) continue;
568             revmeta = HvMROMETA(revstash);
569             CLEAR_LINEAR(revmeta);
570             if(!is_universal)
571                 revmeta->cache_gen++;
572             if(revmeta->mro_nextmethod)
573                 hv_clear(revmeta->mro_nextmethod);
574
575             (void)
576               hv_store(
577                isa_hashes, (const char*)&revstash, sizeof(HV *),
578                revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
579               );
580             revmeta->isa = NULL;
581         }
582
583        /* Second pass: Update PL_isarev. We can just use isa_hashes to
584         * avoid another round of stash lookups. */
585
586        /* isarev might be deleted from PL_isarev during this loop, so hang
587         * on to it. */
588         SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
589
590         if(isa_hashes) {
591             hv_iterinit(isa_hashes);
592             while((iter = hv_iternext(isa_hashes))) {
593                 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
594                 HV * const isa = (HV *)HeVAL(iter);
595                 const HEK *namehek;
596
597                 /* We're starting at the 2nd element, skipping revstash */
598                 linear_mro = mro_get_linear_isa(revstash);
599                 svp = AvARRAY(linear_mro) + 1;
600                 items = AvFILLp(linear_mro);
601
602                 namehek = HvENAME_HEK(revstash);
603                 if (!namehek) namehek = HvNAME_HEK(revstash);
604
605                 while (items--) {
606                     SV* const sv = *svp++;
607                     HV* mroisarev;
608
609                     HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
610
611                     /* That fetch should not fail.  But if it had to create
612                        a new SV for us, then will need to upgrade it to an
613                        HV (which sv_upgrade() can now do for us). */
614
615                     mroisarev = MUTABLE_HV(HeVAL(he));
616
617                     SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
618
619                     /* This hash only ever contains PL_sv_yes. Storing it
620                        over itself is almost as cheap as calling hv_exists,
621                        so on aggregate we expect to save time by not making
622                        two calls to the common HV code for the case where
623                        it doesn't exist.  */
624            
625                     (void)
626                       hv_store(
627                        mroisarev, HEK_KEY(namehek),
628                        HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
629                        &PL_sv_yes, 0
630                       );
631                 }
632
633                 if((SV *)isa != &PL_sv_undef)
634                     mro_clean_isarev(
635                      isa, HEK_KEY(namehek), HEK_LEN(namehek),
636                      HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
637                     );
638             }
639         }
640     }
641
642     /* Now iterate our MRO (parents), adding ourselves and everything from
643        our isarev to their isarev.
644     */
645
646     /* We're starting at the 2nd element, skipping ourselves here */
647     linear_mro = mro_get_linear_isa(stash);
648     svp = AvARRAY(linear_mro) + 1;
649     items = AvFILLp(linear_mro);
650
651     while (items--) {
652         SV* const sv = *svp++;
653         HV* mroisarev;
654
655         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
656
657         /* That fetch should not fail.  But if it had to create a new SV for
658            us, then will need to upgrade it to an HV (which sv_upgrade() can
659            now do for us. */
660
661         mroisarev = MUTABLE_HV(HeVAL(he));
662
663         SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
664
665         /* This hash only ever contains PL_sv_yes. Storing it over itself is
666            almost as cheap as calling hv_exists, so on aggregate we expect to
667            save time by not making two calls to the common HV code for the
668            case where it doesn't exist.  */
669            
670         (void)hv_store(mroisarev, stashname,
671                 stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, &PL_sv_yes, 0);
672     }
673
674     /* Delete our name from our former parents’ isarevs. */
675     if(isa && HvARRAY(isa))
676         mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
677                                 (stashname_utf8 ? SVf_UTF8 : 0) );
678 }
679
680 /* Deletes name from all the isarev entries listed in isa */
681 STATIC void
682 S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
683                          const STRLEN len, HV * const exceptions, U32 flags)
684 {
685     HE* iter;
686
687     PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
688
689     /* Delete our name from our former parents’ isarevs. */
690     if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
691         SV **svp;
692         while((iter = hv_iternext(isa))) {
693             I32 klen;
694             const char * const key = hv_iterkey(iter, &klen);
695             if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
696                 continue;
697             svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
698             if(svp) {
699                 HV * const isarev = (HV *)*svp;
700                 (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -(I32)len : (I32)len, G_DISCARD);
701                 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
702                     (void)hv_delete(PL_isarev, key,
703                                         HeKUTF8(iter) ? -klen : klen, G_DISCARD);
704             }
705         }
706     }
707 }
708
709 /*
710 =for apidoc mro_package_moved
711
712 Call this function to signal to a stash that it has been assigned to
713 another spot in the stash hierarchy. C<stash> is the stash that has been
714 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
715 that is actually being assigned to.
716
717 This can also be called with a null first argument to
718 indicate that C<oldstash> has been deleted.
719
720 This function invalidates isa caches on the old stash, on all subpackages
721 nested inside it, and on the subclasses of all those, including
722 non-existent packages that have corresponding entries in C<stash>.
723
724 It also sets the effective names (C<HvENAME>) on all the stashes as
725 appropriate.
726
727 If the C<gv> is present and is not in the symbol table, then this function
728 simply returns. This checked will be skipped if C<flags & 1>.
729
730 =cut
731 */
732 void
733 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
734                        const GV * const gv, U32 flags)
735 {
736     SV *namesv;
737     HEK **namep;
738     I32 name_count;
739     HV *stashes;
740     HE* iter;
741
742     PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
743     assert(stash || oldstash);
744
745     /* Determine the name(s) of the location that stash was assigned to
746      * or from which oldstash was removed.
747      *
748      * We cannot reliably use the name in oldstash, because it may have
749      * been deleted from the location in the symbol table that its name
750      * suggests, as in this case:
751      *
752      *   $globref = \*foo::bar::;
753      *   Symbol::delete_package("foo");
754      *   *$globref = \%baz::;
755      *   *$globref = *frelp::;
756      *      # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
757      *
758      * So we get it from the gv. But, since the gv may no longer be in the
759      * symbol table, we check that first. The only reliable way to tell is
760      * to see whether its stash has an effective name and whether the gv
761      * resides in that stash under its name. That effective name may be
762      * different from what gv_fullname4 would use.
763      * If flags & 1, the caller has asked us to skip the check.
764      */
765     if(!(flags & 1)) {
766         SV **svp;
767         if(
768          !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
769          !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
770                             GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
771          *svp != (SV *)gv
772         ) return;
773     }
774     assert(SvOOK(GvSTASH(gv)));
775     assert(GvNAMELEN(gv));
776     assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
777     assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
778     name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
779     if (!name_count) {
780         name_count = 1;
781         namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
782     }
783     else {
784         namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
785         if (name_count < 0) ++namep, name_count = -name_count - 1;
786     }
787     if (name_count == 1) {
788         if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
789             namesv = GvNAMELEN(gv) == 1
790                 ? newSVpvs_flags(":", SVs_TEMP)
791                 : newSVpvs_flags("",  SVs_TEMP);
792         }
793         else {
794             namesv = sv_2mortal(newSVhek(*namep));
795             if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
796             else                    sv_catpvs(namesv, "::");
797         }
798         if (GvNAMELEN(gv) != 1) {
799             sv_catpvn_flags(
800                 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
801                                           /* skip trailing :: */
802                 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
803             );
804         }
805     }
806     else {
807         SV *aname;
808         namesv = sv_2mortal((SV *)newAV());
809         while (name_count--) {
810             if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
811                 aname = GvNAMELEN(gv) == 1
812                          ? newSVpvs(":")
813                          : newSVpvs("");
814                 namep++;
815             }
816             else {
817                 aname = newSVhek(*namep++);
818                 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
819                 else                    sv_catpvs(aname, "::");
820             }
821             if (GvNAMELEN(gv) != 1) {
822                 sv_catpvn_flags(
823                     aname, GvNAME(gv), GvNAMELEN(gv) - 2,
824                                           /* skip trailing :: */
825                     GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
826                 );
827             }
828             av_push((AV *)namesv, aname);
829         }
830     }
831
832     /* Get a list of all the affected classes. */
833     /* We cannot simply pass them all to mro_isa_changed_in to avoid
834        the list, as that function assumes that only one package has
835        changed. It does not work with:
836
837           @foo::ISA = qw( B B::B );
838           *B:: = delete $::{"A::"};
839
840        as neither B nor B::B can be updated before the other, since they
841        will reset caches on foo, which will see either B or B::B with the
842        wrong name. The names must be set on *all* affected stashes before
843        we do anything else. (And linearisations must be cleared, too.)
844      */
845     stashes = (HV *) sv_2mortal((SV *)newHV());
846     mro_gather_and_rename(
847      stashes, (HV *) sv_2mortal((SV *)newHV()),
848      stash, oldstash, namesv
849     );
850
851     /* Once the caches have been wiped on all the classes, call
852        mro_isa_changed_in on each. */
853     hv_iterinit(stashes);
854     while((iter = hv_iternext(stashes))) {
855         HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
856         if(HvENAME(stash)) {
857             /* We have to restore the original meta->isa (that
858                mro_gather_and_rename set aside for us) this way, in case
859                one class in this list is a superclass of a another class
860                that we have already encountered. In such a case, meta->isa
861                will have been overwritten without old entries being deleted 
862                from PL_isarev. */
863             struct mro_meta * const meta = HvMROMETA(stash);
864             if(meta->isa != (HV *)HeVAL(iter)){
865                 SvREFCNT_dec(meta->isa);
866                 meta->isa
867                  = HeVAL(iter) == &PL_sv_yes
868                     ? NULL
869                     : (HV *)HeVAL(iter);
870                 HeVAL(iter) = NULL; /* We donated our reference count. */
871             }
872             mro_isa_changed_in(stash);
873         }
874     }
875 }
876
877 void
878 S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
879                               HV *stash, HV *oldstash, SV *namesv)
880 {
881     register XPVHV* xhv;
882     register HE *entry;
883     I32 riter = -1;
884     I32 items = 0;
885     const bool stash_had_name = stash && HvENAME(stash);
886     bool fetched_isarev = FALSE;
887     HV *seen = NULL;
888     HV *isarev = NULL;
889     SV **svp = NULL;
890
891     PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
892
893     /* We use the seen_stashes hash to keep track of which packages have
894        been encountered so far. This must be separate from the main list of
895        stashes, as we need to distinguish between stashes being assigned
896        and stashes being replaced/deleted. (A nested stash can be on both
897        sides of an assignment. We cannot simply skip iterating through a
898        stash on the right if we have seen it on the left, as it will not
899        get its ename assigned to it.)
900
901        To avoid allocating extra SVs, instead of a bitfield we can make
902        bizarre use of immortals:
903
904         &PL_sv_undef:  seen on the left  (oldstash)
905         &PL_sv_no   :  seen on the right (stash)
906         &PL_sv_yes  :  seen on both sides
907
908      */
909
910     if(oldstash) {
911         /* Add to the big list. */
912         struct mro_meta * meta;
913         HE * const entry
914          = (HE *)
915              hv_common(
916               seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
917               HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
918              );
919         if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
920             oldstash = NULL;
921             goto check_stash;
922         }
923         HeVAL(entry)
924          = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
925         meta = HvMROMETA(oldstash);
926         (void)
927           hv_store(
928            stashes, (const char *)&oldstash, sizeof(HV *),
929            meta->isa
930             ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
931             : &PL_sv_yes,
932            0
933           );
934         CLEAR_LINEAR(meta);
935
936         /* Update the effective name. */
937         if(HvENAME_get(oldstash)) {
938             const HEK * const enamehek = HvENAME_HEK(oldstash);
939             if(SvTYPE(namesv) == SVt_PVAV) {
940                 items = AvFILLp((AV *)namesv) + 1;
941                 svp = AvARRAY((AV *)namesv);
942             }
943             else {
944                 items = 1;
945                 svp = &namesv;
946             }
947             while (items--) {
948                 const U32 name_utf8 = SvUTF8(*svp);
949                 STRLEN len;
950                 const char *name = SvPVx_const(*svp++, len);
951                 if(PL_stashcache)
952                    (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
953                 hv_ename_delete(oldstash, name, len, name_utf8);
954
955                 if (!fetched_isarev) {
956                     /* If the name deletion caused a name change, then we
957                      * are not going to call mro_isa_changed_in with this
958                      * name (and not at all if it has become anonymous) so
959                      * we need to delete old isarev entries here, both
960                      * those in the superclasses and this class’s own list
961                      * of subclasses. We simply delete the latter from
962                      * PL_isarev, since we still need it. hv_delete morti-
963                      * fies it for us, so sv_2mortal is not necessary. */
964                     if(HvENAME_HEK(oldstash) != enamehek) {
965                         if(meta->isa && HvARRAY(meta->isa))
966                             mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
967                         isarev = (HV *)hv_delete(PL_isarev, name,
968                                                     name_utf8 ? -(I32)len : (I32)len, 0);
969                         fetched_isarev=TRUE;
970                     }
971                 }
972             }
973         }
974     }
975    check_stash:
976     if(stash) {
977         if(SvTYPE(namesv) == SVt_PVAV) {
978             items = AvFILLp((AV *)namesv) + 1;
979             svp = AvARRAY((AV *)namesv);
980         }
981         else {
982             items = 1;
983             svp = &namesv;
984         }
985         while (items--) {
986             const U32 name_utf8 = SvUTF8(*svp);
987             STRLEN len;
988             const char *name = SvPVx_const(*svp++, len);
989             hv_ename_add(stash, name, len, name_utf8);
990         }
991
992        /* Add it to the big list if it needs
993         * mro_isa_changed_in called on it. That happens if it was
994         * detached from the symbol table (so it had no HvENAME) before
995         * being assigned to the spot named by the ‘name’ variable, because
996         * its cached isa linearisation is now stale (the effective name
997         * having changed), and subclasses will then use that cache when
998         * mro_package_moved calls mro_isa_changed_in. (See
999         * [perl #77358].)
1000         *
1001         * If it did have a name, then its previous name is still
1002         * used in isa caches, and there is no need for
1003         * mro_package_moved to call mro_isa_changed_in.
1004         */
1005
1006         entry
1007          = (HE *)
1008              hv_common(
1009               seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1010               HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1011              );
1012         if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1013             stash = NULL;
1014         else {
1015             HeVAL(entry)
1016              = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1017             if(!stash_had_name)
1018             {
1019                 struct mro_meta * const meta = HvMROMETA(stash);
1020                 (void)
1021                   hv_store(
1022                    stashes, (const char *)&stash, sizeof(HV *),
1023                    meta->isa
1024                     ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1025                     : &PL_sv_yes,
1026                    0
1027                   );
1028                 CLEAR_LINEAR(meta);
1029             }
1030         }
1031     }
1032
1033     if(!stash && !oldstash)
1034         /* Both stashes have been encountered already. */
1035         return;
1036
1037     /* Add all the subclasses to the big list. */
1038     if(!fetched_isarev) {
1039         /* If oldstash is not null, then we can use its HvENAME to look up
1040            the isarev hash, since all its subclasses will be listed there.
1041            It will always have an HvENAME. It the HvENAME was removed
1042            above, then fetch_isarev will be true, and this code will not be
1043            reached.
1044
1045            If oldstash is null, then this is an empty spot with no stash in
1046            it, so subclasses could be listed in isarev hashes belonging to
1047            any of the names, so we have to check all of them.
1048          */
1049         assert(!oldstash || HvENAME(oldstash));
1050         if (oldstash) {
1051             /* Extra variable to avoid a compiler warning */
1052             char * const hvename = HvENAME(oldstash);
1053             fetched_isarev = TRUE;
1054             svp = hv_fetch(PL_isarev, hvename,
1055                             HvENAMEUTF8(oldstash)
1056                                 ? -HvENAMELEN_get(oldstash)
1057                                 : HvENAMELEN_get(oldstash), 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
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 C<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     const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
1309
1310     SV ** const svp = hv_fetch(PL_isarev, stashname,
1311                                     stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
1312     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1313
1314     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1315
1316     if(!stashname)
1317         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1318
1319     /* Inc the package generation, since a local method changed */
1320     HvMROMETA(stash)->pkg_gen++;
1321
1322     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1323        invalidate all method caches globally */
1324     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1325         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1326         PL_sub_generation++;
1327         return;
1328     }
1329
1330     /* else, invalidate the method caches of all child classes,
1331        but not itself */
1332     if(isarev) {
1333         HE* iter;
1334
1335         hv_iterinit(isarev);
1336         while((iter = hv_iternext(isarev))) {
1337             HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1338             struct mro_meta* mrometa;
1339
1340             if(!revstash) continue;
1341             mrometa = HvMROMETA(revstash);
1342             mrometa->cache_gen++;
1343             if(mrometa->mro_nextmethod)
1344                 hv_clear(mrometa->mro_nextmethod);
1345         }
1346     }
1347 }
1348
1349 void
1350 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1351 {
1352     const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1353  
1354     PERL_ARGS_ASSERT_MRO_SET_MRO;
1355
1356     if (!which)
1357         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1358
1359     if(meta->mro_which != which) {
1360         if (meta->mro_linear_current && !meta->mro_linear_all) {
1361             /* If we were storing something directly, put it in the hash before
1362                we lose it. */
1363             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
1364                                       MUTABLE_SV(meta->mro_linear_current));
1365         }
1366         meta->mro_which = which;
1367         /* Scrub our cached pointer to the private data.  */
1368         meta->mro_linear_current = NULL;
1369         /* Only affects local method cache, not
1370            even child classes */
1371         meta->cache_gen++;
1372         if(meta->mro_nextmethod)
1373             hv_clear(meta->mro_nextmethod);
1374     }
1375 }
1376
1377 #include "XSUB.h"
1378
1379 XS(XS_mro_method_changed_in);
1380
1381 void
1382 Perl_boot_core_mro(pTHX)
1383 {
1384     dVAR;
1385     static const char file[] = __FILE__;
1386
1387     Perl_mro_register(aTHX_ &dfs_alg);
1388
1389     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1390 }
1391
1392 XS(XS_mro_method_changed_in)
1393 {
1394     dVAR;
1395     dXSARGS;
1396     SV* classname;
1397     HV* class_stash;
1398
1399     if(items != 1)
1400         croak_xs_usage(cv, "classname");
1401     
1402     classname = ST(0);
1403
1404     class_stash = gv_stashsv(classname, 0);
1405     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1406
1407     mro_method_changed_in(class_stash);
1408
1409     XSRETURN_EMPTY;
1410 }
1411
1412 /*
1413  * Local variables:
1414  * c-indentation-style: bsd
1415  * c-basic-offset: 4
1416  * indent-tabs-mode: t
1417  * End:
1418  *
1419  * ex: set ts=8 sts=4 sw=4 noet:
1420  */