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