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