mro.c

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