mro_core.c

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