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