mro.c

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