mro_core.c

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