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