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