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