mro.c

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