mro.c

   1 /*    mro.c
   2  *
   3  *    Copyright (c) 2007 Brandon L Black
   4  *    Copyright (c) 2007, 2008 Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  * 'Which order shall we go in?' said Frodo.  'Eldest first, or quickest first?
  13  *  You'll be last either way, Master Peregrin.'
  14  *
  15  *     [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
  16  */
  17
  18 /*
  19 =head1 MRO Functions
  20
  21 These functions are related to the method resolution order of perl classes
  22
  23 =cut
  24 */
  25
  26 #include "EXTERN.h"
  27 #define PERL_IN_MRO_C
  28 #include "perl.h"
  29
  30 static const struct mro_alg dfs_alg =
  31     {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
  32
  33 SV *
  34 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
  35                           const struct mro_alg *const which)
  36 {
  37     SV **data;
  38     PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
  39
  40     data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
  41                                  which->name, which->length, which->kflags,
  42                                  HV_FETCH_JUST_SV, NULL, which->hash);
  43     if (!data)
  44         return NULL;
  45
  46     /* If we've been asked to look up the private data for the current MRO, then
  47        cache it.  */
  48     if (smeta->mro_which == which)
  49         smeta->mro_linear_current = *data;
  50
  51     return *data;
  52 }
  53
  54 SV *
  55 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
  56                           const struct mro_alg *const which, SV *const data)
  57 {
  58     PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
  59
  60     if (!smeta->mro_linear_all) {
  61         if (smeta->mro_which == which) {
  62             /* If all we need to store is the current MRO's data, then don't use
  63                memory on a hash with 1 element - store it direct, and signal
  64                this by leaving the would-be-hash NULL.  */
  65             smeta->mro_linear_current = data;
  66             return data;
  67         } else {
  68             HV *const hv = newHV();
  69             /* Start with 2 buckets. It's unlikely we'll need more. */
  70             HvMAX(hv) = 1;
  71             smeta->mro_linear_all = hv;
  72
  73             if (smeta->mro_linear_current) {
  74                 /* If we were storing something directly, put it in the hash
  75                    before we lose it. */
  76                 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
  77                                           smeta->mro_linear_current);
  78             }
  79         }
  80     }
  81
  82     /* We get here if we're storing more than one linearisation for this stash,
  83        or the linearisation we are storing is not that if its current MRO.  */
  84
  85     if (smeta->mro_which == which) {
  86         /* If we've been asked to store the private data for the current MRO,
  87            then cache it.  */
  88         smeta->mro_linear_current = data;
  89     }
  90
  91     if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
  92                         which->name, which->length, which->kflags,
  93                         HV_FETCH_ISSTORE, data, which->hash)) {
  94         Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
  95                    "for '%.*s' %d", (int) which->length, which->name,
  96                    which->kflags);
  97     }
  98
  99     return data;
 100 }
 101
 102 const struct mro_alg *
 103 Perl_mro_get_from_name(pTHX_ SV *name) {
 104     SV **data;
 105
 106     PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
 107
 108     data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
 109                                  HV_FETCH_JUST_SV, NULL, 0);
 110     if (!data)
 111         return NULL;
 112     assert(SvTYPE(*data) == SVt_IV);
 113     assert(SvIOK(*data));
 114     return INT2PTR(const struct mro_alg *, SvUVX(*data));
 115 }
 116
 117 void
 118 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
 119     SV *wrapper = newSVuv(PTR2UV(mro));
 120
 121     PERL_ARGS_ASSERT_MRO_REGISTER;
 122
 123
 124     if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
 125                         mro->name, mro->length, mro->kflags,
 126                         HV_FETCH_ISSTORE, wrapper, mro->hash)) {
 127         SvREFCNT_dec(wrapper);
 128         Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
 129                    "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
 130     }
 131 }
 132
 133 struct mro_meta*
 134 Perl_mro_meta_init(pTHX_ HV* stash)
 135 {
 136     struct mro_meta* newmeta;
 137
 138     PERL_ARGS_ASSERT_MRO_META_INIT;
 139     assert(HvAUX(stash));
 140     assert(!(HvAUX(stash)->xhv_mro_meta));
 141     Newxz(newmeta, 1, struct mro_meta);
 142     HvAUX(stash)->xhv_mro_meta = newmeta;
 143     newmeta->cache_gen = 1;
 144     newmeta->pkg_gen = 1;
 145     newmeta->mro_which = &dfs_alg;
 146
 147     return newmeta;
 148 }
 149
 150 #if defined(USE_ITHREADS)
 151
 152 /* for sv_dup on new threads */
 153 struct mro_meta*
 154 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
 155 {
 156     struct mro_meta* newmeta;
 157
 158     PERL_ARGS_ASSERT_MRO_META_DUP;
 159
 160     Newx(newmeta, 1, struct mro_meta);
 161     Copy(smeta, newmeta, 1, struct mro_meta);
 162
 163     if (newmeta->mro_linear_all) {
 164         newmeta->mro_linear_all
 165             = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_all, param)));
 166         /* This is just acting as a shortcut pointer, and will be automatically
 167            updated on the first get.  */
 168         newmeta->mro_linear_current = NULL;
 169     } else if (newmeta->mro_linear_current) {
 170         /* Only the current MRO is stored, so this owns the data.  */
 171         newmeta->mro_linear_current
 172             = SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_current,
 173                                   param));
 174     }
 175
 176     if (newmeta->mro_nextmethod)
 177         newmeta->mro_nextmethod
 178             = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
 179     if (newmeta->isa)
 180         newmeta->isa
 181             = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
 182
 183     return newmeta;
 184 }
 185
 186 #endif /* USE_ITHREADS */
 187
 188 /*
 189 =for apidoc mro_get_linear_isa_dfs
 190
 191 Returns the Depth-First Search linearization of @ISA
 192 the given stash.  The return value is a read-only AV*.
 193 C<level> should be 0 (it is used internally in this
 194 function's recursion).
 195
 196 You are responsible for C<SvREFCNT_inc()> on the
 197 return value if you plan to store it anywhere
 198 semi-permanently (otherwise it might be deleted
 199 out from under you the next time the cache is
 200 invalidated).
 201
 202 =cut
 203 */
 204 static AV*
 205 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
 206 {
 207     AV* retval;
 208     GV** gvp;
 209     GV* gv;
 210     AV* av;
 211     const HEK* stashhek;
 212     struct mro_meta* meta;
 213     SV *our_name;
 214     HV *stored = NULL;
 215
 216     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
 217     assert(HvAUX(stash));
 218
 219     stashhek = HvNAME_HEK(stash);
 220     if (!stashhek)
 221       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 222
 223     if (level > 100)
 224         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 225                    HEK_KEY(stashhek));
 226
 227     meta = HvMROMETA(stash);
 228
 229     /* return cache if valid */
 230     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
 231         return retval;
 232     }
 233
 234     /* not in cache, make a new one */
 235
 236     retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
 237     /* We use this later in this function, but don't need a reference to it
 238        beyond the end of this function, so reference count is fine.  */
 239     our_name = newSVhek(stashhek);
 240     av_push(retval, our_name); /* add ourselves at the top */
 241
 242     /* fetch our @ISA */
 243     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 244     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 245
 246     /* "stored" is used to keep track of all of the classnames we have added to
 247        the MRO so far, so we can do a quick exists check and avoid adding
 248        duplicate classnames to the MRO as we go.
 249        It's then retained to be re-used as a fast lookup for ->isa(), by adding
 250        our own name and "UNIVERSAL" to it.  */
 251
 252     if(av && AvFILLp(av) >= 0) {
 253
 254         SV **svp = AvARRAY(av);
 255         I32 items = AvFILLp(av) + 1;
 256
 257         /* foreach(@ISA) */
 258         while (items--) {
 259             SV* const sv = *svp++;
 260             HV* const basestash = gv_stashsv(sv, 0);
 261             SV *const *subrv_p;
 262             I32 subrv_items;
 263
 264             if (!basestash) {
 265                 /* if no stash exists for this @ISA member,
 266                    simply add it to the MRO and move on */
 267                 subrv_p = &sv;
 268                 subrv_items = 1;
 269             }
 270             else {
 271                 /* otherwise, recurse into ourselves for the MRO
 272                    of this @ISA member, and append their MRO to ours.
 273                    The recursive call could throw an exception, which
 274                    has memory management implications here, hence the use of
 275                    the mortal.  */
 276                 const AV *const subrv
 277                     = mro_get_linear_isa_dfs(basestash, level + 1);
 278
 279                 subrv_p = AvARRAY(subrv);
 280                 subrv_items = AvFILLp(subrv) + 1;
 281             }
 282             if (stored) {
 283                 while(subrv_items--) {
 284                     SV *const subsv = *subrv_p++;
 285                     /* LVALUE fetch will create a new undefined SV if necessary
 286                      */
 287                     HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
 288                     assert(he);
 289                     if(HeVAL(he) != &PL_sv_undef) {
 290                         /* It was newly created.  Steal it for our new SV, and
 291                            replace it in the hash with the "real" thing.  */
 292                         SV *const val = HeVAL(he);
 293                         HEK *const key = HeKEY_hek(he);
 294
 295                         HeVAL(he) = &PL_sv_undef;
 296                         /* Save copying by making a shared hash key scalar. We
 297                            inline this here rather than calling
 298                            Perl_newSVpvn_share because we already have the
 299                            scalar, and we already have the hash key.  */
 300                         assert(SvTYPE(val) == SVt_NULL);
 301                         sv_upgrade(val, SVt_PV);
 302                         SvPV_set(val, HEK_KEY(share_hek_hek(key)));
 303                         SvCUR_set(val, HEK_LEN(key));
 304                         SvREADONLY_on(val);
 305                         SvFAKE_on(val);
 306                         SvPOK_on(val);
 307                         if (HEK_UTF8(key))
 308                             SvUTF8_on(val);
 309
 310                         av_push(retval, val);
 311                     }
 312                 }
 313             } else {
 314                 /* We are the first (or only) parent. We can short cut the
 315                    complexity above, because our @ISA is simply us prepended
 316                    to our parent's @ISA, and our ->isa cache is simply our
 317                    parent's, with our name added.  */
 318                 /* newSVsv() is slow. This code is only faster if we can avoid
 319                    it by ensuring that SVs in the arrays are shared hash key
 320                    scalar SVs, because we can "copy" them very efficiently.
 321                    Although to be fair, we can't *ensure* this, as a reference
 322                    to the internal array is returned by mro::get_linear_isa(),
 323                    so we'll have to be defensive just in case someone faffed
 324                    with it.  */
 325                 if (basestash) {
 326                     SV **svp;
 327                     stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
 328                     av_extend(retval, subrv_items);
 329                     AvFILLp(retval) = subrv_items;
 330                     svp = AvARRAY(retval);
 331                     while(subrv_items--) {
 332                         SV *const val = *subrv_p++;
 333                         *++svp = SvIsCOW_shared_hash(val)
 334                             ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
 335                             : newSVsv(val);
 336                     }
 337                 } else {
 338                     /* They have no stash.  So create ourselves an ->isa cache
 339                        as if we'd copied it from what theirs should be.  */
 340                     stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
 341                     (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
 342                     av_push(retval,
 343                             newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
 344                                                             &PL_sv_undef, 0))));
 345                 }
 346             }
 347         }
 348     } else {
 349         /* We have no parents.  */
 350         stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
 351         (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
 352     }
 353
 354     (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
 355
 356     SvREFCNT_inc_simple_void_NN(stored);
 357     SvTEMP_off(stored);
 358     SvREADONLY_on(stored);
 359
 360     meta->isa = stored;
 361
 362     /* now that we're past the exception dangers, grab our own reference to
 363        the AV we're about to use for the result. The reference owned by the
 364        mortals' stack will be released soon, so everything will balance.  */
 365     SvREFCNT_inc_simple_void_NN(retval);
 366     SvTEMP_off(retval);
 367
 368     /* we don't want anyone modifying the cache entry but us,
 369        and we do so by replacing it completely */
 370     SvREADONLY_on(retval);
 371
 372     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
 373                                                 MUTABLE_SV(retval)));
 374 }
 375
 376 /*
 377 =for apidoc mro_get_linear_isa
 378
 379 Returns either C<mro_get_linear_isa_c3> or
 380 C<mro_get_linear_isa_dfs> for the given stash,
 381 dependant upon which MRO is in effect
 382 for that stash.  The return value is a
 383 read-only AV*.
 384
 385 You are responsible for C<SvREFCNT_inc()> on the
 386 return value if you plan to store it anywhere
 387 semi-permanently (otherwise it might be deleted
 388 out from under you the next time the cache is
 389 invalidated).
 390
 391 =cut
 392 */
 393 AV*
 394 Perl_mro_get_linear_isa(pTHX_ HV *stash)
 395 {
 396     struct mro_meta* meta;
 397
 398     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
 399     if(!SvOOK(stash))
 400         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 401
 402     meta = HvMROMETA(stash);
 403     if (!meta->mro_which)
 404         Perl_croak(aTHX_ "panic: invalid MRO!");
 405     return meta->mro_which->resolve(aTHX_ stash, 0);
 406 }
 407
 408 /*
 409 =for apidoc mro_isa_changed_in
 410
 411 Takes the necessary steps (cache invalidations, mostly)
 412 when the @ISA of the given package has changed.  Invoked
 413 by the C<setisa> magic, should not need to invoke directly.
 414
 415 =cut
 416 */
 417 void
 418 Perl_mro_isa_changed_in(pTHX_ HV* stash)
 419 {
 420     dVAR;
 421     HV* isarev;
 422     AV* linear_mro;
 423     HE* iter;
 424     SV** svp;
 425     I32 items;
 426     bool is_universal;
 427     struct mro_meta * meta;
 428
 429     const char * const stashname = HvNAME_get(stash);
 430     const STRLEN stashname_len = HvNAMELEN_get(stash);
 431
 432     PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
 433
 434     if(!stashname)
 435         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
 436
 437     /* wipe out the cached linearizations for this stash */
 438     meta = HvMROMETA(stash);
 439     if (meta->mro_linear_all) {
 440         SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
 441         meta->mro_linear_all = NULL;
 442         /* This is just acting as a shortcut pointer.  */
 443         meta->mro_linear_current = NULL;
 444     } else if (meta->mro_linear_current) {
 445         /* Only the current MRO is stored, so this owns the data.  */
 446         SvREFCNT_dec(meta->mro_linear_current);
 447         meta->mro_linear_current = NULL;
 448     }
 449     if (meta->isa) {
 450         SvREFCNT_dec(meta->isa);
 451         meta->isa = NULL;
 452     }
 453
 454     /* Inc the package generation, since our @ISA changed */
 455     meta->pkg_gen++;
 456
 457     /* Wipe the global method cache if this package
 458        is UNIVERSAL or one of its parents */
 459
 460     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 461     isarev = svp ? MUTABLE_HV(*svp) : NULL;
 462
 463     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 464         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 465         PL_sub_generation++;
 466         is_universal = TRUE;
 467     }
 468     else { /* Wipe the local method cache otherwise */
 469         meta->cache_gen++;
 470         is_universal = FALSE;
 471     }
 472
 473     /* wipe next::method cache too */
 474     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
 475
 476     /* Iterate the isarev (classes that are our children),
 477        wiping out their linearization, method and isa caches */
 478     if(isarev) {
 479         hv_iterinit(isarev);
 480         while((iter = hv_iternext(isarev))) {
 481             I32 len;
 482             const char* const revkey = hv_iterkey(iter, &len);
 483             HV* revstash = gv_stashpvn(revkey, len, 0);
 484             struct mro_meta* revmeta;
 485
 486             if(!revstash) continue;
 487             revmeta = HvMROMETA(revstash);
 488             if (revmeta->mro_linear_all) {
 489                 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
 490                 revmeta->mro_linear_all = NULL;
 491                 /* This is just acting as a shortcut pointer.  */
 492                 revmeta->mro_linear_current = NULL;
 493             } else if (revmeta->mro_linear_current) {
 494                 /* Only the current MRO is stored, so this owns the data.  */
 495                 SvREFCNT_dec(revmeta->mro_linear_current);
 496                 revmeta->mro_linear_current = NULL;
 497             }
 498             if(!is_universal)
 499                 revmeta->cache_gen++;
 500             if(revmeta->mro_nextmethod)
 501                 hv_clear(revmeta->mro_nextmethod);
 502             if (revmeta->isa) {
 503                 SvREFCNT_dec(revmeta->isa);
 504                 revmeta->isa = NULL;
 505             }
 506         }
 507     }
 508
 509     /* Now iterate our MRO (parents), and do a few things:
 510          1) instantiate with the "fake" flag if they don't exist
 511          2) flag them as universal if we are universal
 512          3) Add everything from our isarev to their isarev
 513     */
 514
 515     /* We're starting at the 2nd element, skipping ourselves here */
 516     linear_mro = mro_get_linear_isa(stash);
 517     svp = AvARRAY(linear_mro) + 1;
 518     items = AvFILLp(linear_mro);
 519
 520     while (items--) {
 521         SV* const sv = *svp++;
 522         HV* mroisarev;
 523
 524         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
 525
 526         /* That fetch should not fail.  But if it had to create a new SV for
 527            us, then will need to upgrade it to an HV (which sv_upgrade() can
 528            now do for us. */
 529
 530         mroisarev = MUTABLE_HV(HeVAL(he));
 531
 532         SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
 533
 534         /* This hash only ever contains PL_sv_yes. Storing it over itself is
 535            almost as cheap as calling hv_exists, so on aggregate we expect to
 536            save time by not making two calls to the common HV code for the
 537            case where it doesn't exist.  */
 538
 539         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
 540
 541         if(isarev) {
 542             hv_iterinit(isarev);
 543             while((iter = hv_iternext(isarev))) {
 544                 I32 revkeylen;
 545                 char* const revkey = hv_iterkey(iter, &revkeylen);
 546                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
 547             }
 548         }
 549     }
 550 }
 551
 552 /*
 553 =for apidoc mro_method_changed_in
 554
 555 Invalidates method caching on any child classes
 556 of the given stash, so that they might notice
 557 the changes in this one.
 558
 559 Ideally, all instances of C<PL_sub_generation++> in
 560 perl source outside of C<mro.c> should be
 561 replaced by calls to this.
 562
 563 Perl automatically handles most of the common
 564 ways a method might be redefined.  However, there
 565 are a few ways you could change a method in a stash
 566 without the cache code noticing, in which case you
 567 need to call this method afterwards:
 568
 569 1) Directly manipulating the stash HV entries from
 570 XS code.
 571
 572 2) Assigning a reference to a readonly scalar
 573 constant into a stash entry in order to create
 574 a constant subroutine (like constant.pm
 575 does).
 576
 577 This same method is available from pure perl
 578 via, C<mro::method_changed_in(classname)>.
 579
 580 =cut
 581 */
 582 void
 583 Perl_mro_method_changed_in(pTHX_ HV *stash)
 584 {
 585     const char * const stashname = HvNAME_get(stash);
 586     const STRLEN stashname_len = HvNAMELEN_get(stash);
 587
 588     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 589     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
 590
 591     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
 592
 593     if(!stashname)
 594         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
 595
 596     /* Inc the package generation, since a local method changed */
 597     HvMROMETA(stash)->pkg_gen++;
 598
 599     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
 600        invalidate all method caches globally */
 601     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 602         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 603         PL_sub_generation++;
 604         return;
 605     }
 606
 607     /* else, invalidate the method caches of all child classes,
 608        but not itself */
 609     if(isarev) {
 610         HE* iter;
 611
 612         hv_iterinit(isarev);
 613         while((iter = hv_iternext(isarev))) {
 614             I32 len;
 615             const char* const revkey = hv_iterkey(iter, &len);
 616             HV* const revstash = gv_stashpvn(revkey, len, 0);
 617             struct mro_meta* mrometa;
 618
 619             if(!revstash) continue;
 620             mrometa = HvMROMETA(revstash);
 621             mrometa->cache_gen++;
 622             if(mrometa->mro_nextmethod)
 623                 hv_clear(mrometa->mro_nextmethod);
 624         }
 625     }
 626 }
 627
 628 void
 629 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
 630 {
 631     const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
 632
 633     PERL_ARGS_ASSERT_MRO_SET_MRO;
 634
 635     if (!which)
 636         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
 637
 638     if(meta->mro_which != which) {
 639         if (meta->mro_linear_current && !meta->mro_linear_all) {
 640             /* If we were storing something directly, put it in the hash before
 641                we lose it. */
 642             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
 643                                       MUTABLE_SV(meta->mro_linear_current));
 644         }
 645         meta->mro_which = which;
 646         /* Scrub our cached pointer to the private data.  */
 647         meta->mro_linear_current = NULL;
 648         /* Only affects local method cache, not
 649            even child classes */
 650         meta->cache_gen++;
 651         if(meta->mro_nextmethod)
 652             hv_clear(meta->mro_nextmethod);
 653     }
 654 }
 655
 656 #include "XSUB.h"
 657
 658 XS(XS_mro_method_changed_in);
 659
 660 void
 661 Perl_boot_core_mro(pTHX)
 662 {
 663     dVAR;
 664     static const char file[] = __FILE__;
 665
 666     Perl_mro_register(aTHX_ &dfs_alg);
 667
 668     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 669 }
 670
 671 XS(XS_mro_method_changed_in)
 672 {
 673     dVAR;
 674     dXSARGS;
 675     SV* classname;
 676     HV* class_stash;
 677
 678     if(items != 1)
 679         croak_xs_usage(cv, "classname");
 680
 681     classname = ST(0);
 682
 683     class_stash = gv_stashsv(classname, 0);
 684     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 685
 686     mro_method_changed_in(class_stash);
 687
 688     XSRETURN_EMPTY;
 689 }
 690
 691 /*
 692  * Local variables:
 693  * c-indentation-style: bsd
 694  * c-basic-offset: 4
 695  * indent-tabs-mode: t
 696  * End:
 697  *
 698  * ex: set ts=8 sts=4 sw=4 noet:
 699  */