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     XPVHV* xhv;
 887     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                     DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
 958                                      *svp));
 959                    (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
 960                 }
 961                 ++svp;
 962                 hv_ename_delete(oldstash, name, len, name_utf8);
 963
 964                 if (!fetched_isarev) {
 965                     /* If the name deletion caused a name change, then we
 966                      * are not going to call mro_isa_changed_in with this
 967                      * name (and not at all if it has become anonymous) so
 968                      * we need to delete old isarev entries here, both
 969                      * those in the superclasses and this class's own list
 970                      * of subclasses. We simply delete the latter from
 971                      * PL_isarev, since we still need it. hv_delete morti-
 972                      * fies it for us, so sv_2mortal is not necessary. */
 973                     if(HvENAME_HEK(oldstash) != enamehek) {
 974                         if(meta->isa && HvARRAY(meta->isa))
 975                             mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
 976                         isarev = (HV *)hv_delete(PL_isarev, name,
 977                                                     name_utf8 ? -(I32)len : (I32)len, 0);
 978                         fetched_isarev=TRUE;
 979                     }
 980                 }
 981             }
 982         }
 983     }
 984    check_stash:
 985     if(stash) {
 986         if(SvTYPE(namesv) == SVt_PVAV) {
 987             items = AvFILLp((AV *)namesv) + 1;
 988             svp = AvARRAY((AV *)namesv);
 989         }
 990         else {
 991             items = 1;
 992             svp = &namesv;
 993         }
 994         while (items--) {
 995             const U32 name_utf8 = SvUTF8(*svp);
 996             STRLEN len;
 997             const char *name = SvPVx_const(*svp++, len);
 998             hv_ename_add(stash, name, len, name_utf8);
 999         }
1000
1001        /* Add it to the big list if it needs
1002         * mro_isa_changed_in called on it. That happens if it was
1003         * detached from the symbol table (so it had no HvENAME) before
1004         * being assigned to the spot named by the 'name' variable, because
1005         * its cached isa linearisation is now stale (the effective name
1006         * having changed), and subclasses will then use that cache when
1007         * mro_package_moved calls mro_isa_changed_in. (See
1008         * [perl #77358].)
1009         *
1010         * If it did have a name, then its previous name is still
1011         * used in isa caches, and there is no need for
1012         * mro_package_moved to call mro_isa_changed_in.
1013         */
1014
1015         entry
1016          = (HE *)
1017              hv_common(
1018               seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1019               HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1020              );
1021         if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1022             stash = NULL;
1023         else {
1024             HeVAL(entry)
1025              = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1026             if(!stash_had_name)
1027             {
1028                 struct mro_meta * const meta = HvMROMETA(stash);
1029                 (void)
1030                   hv_store(
1031                    stashes, (const char *)&stash, sizeof(HV *),
1032                    meta->isa
1033                     ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1034                     : &PL_sv_yes,
1035                    0
1036                   );
1037                 CLEAR_LINEAR(meta);
1038             }
1039         }
1040     }
1041
1042     if(!stash && !oldstash)
1043         /* Both stashes have been encountered already. */
1044         return;
1045
1046     /* Add all the subclasses to the big list. */
1047     if(!fetched_isarev) {
1048         /* If oldstash is not null, then we can use its HvENAME to look up
1049            the isarev hash, since all its subclasses will be listed there.
1050            It will always have an HvENAME. It the HvENAME was removed
1051            above, then fetch_isarev will be true, and this code will not be
1052            reached.
1053
1054            If oldstash is null, then this is an empty spot with no stash in
1055            it, so subclasses could be listed in isarev hashes belonging to
1056            any of the names, so we have to check all of them.
1057          */
1058         assert(!oldstash || HvENAME(oldstash));
1059         if (oldstash) {
1060             /* Extra variable to avoid a compiler warning */
1061             char * const hvename = HvENAME(oldstash);
1062             fetched_isarev = TRUE;
1063             svp = hv_fetch(PL_isarev, hvename,
1064                             HvENAMEUTF8(oldstash)
1065                                 ? -HvENAMELEN_get(oldstash)
1066                                 : HvENAMELEN_get(oldstash), 0);
1067             if (svp) isarev = MUTABLE_HV(*svp);
1068         }
1069         else if(SvTYPE(namesv) == SVt_PVAV) {
1070             items = AvFILLp((AV *)namesv) + 1;
1071             svp = AvARRAY((AV *)namesv);
1072         }
1073         else {
1074             items = 1;
1075             svp = &namesv;
1076         }
1077     }
1078     if(
1079         isarev || !fetched_isarev
1080     ) {
1081       while (fetched_isarev || items--) {
1082         HE *iter;
1083
1084         if (!fetched_isarev) {
1085             HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1086             if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1087         }
1088
1089         hv_iterinit(isarev);
1090         while((iter = hv_iternext(isarev))) {
1091             HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1092             struct mro_meta * meta;
1093
1094             if(!revstash) continue;
1095             meta = HvMROMETA(revstash);
1096             (void)
1097               hv_store(
1098                stashes, (const char *)&revstash, sizeof(HV *),
1099                meta->isa
1100                 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1101                 : &PL_sv_yes,
1102                0
1103               );
1104             CLEAR_LINEAR(meta);
1105         }
1106
1107         if (fetched_isarev) break;
1108       }
1109     }
1110
1111     /* This is partly based on code in hv_iternext_flags. We are not call-
1112        ing that here, as we want to avoid resetting the hash iterator. */
1113
1114     /* Skip the entire loop if the hash is empty.   */
1115     if(oldstash && HvUSEDKEYS(oldstash)) {
1116         xhv = (XPVHV*)SvANY(oldstash);
1117         seen = (HV *) sv_2mortal((SV *)newHV());
1118
1119         /* Iterate through entries in the oldstash, adding them to the
1120            list, meanwhile doing the equivalent of $seen{$key} = 1.
1121          */
1122
1123         while (++riter <= (I32)xhv->xhv_max) {
1124             entry = (HvARRAY(oldstash))[riter];
1125
1126             /* Iterate through the entries in this list */
1127             for(; entry; entry = HeNEXT(entry)) {
1128                 const char* key;
1129                 I32 len;
1130
1131                 /* If this entry is not a glob, ignore it.
1132                    Try the next.  */
1133                 if (!isGV(HeVAL(entry))) continue;
1134
1135                 key = hv_iterkey(entry, &len);
1136                 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1137                  || (len == 1 && key[0] == ':')) {
1138                     HV * const oldsubstash = GvHV(HeVAL(entry));
1139                     SV ** const stashentry
1140                      = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
1141                     HV *substash = NULL;
1142
1143                     /* Avoid main::main::main::... */
1144                     if(oldsubstash == oldstash) continue;
1145
1146                     if(
1147                         (
1148                             stashentry && *stashentry
1149                          && (substash = GvHV(*stashentry))
1150                         )
1151                      || (oldsubstash && HvENAME_get(oldsubstash))
1152                     )
1153                     {
1154                         /* Add :: and the key (minus the trailing ::)
1155                            to each name. */
1156                         SV *subname;
1157                         if(SvTYPE(namesv) == SVt_PVAV) {
1158                             SV *aname;
1159                             items = AvFILLp((AV *)namesv) + 1;
1160                             svp = AvARRAY((AV *)namesv);
1161                             subname = sv_2mortal((SV *)newAV());
1162                             while (items--) {
1163                                 aname = newSVsv(*svp++);
1164                                 if (len == 1)
1165                                     sv_catpvs(aname, ":");
1166                                 else {
1167                                     sv_catpvs(aname, "::");
1168                                     sv_catpvn_flags(
1169                                         aname, key, len-2,
1170                                         HeUTF8(entry)
1171                                            ? SV_CATUTF8 : SV_CATBYTES
1172                                     );
1173                                 }
1174                                 av_push((AV *)subname, aname);
1175                             }
1176                         }
1177                         else {
1178                             subname = sv_2mortal(newSVsv(namesv));
1179                             if (len == 1) sv_catpvs(subname, ":");
1180                             else {
1181                                 sv_catpvs(subname, "::");
1182                                 sv_catpvn_flags(
1183                                    subname, key, len-2,
1184                                    HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1185                                 );
1186                             }
1187                         }
1188                         mro_gather_and_rename(
1189                              stashes, seen_stashes,
1190                              substash, oldsubstash, subname
1191                         );
1192                     }
1193
1194                     (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
1195                 }
1196             }
1197         }
1198     }
1199
1200     /* Skip the entire loop if the hash is empty.   */
1201     if (stash && HvUSEDKEYS(stash)) {
1202         xhv = (XPVHV*)SvANY(stash);
1203         riter = -1;
1204
1205         /* Iterate through the new stash, skipping $seen{$key} items,
1206            calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1207         while (++riter <= (I32)xhv->xhv_max) {
1208             entry = (HvARRAY(stash))[riter];
1209
1210             /* Iterate through the entries in this list */
1211             for(; entry; entry = HeNEXT(entry)) {
1212                 const char* key;
1213                 I32 len;
1214
1215                 /* If this entry is not a glob, ignore it.
1216                    Try the next.  */
1217                 if (!isGV(HeVAL(entry))) continue;
1218
1219                 key = hv_iterkey(entry, &len);
1220                 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1221                  || (len == 1 && key[0] == ':')) {
1222                     HV *substash;
1223
1224                     /* If this entry was seen when we iterated through the
1225                        oldstash, skip it. */
1226                     if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
1227
1228                     /* We get here only if this stash has no corresponding
1229                        entry in the stash being replaced. */
1230
1231                     substash = GvHV(HeVAL(entry));
1232                     if(substash) {
1233                         SV *subname;
1234
1235                         /* Avoid checking main::main::main::... */
1236                         if(substash == stash) continue;
1237
1238                         /* Add :: and the key (minus the trailing ::)
1239                            to each name. */
1240                         if(SvTYPE(namesv) == SVt_PVAV) {
1241                             SV *aname;
1242                             items = AvFILLp((AV *)namesv) + 1;
1243                             svp = AvARRAY((AV *)namesv);
1244                             subname = sv_2mortal((SV *)newAV());
1245                             while (items--) {
1246                                 aname = newSVsv(*svp++);
1247                                 if (len == 1)
1248                                     sv_catpvs(aname, ":");
1249                                 else {
1250                                     sv_catpvs(aname, "::");
1251                                     sv_catpvn_flags(
1252                                         aname, key, len-2,
1253                                         HeUTF8(entry)
1254                                            ? SV_CATUTF8 : SV_CATBYTES
1255                                     );
1256                                 }
1257                                 av_push((AV *)subname, aname);
1258                             }
1259                         }
1260                         else {
1261                             subname = sv_2mortal(newSVsv(namesv));
1262                             if (len == 1) sv_catpvs(subname, ":");
1263                             else {
1264                                 sv_catpvs(subname, "::");
1265                                 sv_catpvn_flags(
1266                                    subname, key, len-2,
1267                                    HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1268                                 );
1269                             }
1270                         }
1271                         mro_gather_and_rename(
1272                           stashes, seen_stashes,
1273                           substash, NULL, subname
1274                         );
1275                     }
1276                 }
1277             }
1278         }
1279     }
1280 }
1281
1282 /*
1283 =for apidoc mro_method_changed_in
1284
1285 Invalidates method caching on any child classes
1286 of the given stash, so that they might notice
1287 the changes in this one.
1288
1289 Ideally, all instances of C<PL_sub_generation++> in
1290 perl source outside of F<mro.c> should be
1291 replaced by calls to this.
1292
1293 Perl automatically handles most of the common
1294 ways a method might be redefined.  However, there
1295 are a few ways you could change a method in a stash
1296 without the cache code noticing, in which case you
1297 need to call this method afterwards:
1298
1299 1) Directly manipulating the stash HV entries from
1300 XS code.
1301
1302 2) Assigning a reference to a readonly scalar
1303 constant into a stash entry in order to create
1304 a constant subroutine (like constant.pm
1305 does).
1306
1307 This same method is available from pure perl
1308 via, C<mro::method_changed_in(classname)>.
1309
1310 =cut
1311 */
1312 void
1313 Perl_mro_method_changed_in(pTHX_ HV *stash)
1314 {
1315     const char * const stashname = HvENAME_get(stash);
1316     const STRLEN stashname_len = HvENAMELEN_get(stash);
1317     const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
1318
1319     SV ** const svp = hv_fetch(PL_isarev, stashname,
1320                                     stashname_utf8 ? -(I32)stashname_len : (I32)stashname_len, 0);
1321     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1322
1323     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1324
1325     if(!stashname)
1326         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1327
1328     /* Inc the package generation, since a local method changed */
1329     HvMROMETA(stash)->pkg_gen++;
1330
1331     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1332        invalidate all method caches globally */
1333     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1334         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1335         PL_sub_generation++;
1336         return;
1337     }
1338
1339     /* else, invalidate the method caches of all child classes,
1340        but not itself */
1341     if(isarev) {
1342         HE* iter;
1343
1344         hv_iterinit(isarev);
1345         while((iter = hv_iternext(isarev))) {
1346             HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1347             struct mro_meta* mrometa;
1348
1349             if(!revstash) continue;
1350             mrometa = HvMROMETA(revstash);
1351             mrometa->cache_gen++;
1352             if(mrometa->mro_nextmethod)
1353                 hv_clear(mrometa->mro_nextmethod);
1354         }
1355     }
1356
1357     /* The method change may be due to *{$package . "::()"} = \&nil; in
1358        overload.pm. */
1359     HvAMAGIC_on(stash);
1360 }
1361
1362 void
1363 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1364 {
1365     const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1366
1367     PERL_ARGS_ASSERT_MRO_SET_MRO;
1368
1369     if (!which)
1370         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1371
1372     if(meta->mro_which != which) {
1373         if (meta->mro_linear_current && !meta->mro_linear_all) {
1374             /* If we were storing something directly, put it in the hash before
1375                we lose it. */
1376             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1377                                       MUTABLE_SV(meta->mro_linear_current));
1378         }
1379         meta->mro_which = which;
1380         /* Scrub our cached pointer to the private data.  */
1381         meta->mro_linear_current = NULL;
1382         /* Only affects local method cache, not
1383            even child classes */
1384         meta->cache_gen++;
1385         if(meta->mro_nextmethod)
1386             hv_clear(meta->mro_nextmethod);
1387     }
1388 }
1389
1390 #include "XSUB.h"
1391
1392 XS(XS_mro_method_changed_in);
1393
1394 void
1395 Perl_boot_core_mro(pTHX)
1396 {
1397     dVAR;
1398     static const char file[] = __FILE__;
1399
1400     Perl_mro_register(aTHX_ &dfs_alg);
1401
1402     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1403 }
1404
1405 XS(XS_mro_method_changed_in)
1406 {
1407     dVAR;
1408     dXSARGS;
1409     SV* classname;
1410     HV* class_stash;
1411
1412     if(items != 1)
1413         croak_xs_usage(cv, "classname");
1414
1415     classname = ST(0);
1416
1417     class_stash = gv_stashsv(classname, 0);
1418     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1419
1420     mro_method_changed_in(class_stash);
1421
1422     XSRETURN_EMPTY;
1423 }
1424
1425 /*
1426  * Local variables:
1427  * c-indentation-style: bsd
1428  * c-basic-offset: 4
1429  * indent-tabs-mode: nil
1430  * End:
1431  *
1432  * ex: set ts=8 sts=4 sw=4 et:
1433  */