mro.c

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