This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Switch the core MRO code over to HvENAME
[perl5.git] / mro.c
1 /*    mro.c
2  *
3  *    Copyright (c) 2007 Brandon L Black
4  *    Copyright (c) 2007, 2008 Larry Wall and others
5  *
6  *    You may distribute under the terms of either the GNU General Public
7  *    License or the Artistic License, as specified in the README file.
8  *
9  */
10
11 /*
12  * 'Which order shall we go in?' said Frodo.  'Eldest first, or quickest first?
13  *  You'll be last either way, Master Peregrin.'
14  *
15  *     [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
16  */
17
18 /*
19 =head1 MRO Functions
20
21 These functions are related to the method resolution order of perl classes
22
23 =cut
24 */
25
26 #include "EXTERN.h"
27 #define PERL_IN_MRO_C
28 #include "perl.h"
29
30 static const struct mro_alg dfs_alg =
31     {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
32
33 SV *
34 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35                           const struct mro_alg *const which)
36 {
37     SV **data;
38     PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
39
40     data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
41                                  which->name, which->length, which->kflags,
42                                  HV_FETCH_JUST_SV, NULL, which->hash);
43     if (!data)
44         return NULL;
45
46     /* If we've been asked to look up the private data for the current MRO, then
47        cache it.  */
48     if (smeta->mro_which == which)
49         smeta->mro_linear_current = *data;
50
51     return *data;
52 }
53
54 SV *
55 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56                           const struct mro_alg *const which, SV *const data)
57 {
58     PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
59
60     if (!smeta->mro_linear_all) {
61         if (smeta->mro_which == which) {
62             /* If all we need to store is the current MRO's data, then don't use
63                memory on a hash with 1 element - store it direct, and signal
64                this by leaving the would-be-hash NULL.  */
65             smeta->mro_linear_current = data;
66             return data;
67         } else {
68             HV *const hv = newHV();
69             /* Start with 2 buckets. It's unlikely we'll need more. */
70             HvMAX(hv) = 1;      
71             smeta->mro_linear_all = hv;
72
73             if (smeta->mro_linear_current) {
74                 /* If we were storing something directly, put it in the hash
75                    before we lose it. */
76                 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which, 
77                                           smeta->mro_linear_current);
78             }
79         }
80     }
81
82     /* We get here if we're storing more than one linearisation for this stash,
83        or the linearisation we are storing is not that if its current MRO.  */
84
85     if (smeta->mro_which == which) {
86         /* If we've been asked to store the private data for the current MRO,
87            then cache it.  */
88         smeta->mro_linear_current = data;
89     }
90
91     if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
92                         which->name, which->length, which->kflags,
93                         HV_FETCH_ISSTORE, data, which->hash)) {
94         Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
95                    "for '%.*s' %d", (int) which->length, which->name,
96                    which->kflags);
97     }
98
99     return data;
100 }
101
102 const struct mro_alg *
103 Perl_mro_get_from_name(pTHX_ SV *name) {
104     SV **data;
105
106     PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
107
108     data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109                                  HV_FETCH_JUST_SV, NULL, 0);
110     if (!data)
111         return NULL;
112     assert(SvTYPE(*data) == SVt_IV);
113     assert(SvIOK(*data));
114     return INT2PTR(const struct mro_alg *, SvUVX(*data));
115 }
116
117 void
118 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
119     SV *wrapper = newSVuv(PTR2UV(mro));
120
121     PERL_ARGS_ASSERT_MRO_REGISTER;
122
123     
124     if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
125                         mro->name, mro->length, mro->kflags,
126                         HV_FETCH_ISSTORE, wrapper, mro->hash)) {
127         SvREFCNT_dec(wrapper);
128         Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
129                    "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
130     }
131 }
132
133 struct mro_meta*
134 Perl_mro_meta_init(pTHX_ HV* stash)
135 {
136     struct mro_meta* newmeta;
137
138     PERL_ARGS_ASSERT_MRO_META_INIT;
139     assert(HvAUX(stash));
140     assert(!(HvAUX(stash)->xhv_mro_meta));
141     Newxz(newmeta, 1, struct mro_meta);
142     HvAUX(stash)->xhv_mro_meta = newmeta;
143     newmeta->cache_gen = 1;
144     newmeta->pkg_gen = 1;
145     newmeta->mro_which = &dfs_alg;
146
147     return newmeta;
148 }
149
150 #if defined(USE_ITHREADS)
151
152 /* for sv_dup on new threads */
153 struct mro_meta*
154 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
155 {
156     struct mro_meta* newmeta;
157
158     PERL_ARGS_ASSERT_MRO_META_DUP;
159
160     Newx(newmeta, 1, struct mro_meta);
161     Copy(smeta, newmeta, 1, struct mro_meta);
162
163     if (newmeta->mro_linear_all) {
164         newmeta->mro_linear_all
165             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
166         /* This is just acting as a shortcut pointer, and will be automatically
167            updated on the first get.  */
168         newmeta->mro_linear_current = NULL;
169     } else if (newmeta->mro_linear_current) {
170         /* Only the current MRO is stored, so this owns the data.  */
171         newmeta->mro_linear_current
172             = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
173     }
174
175     if (newmeta->mro_nextmethod)
176         newmeta->mro_nextmethod
177             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
178     if (newmeta->isa)
179         newmeta->isa
180             = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
181
182     return newmeta;
183 }
184
185 #endif /* USE_ITHREADS */
186
187 /*
188 =for apidoc mro_get_linear_isa_dfs
189
190 Returns the Depth-First Search linearization of @ISA
191 the given stash.  The return value is a read-only AV*.
192 C<level> should be 0 (it is used internally in this
193 function's recursion).
194
195 You are responsible for C<SvREFCNT_inc()> on the
196 return value if you plan to store it anywhere
197 semi-permanently (otherwise it might be deleted
198 out from under you the next time the cache is
199 invalidated).
200
201 =cut
202 */
203 static AV*
204 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
205 {
206     AV* retval;
207     GV** gvp;
208     GV* gv;
209     AV* av;
210     const HEK* stashhek;
211     struct mro_meta* meta;
212     SV *our_name;
213     HV *stored = NULL;
214
215     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
216     assert(HvAUX(stash));
217
218     stashhek
219      = HvAUX(stash)->xhv_name && HvENAME_HEK_NN(stash)
220         ? HvENAME_HEK_NN(stash)
221         : HvNAME_HEK(stash);
222
223     if (!stashhek)
224       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
225
226     if (level > 100)
227         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
228                    HEK_KEY(stashhek));
229
230     meta = HvMROMETA(stash);
231
232     /* return cache if valid */
233     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
234         return retval;
235     }
236
237     /* not in cache, make a new one */
238
239     retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
240     /* We use this later in this function, but don't need a reference to it
241        beyond the end of this function, so reference count is fine.  */
242     our_name = newSVhek(stashhek);
243     av_push(retval, our_name); /* add ourselves at the top */
244
245     /* fetch our @ISA */
246     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
247     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
248
249     /* "stored" is used to keep track of all of the classnames we have added to
250        the MRO so far, so we can do a quick exists check and avoid adding
251        duplicate classnames to the MRO as we go.
252        It's then retained to be re-used as a fast lookup for ->isa(), by adding
253        our own name and "UNIVERSAL" to it.  */
254
255     if(av && AvFILLp(av) >= 0) {
256
257         SV **svp = AvARRAY(av);
258         I32 items = AvFILLp(av) + 1;
259
260         /* foreach(@ISA) */
261         while (items--) {
262             SV* const sv = *svp++;
263             HV* const basestash = gv_stashsv(sv, 0);
264             SV *const *subrv_p;
265             I32 subrv_items;
266
267             if (!basestash) {
268                 /* if no stash exists for this @ISA member,
269                    simply add it to the MRO and move on */
270                 subrv_p = &sv;
271                 subrv_items = 1;
272             }
273             else {
274                 /* otherwise, recurse into ourselves for the MRO
275                    of this @ISA member, and append their MRO to ours.
276                    The recursive call could throw an exception, which
277                    has memory management implications here, hence the use of
278                    the mortal.  */
279                 const AV *const subrv
280                     = mro_get_linear_isa_dfs(basestash, level + 1);
281
282                 subrv_p = AvARRAY(subrv);
283                 subrv_items = AvFILLp(subrv) + 1;
284             }
285             if (stored) {
286                 while(subrv_items--) {
287                     SV *const subsv = *subrv_p++;
288                     /* LVALUE fetch will create a new undefined SV if necessary
289                      */
290                     HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
291                     assert(he);
292                     if(HeVAL(he) != &PL_sv_undef) {
293                         /* It was newly created.  Steal it for our new SV, and
294                            replace it in the hash with the "real" thing.  */
295                         SV *const val = HeVAL(he);
296                         HEK *const key = HeKEY_hek(he);
297
298                         HeVAL(he) = &PL_sv_undef;
299                         /* Save copying by making a shared hash key scalar. We
300                            inline this here rather than calling
301                            Perl_newSVpvn_share because we already have the
302                            scalar, and we already have the hash key.  */
303                         assert(SvTYPE(val) == SVt_NULL);
304                         sv_upgrade(val, SVt_PV);
305                         SvPV_set(val, HEK_KEY(share_hek_hek(key)));
306                         SvCUR_set(val, HEK_LEN(key));
307                         SvREADONLY_on(val);
308                         SvFAKE_on(val);
309                         SvPOK_on(val);
310                         if (HEK_UTF8(key))
311                             SvUTF8_on(val);
312
313                         av_push(retval, val);
314                     }
315                 }
316             } else {
317                 /* We are the first (or only) parent. We can short cut the
318                    complexity above, because our @ISA is simply us prepended
319                    to our parent's @ISA, and our ->isa cache is simply our
320                    parent's, with our name added.  */
321                 /* newSVsv() is slow. This code is only faster if we can avoid
322                    it by ensuring that SVs in the arrays are shared hash key
323                    scalar SVs, because we can "copy" them very efficiently.
324                    Although to be fair, we can't *ensure* this, as a reference
325                    to the internal array is returned by mro::get_linear_isa(),
326                    so we'll have to be defensive just in case someone faffed
327                    with it.  */
328                 if (basestash) {
329                     SV **svp;
330                     stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
331                     av_extend(retval, subrv_items);
332                     AvFILLp(retval) = subrv_items;
333                     svp = AvARRAY(retval);
334                     while(subrv_items--) {
335                         SV *const val = *subrv_p++;
336                         *++svp = SvIsCOW_shared_hash(val)
337                             ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
338                             : newSVsv(val);
339                     }
340                 } else {
341                     /* They have no stash.  So create ourselves an ->isa cache
342                        as if we'd copied it from what theirs should be.  */
343                     stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
344                     (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
345                     av_push(retval,
346                             newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
347                                                             &PL_sv_undef, 0))));
348                 }
349             }
350         }
351     } else {
352         /* We have no parents.  */
353         stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
354         (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
355     }
356
357     (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
358
359     SvREFCNT_inc_simple_void_NN(stored);
360     SvTEMP_off(stored);
361     SvREADONLY_on(stored);
362
363     meta->isa = stored;
364
365     /* now that we're past the exception dangers, grab our own reference to
366        the AV we're about to use for the result. The reference owned by the
367        mortals' stack will be released soon, so everything will balance.  */
368     SvREFCNT_inc_simple_void_NN(retval);
369     SvTEMP_off(retval);
370
371     /* we don't want anyone modifying the cache entry but us,
372        and we do so by replacing it completely */
373     SvREADONLY_on(retval);
374
375     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
376                                                 MUTABLE_SV(retval)));
377 }
378
379 /*
380 =for apidoc mro_get_linear_isa
381
382 Returns either C<mro_get_linear_isa_c3> or
383 C<mro_get_linear_isa_dfs> for the given stash,
384 dependant upon which MRO is in effect
385 for that stash.  The return value is a
386 read-only AV*.
387
388 You are responsible for C<SvREFCNT_inc()> on the
389 return value if you plan to store it anywhere
390 semi-permanently (otherwise it might be deleted
391 out from under you the next time the cache is
392 invalidated).
393
394 =cut
395 */
396 AV*
397 Perl_mro_get_linear_isa(pTHX_ HV *stash)
398 {
399     struct mro_meta* meta;
400
401     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
402     if(!SvOOK(stash))
403         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
404
405     meta = HvMROMETA(stash);
406     if (!meta->mro_which)
407         Perl_croak(aTHX_ "panic: invalid MRO!");
408     return meta->mro_which->resolve(aTHX_ stash, 0);
409 }
410
411 /*
412 =for apidoc mro_isa_changed_in
413
414 Takes the necessary steps (cache invalidations, mostly)
415 when the @ISA of the given package has changed.  Invoked
416 by the C<setisa> magic, should not need to invoke directly.
417
418 =for apidoc mro_isa_changed_in3
419
420 Takes the necessary steps (cache invalidations, mostly)
421 when the @ISA of the given package has changed.  Invoked
422 by the C<setisa> magic, should not need to invoke directly.
423
424 The stash can be passed as the first argument, or its name and length as
425 the second and third (or both). If just the name is passed and the stash
426 does not exist, then only the subclasses' method and isa caches will be
427 invalidated.
428
429 =cut
430 */
431 void
432 Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
433                          STRLEN stashname_len)
434 {
435     dVAR;
436     HV* isarev;
437     AV* linear_mro;
438     HE* iter;
439     SV** svp;
440     I32 items;
441     bool is_universal;
442     struct mro_meta * meta = NULL;
443
444     if(!stashname && stash) {
445         stashname = HvENAME_get(stash);
446         stashname_len = HvENAMELEN_get(stash);
447     }
448     else if(!stash)
449         stash = gv_stashpvn(stashname, stashname_len, 0 /* don't add */);
450
451     if(!stashname)
452         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
453
454     if(stash) {
455       /* wipe out the cached linearizations for this stash */
456       meta = HvMROMETA(stash);
457       if (meta->mro_linear_all) {
458         SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
459         meta->mro_linear_all = NULL;
460         /* This is just acting as a shortcut pointer.  */
461         meta->mro_linear_current = NULL;
462       } else if (meta->mro_linear_current) {
463         /* Only the current MRO is stored, so this owns the data.  */
464         SvREFCNT_dec(meta->mro_linear_current);
465         meta->mro_linear_current = NULL;
466       }
467       if (meta->isa) {
468         SvREFCNT_dec(meta->isa);
469         meta->isa = NULL;
470       }
471
472       /* Inc the package generation, since our @ISA changed */
473       meta->pkg_gen++;
474     }
475
476     /* Wipe the global method cache if this package
477        is UNIVERSAL or one of its parents */
478
479     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
480     isarev = svp ? MUTABLE_HV(*svp) : NULL;
481
482     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
483         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
484         PL_sub_generation++;
485         is_universal = TRUE;
486     }
487     else { /* Wipe the local method cache otherwise */
488         if(meta) meta->cache_gen++;
489         is_universal = FALSE;
490     }
491
492     /* wipe next::method cache too */
493     if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
494
495     /* Iterate the isarev (classes that are our children),
496        wiping out their linearization, method and isa caches */
497     if(isarev) {
498         hv_iterinit(isarev);
499         while((iter = hv_iternext(isarev))) {
500             I32 len;
501             const char* const revkey = hv_iterkey(iter, &len);
502             HV* revstash = gv_stashpvn(revkey, len, 0);
503             struct mro_meta* revmeta;
504
505             if(!revstash) continue;
506             revmeta = HvMROMETA(revstash);
507             if (revmeta->mro_linear_all) {
508                 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
509                 revmeta->mro_linear_all = NULL;
510                 /* This is just acting as a shortcut pointer.  */
511                 revmeta->mro_linear_current = NULL;
512             } else if (revmeta->mro_linear_current) {
513                 /* Only the current MRO is stored, so this owns the data.  */
514                 SvREFCNT_dec(revmeta->mro_linear_current);
515                 revmeta->mro_linear_current = NULL;
516             }
517             if(!is_universal)
518                 revmeta->cache_gen++;
519             if(revmeta->mro_nextmethod)
520                 hv_clear(revmeta->mro_nextmethod);
521             if (revmeta->isa) {
522                 SvREFCNT_dec(revmeta->isa);
523                 revmeta->isa = NULL;
524             }
525         }
526     }
527
528     /* Now iterate our MRO (parents), and do a few things:
529          1) instantiate with the "fake" flag if they don't exist
530          2) flag them as universal if we are universal
531          3) Add everything from our isarev to their isarev
532     */
533
534     /* This only applies if the stash exists. */
535     if(!stash) return;
536
537     /* We're starting at the 2nd element, skipping ourselves here */
538     linear_mro = mro_get_linear_isa(stash);
539     svp = AvARRAY(linear_mro) + 1;
540     items = AvFILLp(linear_mro);
541
542     while (items--) {
543         SV* const sv = *svp++;
544         HV* mroisarev;
545
546         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
547
548         /* That fetch should not fail.  But if it had to create a new SV for
549            us, then will need to upgrade it to an HV (which sv_upgrade() can
550            now do for us. */
551
552         mroisarev = MUTABLE_HV(HeVAL(he));
553
554         SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
555
556         /* This hash only ever contains PL_sv_yes. Storing it over itself is
557            almost as cheap as calling hv_exists, so on aggregate we expect to
558            save time by not making two calls to the common HV code for the
559            case where it doesn't exist.  */
560            
561         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
562
563         if(isarev) {
564             hv_iterinit(isarev);
565             while((iter = hv_iternext(isarev))) {
566                 I32 revkeylen;
567                 char* const revkey = hv_iterkey(iter, &revkeylen);
568                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
569             }
570         }
571     }
572 }
573
574 /*
575 =for apidoc mro_package_moved
576
577 Call this function to signal to a stash that it has been assigned to
578 another spot in the stash hierarchy. C<stash> is the stash that has been
579 assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
580 that is actually being assigned to. C<newname> and C<newname_len> are the
581 full name of the GV. If these last two arguments are omitted, they can be
582 inferred from C<gv>. C<gv> can be omitted if C<newname> is given.
583
584 This can also be called with a null first argument to
585 indicate that C<oldstash> has been deleted.
586
587 This function invalidates isa caches on the old stash, on all subpackages
588 nested inside it, and on the subclasses of all those, including
589 non-existent packages that have corresponding entries in C<stash>.
590
591 =cut
592 */
593 void
594 Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
595                        const GV *gv, const char *newname,
596                        I32 newname_len)
597 {
598     register XPVHV* xhv;
599     register HE *entry;
600     I32 riter = -1;
601     HV *seen = NULL;
602     HV *seen_stashes = NULL;
603
604     /* If newname_len is negative, then gv is actually the caller’s hash of
605        stashes that have been seen so far. */
606
607     assert(stash || oldstash);
608     assert((gv && newname_len >= 0) || newname);
609
610     if(newname_len < 0) seen_stashes = (HV *)gv, gv = NULL;
611
612     /* Determine the name of the location that stash was assigned to
613      * or from which oldstash was removed.
614      *
615      * We cannot reliable use the name in oldstash, because it may have
616      * been deleted from the location in the symbol table that its name
617      * suggests, as in this case:
618      *
619      *   $globref = \*foo::bar::;
620      *   Symbol::delete_package("foo");
621      *   *$globref = \%baz::;
622      *   *$globref = *frelp::;
623      *      # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
624      *
625      * If newname is not null, then we trust that the caller gave us the
626      * right name. Otherwise, we get it from the gv. But if the gv is not
627      * in the symbol table, then we just return.
628      */
629     if(!newname && gv) {
630         SV * const namesv = sv_newmortal();
631         STRLEN len;
632         gv_fullname4(namesv, gv, NULL, 0);
633         if(gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv) return;
634         newname = SvPV_const(namesv, len);
635         newname_len = len - 2; /* skip trailing :: */
636     }
637     if(newname_len < 0) newname_len = -newname_len;
638
639     mro_isa_changed_in3((HV *)oldstash, newname, newname_len);
640
641     if(
642      (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
643     ) goto set_names;
644
645     /* This is partly based on code in hv_iternext_flags. We are not call-
646        ing that here, as we want to avoid resetting the hash iterator. */
647
648     /* Skip the entire loop if the hash is empty.   */
649     if(oldstash && HvUSEDKEYS(oldstash)) { 
650         xhv = (XPVHV*)SvANY(oldstash);
651         seen = (HV *) sv_2mortal((SV *)newHV());
652         if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
653
654         /* Iterate through entries in the oldstash, calling
655             mro_package_moved(
656              corresponding_entry_in_new_stash, current_entry, ...
657             )
658            meanwhile doing the equivalent of $seen{$key} = 1.
659          */
660
661         while (++riter <= (I32)xhv->xhv_max) {
662             entry = (HvARRAY(oldstash))[riter];
663
664             /* Iterate through the entries in this list */
665             for(; entry; entry = HeNEXT(entry)) {
666                 const char* key;
667                 I32 len;
668
669                 /* If this entry is not a glob, ignore it.
670                    Try the next.  */
671                 if (!isGV(HeVAL(entry))) continue;
672
673                 key = hv_iterkey(entry, &len);
674                 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
675                     HV * const oldsubstash = GvHV(HeVAL(entry));
676                     SV ** const stashentry
677                      = stash ? hv_fetch(stash, key, len, 0) : NULL;
678                     HV *substash = NULL;
679
680                     /* Avoid main::main::main::... */
681                     if(oldsubstash == oldstash) continue;
682                     if(oldsubstash) {
683                         HE * const entry
684                          = (HE *)
685                             hv_common(
686                              seen_stashes, NULL,
687                              (const char *)&oldsubstash, sizeof(HV *), 0,
688                              HV_FETCH_LVALUE, NULL, 0
689                             );
690                         if(HeVAL(entry) == &PL_sv_yes) continue;
691                         HeVAL(entry) = &PL_sv_yes;
692                     }
693
694                     if(
695                         (
696                             stashentry && *stashentry
697                          && (substash = GvHV(*stashentry))
698                         )
699                      || (oldsubstash && HvENAME_get(oldsubstash))
700                     )
701                     {
702                         /* Add :: and the key (minus the trailing ::)
703                            to newname. */
704                         SV *namesv
705                          = newSVpvn_flags(newname, newname_len, SVs_TEMP);
706                         const char *name;
707                         STRLEN namlen;
708                         sv_catpvs(namesv, "::");
709                         sv_catpvn(namesv, key, len-2);
710                         name = SvPV_const(namesv, namlen);
711                         mro_package_moved(
712                           substash, oldsubstash,
713                           (GV *)seen_stashes, name, -namlen
714                         );
715                     }
716
717                     (void)hv_store(seen, key, len, &PL_sv_yes, 0);
718                 }
719             }
720         }
721     }
722
723     /* Skip the entire loop if the hash is empty.   */
724     if (stash && HvUSEDKEYS(stash)) {
725         xhv = (XPVHV*)SvANY(stash);
726         if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
727
728         /* Iterate through the new stash, skipping $seen{$key} items,
729            calling mro_package_moved(entry, NULL, ...). */
730         while (++riter <= (I32)xhv->xhv_max) {
731             entry = (HvARRAY(stash))[riter];
732
733             /* Iterate through the entries in this list */
734             for(; entry; entry = HeNEXT(entry)) {
735                 const char* key;
736                 I32 len;
737
738                 /* If this entry is not a glob, ignore it.
739                    Try the next.  */
740                 if (!isGV(HeVAL(entry))) continue;
741
742                 key = hv_iterkey(entry, &len);
743                 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
744                     HV *substash;
745
746                     /* If this entry was seen when we iterated through the
747                        oldstash, skip it. */
748                     if(seen && hv_exists(seen, key, len)) continue;
749
750                     /* We get here only if this stash has no corresponding
751                        entry in the stash being replaced. */
752
753                     substash = GvHV(HeVAL(entry));
754                     if(substash) {
755                         SV *namesv;
756                         const char *name;
757                         STRLEN namlen;
758                         HE *entry;
759
760                         /* Avoid checking main::main::main::... */
761                         if(substash == stash) continue;
762                         entry
763                          = (HE *)
764                                hv_common(
765                                 seen_stashes, NULL,
766                                 (const char *)&substash, sizeof(HV *), 0,
767                                 HV_FETCH_LVALUE, NULL, 0
768                                );
769                         if(HeVAL(entry) == &PL_sv_yes) continue;
770                         HeVAL(entry) = &PL_sv_yes;
771
772                         /* Add :: and the key (minus the trailing ::)
773                            to newname. */
774                         namesv
775                          = newSVpvn_flags(newname, newname_len, SVs_TEMP);
776                         sv_catpvs(namesv, "::");
777                         sv_catpvn(namesv, key, len-2);
778                         name = SvPV_const(namesv, namlen);
779                         mro_package_moved(
780                           substash, NULL, (GV *)seen_stashes, name, -namlen
781                         );
782                     }
783                 }
784             }
785         }
786     }
787
788    set_names:
789     if(oldstash && HvENAME_get(oldstash)) {
790         if(PL_stashcache)
791             (void)
792              hv_delete(PL_stashcache, newname, newname_len, G_DISCARD);
793         hv_ename_delete(oldstash, newname, newname_len);
794     }
795     if(stash) hv_ename_add(stash, newname, newname_len);
796 }
797
798 /*
799 =for apidoc mro_method_changed_in
800
801 Invalidates method caching on any child classes
802 of the given stash, so that they might notice
803 the changes in this one.
804
805 Ideally, all instances of C<PL_sub_generation++> in
806 perl source outside of C<mro.c> should be
807 replaced by calls to this.
808
809 Perl automatically handles most of the common
810 ways a method might be redefined.  However, there
811 are a few ways you could change a method in a stash
812 without the cache code noticing, in which case you
813 need to call this method afterwards:
814
815 1) Directly manipulating the stash HV entries from
816 XS code.
817
818 2) Assigning a reference to a readonly scalar
819 constant into a stash entry in order to create
820 a constant subroutine (like constant.pm
821 does).
822
823 This same method is available from pure perl
824 via, C<mro::method_changed_in(classname)>.
825
826 =cut
827 */
828 void
829 Perl_mro_method_changed_in(pTHX_ HV *stash)
830 {
831     const char * const stashname = HvENAME_get(stash);
832     const STRLEN stashname_len = HvENAMELEN_get(stash);
833
834     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
835     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
836
837     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
838
839     if(!stashname)
840         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
841
842     /* Inc the package generation, since a local method changed */
843     HvMROMETA(stash)->pkg_gen++;
844
845     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
846        invalidate all method caches globally */
847     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
848         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
849         PL_sub_generation++;
850         return;
851     }
852
853     /* else, invalidate the method caches of all child classes,
854        but not itself */
855     if(isarev) {
856         HE* iter;
857
858         hv_iterinit(isarev);
859         while((iter = hv_iternext(isarev))) {
860             I32 len;
861             const char* const revkey = hv_iterkey(iter, &len);
862             HV* const revstash = gv_stashpvn(revkey, len, 0);
863             struct mro_meta* mrometa;
864
865             if(!revstash) continue;
866             mrometa = HvMROMETA(revstash);
867             mrometa->cache_gen++;
868             if(mrometa->mro_nextmethod)
869                 hv_clear(mrometa->mro_nextmethod);
870         }
871     }
872 }
873
874 void
875 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
876 {
877     const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
878  
879     PERL_ARGS_ASSERT_MRO_SET_MRO;
880
881     if (!which)
882         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
883
884     if(meta->mro_which != which) {
885         if (meta->mro_linear_current && !meta->mro_linear_all) {
886             /* If we were storing something directly, put it in the hash before
887                we lose it. */
888             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which, 
889                                       MUTABLE_SV(meta->mro_linear_current));
890         }
891         meta->mro_which = which;
892         /* Scrub our cached pointer to the private data.  */
893         meta->mro_linear_current = NULL;
894         /* Only affects local method cache, not
895            even child classes */
896         meta->cache_gen++;
897         if(meta->mro_nextmethod)
898             hv_clear(meta->mro_nextmethod);
899     }
900 }
901
902 #include "XSUB.h"
903
904 XS(XS_mro_method_changed_in);
905
906 void
907 Perl_boot_core_mro(pTHX)
908 {
909     dVAR;
910     static const char file[] = __FILE__;
911
912     Perl_mro_register(aTHX_ &dfs_alg);
913
914     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
915 }
916
917 XS(XS_mro_method_changed_in)
918 {
919     dVAR;
920     dXSARGS;
921     SV* classname;
922     HV* class_stash;
923
924     if(items != 1)
925         croak_xs_usage(cv, "classname");
926     
927     classname = ST(0);
928
929     class_stash = gv_stashsv(classname, 0);
930     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
931
932     mro_method_changed_in(class_stash);
933
934     XSRETURN_EMPTY;
935 }
936
937 /*
938  * Local variables:
939  * c-indentation-style: bsd
940  * c-basic-offset: 4
941  * indent-tabs-mode: t
942  * End:
943  *
944  * ex: set ts=8 sts=4 sw=4 noet:
945  */