mro.c

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