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 = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), 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_c3 = MUTABLE_AV(*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 we've been asked to look up the private data for the current MRO, then
  61        cache it.  */
  62     if (smeta->mro_which == which)
  63         smeta->mro_linear_c3 = MUTABLE_AV(data);
  64
  65     if (!smeta->mro_linear_dfs) {
  66         HV *const hv = newHV();
  67         HvMAX(hv) = 0;  /* Start with 1 bucket. It's unlikely we'll need more.
  68                          */
  69         smeta->mro_linear_dfs = MUTABLE_AV(hv);
  70     }
  71
  72     if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
  73                         which->name, which->length, which->kflags,
  74                         HV_FETCH_ISSTORE, data, which->hash)) {
  75         Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
  76                    "for '%.*s' %d", (int) which->length, which->name,
  77                    which->kflags);
  78     }
  79
  80     return data;
  81 }
  82
  83 const struct mro_alg *
  84 Perl_mro_get_from_name(pTHX_ SV *name) {
  85     SV **data;
  86
  87     PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
  88
  89     data = Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
  90                           HV_FETCH_JUST_SV, NULL, 0);
  91     if (!data)
  92         return NULL;
  93     assert(SvTYPE(*data) == SVt_IV);
  94     assert(SvIOK(*data));
  95     return INT2PTR(const struct mro_alg *, SvUVX(*data));
  96 }
  97
  98 void
  99 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
 100     SV *wrapper = newSVuv(PTR2UV(mro));
 101
 102     PERL_ARGS_ASSERT_MRO_REGISTER;
 103
 104
 105     if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
 106                         mro->name, mro->length, mro->kflags,
 107                         HV_FETCH_ISSTORE, wrapper, mro->hash)) {
 108         SvREFCNT_dec(wrapper);
 109         Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
 110                    "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
 111     }
 112 }
 113
 114 struct mro_meta*
 115 Perl_mro_meta_init(pTHX_ HV* stash)
 116 {
 117     struct mro_meta* newmeta;
 118
 119     PERL_ARGS_ASSERT_MRO_META_INIT;
 120     assert(HvAUX(stash));
 121     assert(!(HvAUX(stash)->xhv_mro_meta));
 122     Newxz(newmeta, 1, struct mro_meta);
 123     HvAUX(stash)->xhv_mro_meta = newmeta;
 124     newmeta->cache_gen = 1;
 125     newmeta->pkg_gen = 1;
 126     newmeta->mro_which = &dfs_alg;
 127
 128     return newmeta;
 129 }
 130
 131 #if defined(USE_ITHREADS)
 132
 133 /* for sv_dup on new threads */
 134 struct mro_meta*
 135 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
 136 {
 137     struct mro_meta* newmeta;
 138
 139     PERL_ARGS_ASSERT_MRO_META_DUP;
 140
 141     Newx(newmeta, 1, struct mro_meta);
 142     Copy(smeta, newmeta, 1, struct mro_meta);
 143
 144     if (newmeta->mro_linear_dfs)
 145         newmeta->mro_linear_dfs
 146             = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
 147     newmeta->mro_linear_c3 = NULL;
 148     if (newmeta->mro_nextmethod)
 149         newmeta->mro_nextmethod
 150             = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
 151     if (newmeta->isa)
 152         newmeta->isa
 153             = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
 154
 155     return newmeta;
 156 }
 157
 158 #endif /* USE_ITHREADS */
 159
 160 HV *
 161 Perl_get_isa_hash(pTHX_ HV *const stash)
 162 {
 163     dVAR;
 164     struct mro_meta *const meta = HvMROMETA(stash);
 165
 166     PERL_ARGS_ASSERT_GET_ISA_HASH;
 167
 168     if (!meta->isa) {
 169         AV *const isa = mro_get_linear_isa(stash);
 170         if (!meta->isa) {
 171             HV *const isa_hash = newHV();
 172             /* Linearisation didn't build it for us, so do it here.  */
 173             SV *const *svp = AvARRAY(isa);
 174             SV *const *const svp_end = svp + AvFILLp(isa) + 1;
 175             const HEK *const canon_name = HvNAME_HEK(stash);
 176
 177             while (svp < svp_end) {
 178                 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
 179             }
 180
 181             (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
 182                              HEK_LEN(canon_name), HEK_FLAGS(canon_name),
 183                              HV_FETCH_ISSTORE, &PL_sv_undef,
 184                              HEK_HASH(canon_name));
 185             (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
 186
 187             SvREADONLY_on(isa_hash);
 188
 189             meta->isa = isa_hash;
 190         }
 191     }
 192     return meta->isa;
 193 }
 194
 195 /*
 196 =for apidoc mro_get_linear_isa_dfs
 197
 198 Returns the Depth-First Search linearization of @ISA
 199 the given stash.  The return value is a read-only AV*.
 200 C<level> should be 0 (it is used internally in this
 201 function's recursion).
 202
 203 You are responsible for C<SvREFCNT_inc()> on the
 204 return value if you plan to store it anywhere
 205 semi-permanently (otherwise it might be deleted
 206 out from under you the next time the cache is
 207 invalidated).
 208
 209 =cut
 210 */
 211 static AV*
 212 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
 213 {
 214     AV* retval;
 215     GV** gvp;
 216     GV* gv;
 217     AV* av;
 218     const HEK* stashhek;
 219     struct mro_meta* meta;
 220     SV *our_name;
 221     HV *stored;
 222
 223     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
 224     assert(HvAUX(stash));
 225
 226     stashhek = HvNAME_HEK(stash);
 227     if (!stashhek)
 228       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 229
 230     if (level > 100)
 231         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 232                    HEK_KEY(stashhek));
 233
 234     meta = HvMROMETA(stash);
 235
 236     /* return cache if valid */
 237     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
 238         return retval;
 239     }
 240
 241     /* not in cache, make a new one */
 242
 243     retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
 244     /* We use this later in this function, but don't need a reference to it
 245        beyond the end of this function, so reference count is fine.  */
 246     our_name = newSVhek(stashhek);
 247     av_push(retval, our_name); /* add ourselves at the top */
 248
 249     /* fetch our @ISA */
 250     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 251     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 252
 253     /* "stored" is used to keep track of all of the classnames we have added to
 254        the MRO so far, so we can do a quick exists check and avoid adding
 255        duplicate classnames to the MRO as we go.
 256        It's then retained to be re-used as a fast lookup for ->isa(), by adding
 257        our own name and "UNIVERSAL" to it.  */
 258
 259     stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
 260
 261     if(av && AvFILLp(av) >= 0) {
 262
 263         SV **svp = AvARRAY(av);
 264         I32 items = AvFILLp(av) + 1;
 265
 266         /* foreach(@ISA) */
 267         while (items--) {
 268             SV* const sv = *svp++;
 269             HV* const basestash = gv_stashsv(sv, 0);
 270             SV *const *subrv_p;
 271             I32 subrv_items;
 272
 273             if (!basestash) {
 274                 /* if no stash exists for this @ISA member,
 275                    simply add it to the MRO and move on */
 276                 subrv_p = &sv;
 277                 subrv_items = 1;
 278             }
 279             else {
 280                 /* otherwise, recurse into ourselves for the MRO
 281                    of this @ISA member, and append their MRO to ours.
 282                    The recursive call could throw an exception, which
 283                    has memory management implications here, hence the use of
 284                    the mortal.  */
 285                 const AV *const subrv
 286                     = mro_get_linear_isa_dfs(basestash, level + 1);
 287
 288                 subrv_p = AvARRAY(subrv);
 289                 subrv_items = AvFILLp(subrv) + 1;
 290             }
 291             while(subrv_items--) {
 292                 SV *const subsv = *subrv_p++;
 293                 /* LVALUE fetch will create a new undefined SV if necessary
 294                  */
 295                 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
 296                 assert(he);
 297                 if(HeVAL(he) != &PL_sv_undef) {
 298                     /* It was newly created.  Steal it for our new SV, and
 299                        replace it in the hash with the "real" thing.  */
 300                     SV *const val = HeVAL(he);
 301                     HEK *const key = HeKEY_hek(he);
 302
 303                     HeVAL(he) = &PL_sv_undef;
 304                     /* Save copying by making a shared hash key scalar. We
 305                        inline this here rather than calling Perl_newSVpvn_share
 306                        because we already have the scalar, and we already have
 307                        the hash key.  */
 308                     assert(SvTYPE(val) == SVt_NULL);
 309                     sv_upgrade(val, SVt_PV);
 310                     SvPV_set(val, HEK_KEY(share_hek_hek(key)));
 311                     SvCUR_set(val, HEK_LEN(key));
 312                     SvREADONLY_on(val);
 313                     SvFAKE_on(val);
 314                     SvPOK_on(val);
 315                     if (HEK_UTF8(key))
 316                         SvUTF8_on(val);
 317
 318                     av_push(retval, val);
 319                 }
 320             }
 321         }
 322     }
 323
 324     (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
 325     (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
 326
 327     SvREFCNT_inc_simple_void_NN(stored);
 328     SvTEMP_off(stored);
 329     SvREADONLY_on(stored);
 330
 331     meta->isa = stored;
 332
 333     /* now that we're past the exception dangers, grab our own reference to
 334        the AV we're about to use for the result. The reference owned by the
 335        mortals' stack will be released soon, so everything will balance.  */
 336     SvREFCNT_inc_simple_void_NN(retval);
 337     SvTEMP_off(retval);
 338
 339     /* we don't want anyone modifying the cache entry but us,
 340        and we do so by replacing it completely */
 341     SvREADONLY_on(retval);
 342
 343     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
 344                                                 MUTABLE_SV(retval)));
 345 }
 346
 347 /*
 348 =for apidoc mro_get_linear_isa
 349
 350 Returns either C<mro_get_linear_isa_c3> or
 351 C<mro_get_linear_isa_dfs> for the given stash,
 352 dependant upon which MRO is in effect
 353 for that stash.  The return value is a
 354 read-only AV*.
 355
 356 You are responsible for C<SvREFCNT_inc()> on the
 357 return value if you plan to store it anywhere
 358 semi-permanently (otherwise it might be deleted
 359 out from under you the next time the cache is
 360 invalidated).
 361
 362 =cut
 363 */
 364 AV*
 365 Perl_mro_get_linear_isa(pTHX_ HV *stash)
 366 {
 367     struct mro_meta* meta;
 368
 369     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
 370     if(!SvOOK(stash))
 371         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 372
 373     meta = HvMROMETA(stash);
 374     if (!meta->mro_which)
 375         Perl_croak(aTHX_ "panic: invalid MRO!");
 376     return meta->mro_which->resolve(aTHX_ stash, 0);
 377 }
 378
 379 /*
 380 =for apidoc mro_isa_changed_in
 381
 382 Takes the necessary steps (cache invalidations, mostly)
 383 when the @ISA of the given package has changed.  Invoked
 384 by the C<setisa> magic, should not need to invoke directly.
 385
 386 =cut
 387 */
 388 void
 389 Perl_mro_isa_changed_in(pTHX_ HV* stash)
 390 {
 391     dVAR;
 392     HV* isarev;
 393     AV* linear_mro;
 394     HE* iter;
 395     SV** svp;
 396     I32 items;
 397     bool is_universal;
 398     struct mro_meta * meta;
 399
 400     const char * const stashname = HvNAME_get(stash);
 401     const STRLEN stashname_len = HvNAMELEN_get(stash);
 402
 403     PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
 404
 405     if(!stashname)
 406         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
 407
 408     /* wipe out the cached linearizations for this stash */
 409     meta = HvMROMETA(stash);
 410     SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
 411     meta->mro_linear_dfs = NULL;
 412     meta->mro_linear_c3 = NULL;
 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 and method 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             SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
 453             revmeta->mro_linear_dfs = NULL;
 454             revmeta->mro_linear_c3 = NULL;
 455             if(!is_universal)
 456                 revmeta->cache_gen++;
 457             if(revmeta->mro_nextmethod)
 458                 hv_clear(revmeta->mro_nextmethod);
 459         }
 460     }
 461
 462     /* Now iterate our MRO (parents), and do a few things:
 463          1) instantiate with the "fake" flag if they don't exist
 464          2) flag them as universal if we are universal
 465          3) Add everything from our isarev to their isarev
 466     */
 467
 468     /* We're starting at the 2nd element, skipping ourselves here */
 469     linear_mro = mro_get_linear_isa(stash);
 470     svp = AvARRAY(linear_mro) + 1;
 471     items = AvFILLp(linear_mro);
 472
 473     while (items--) {
 474         SV* const sv = *svp++;
 475         HV* mroisarev;
 476
 477         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
 478
 479         /* That fetch should not fail.  But if it had to create a new SV for
 480            us, then will need to upgrade it to an HV (which sv_upgrade() can
 481            now do for us. */
 482
 483         mroisarev = MUTABLE_HV(HeVAL(he));
 484
 485         SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
 486
 487         /* This hash only ever contains PL_sv_yes. Storing it over itself is
 488            almost as cheap as calling hv_exists, so on aggregate we expect to
 489            save time by not making two calls to the common HV code for the
 490            case where it doesn't exist.  */
 491
 492         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
 493
 494         if(isarev) {
 495             hv_iterinit(isarev);
 496             while((iter = hv_iternext(isarev))) {
 497                 I32 revkeylen;
 498                 char* const revkey = hv_iterkey(iter, &revkeylen);
 499                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
 500             }
 501         }
 502     }
 503 }
 504
 505 /*
 506 =for apidoc mro_method_changed_in
 507
 508 Invalidates method caching on any child classes
 509 of the given stash, so that they might notice
 510 the changes in this one.
 511
 512 Ideally, all instances of C<PL_sub_generation++> in
 513 perl source outside of C<mro.c> should be
 514 replaced by calls to this.
 515
 516 Perl automatically handles most of the common
 517 ways a method might be redefined.  However, there
 518 are a few ways you could change a method in a stash
 519 without the cache code noticing, in which case you
 520 need to call this method afterwards:
 521
 522 1) Directly manipulating the stash HV entries from
 523 XS code.
 524
 525 2) Assigning a reference to a readonly scalar
 526 constant into a stash entry in order to create
 527 a constant subroutine (like constant.pm
 528 does).
 529
 530 This same method is available from pure perl
 531 via, C<mro::method_changed_in(classname)>.
 532
 533 =cut
 534 */
 535 void
 536 Perl_mro_method_changed_in(pTHX_ HV *stash)
 537 {
 538     const char * const stashname = HvNAME_get(stash);
 539     const STRLEN stashname_len = HvNAMELEN_get(stash);
 540
 541     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 542     HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
 543
 544     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
 545
 546     if(!stashname)
 547         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
 548
 549     /* Inc the package generation, since a local method changed */
 550     HvMROMETA(stash)->pkg_gen++;
 551
 552     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
 553        invalidate all method caches globally */
 554     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 555         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 556         PL_sub_generation++;
 557         return;
 558     }
 559
 560     /* else, invalidate the method caches of all child classes,
 561        but not itself */
 562     if(isarev) {
 563         HE* iter;
 564
 565         hv_iterinit(isarev);
 566         while((iter = hv_iternext(isarev))) {
 567             I32 len;
 568             const char* const revkey = hv_iterkey(iter, &len);
 569             HV* const revstash = gv_stashpvn(revkey, len, 0);
 570             struct mro_meta* mrometa;
 571
 572             if(!revstash) continue;
 573             mrometa = HvMROMETA(revstash);
 574             mrometa->cache_gen++;
 575             if(mrometa->mro_nextmethod)
 576                 hv_clear(mrometa->mro_nextmethod);
 577         }
 578     }
 579 }
 580
 581 #include "XSUB.h"
 582
 583 XS(XS_mro_get_linear_isa);
 584 XS(XS_mro_set_mro);
 585 XS(XS_mro_get_mro);
 586 XS(XS_mro_get_isarev);
 587 XS(XS_mro_is_universal);
 588 XS(XS_mro_invalidate_method_caches);
 589 XS(XS_mro_method_changed_in);
 590 XS(XS_mro_get_pkg_gen);
 591
 592 void
 593 Perl_boot_core_mro(pTHX)
 594 {
 595     dVAR;
 596     static const char file[] = __FILE__;
 597
 598     Perl_mro_register(aTHX_ &dfs_alg);
 599
 600     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
 601     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
 602     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
 603     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
 604     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
 605     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
 606     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 607     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
 608 }
 609
 610 XS(XS_mro_get_linear_isa) {
 611     dVAR;
 612     dXSARGS;
 613     AV* RETVAL;
 614     HV* class_stash;
 615     SV* classname;
 616
 617     if(items < 1 || items > 2)
 618         croak_xs_usage(cv, "classname [, type ]");
 619
 620     classname = ST(0);
 621     class_stash = gv_stashsv(classname, 0);
 622
 623     if(!class_stash) {
 624         /* No stash exists yet, give them just the classname */
 625         AV* isalin = newAV();
 626         av_push(isalin, newSVsv(classname));
 627         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
 628         XSRETURN(1);
 629     }
 630     else if(items > 1) {
 631         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
 632         if (!algo)
 633             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
 634         RETVAL = algo->resolve(aTHX_ class_stash, 0);
 635     }
 636     else {
 637         RETVAL = mro_get_linear_isa(class_stash);
 638     }
 639
 640     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
 641     sv_2mortal(ST(0));
 642     XSRETURN(1);
 643 }
 644
 645 XS(XS_mro_set_mro)
 646 {
 647     dVAR;
 648     dXSARGS;
 649     SV* classname;
 650     const struct mro_alg *which;
 651     HV* class_stash;
 652     struct mro_meta* meta;
 653
 654     if (items != 2)
 655         croak_xs_usage(cv, "classname, type");
 656
 657     classname = ST(0);
 658     class_stash = gv_stashsv(classname, GV_ADD);
 659     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 660     meta = HvMROMETA(class_stash);
 661
 662     which = Perl_mro_get_from_name(aTHX_ ST(1));
 663     if (!which)
 664         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
 665
 666     if(meta->mro_which != which) {
 667         meta->mro_which = which;
 668         /* Scrub our cached pointer to the private data.  */
 669         meta->mro_linear_c3 = NULL;
 670         /* Only affects local method cache, not
 671            even child classes */
 672         meta->cache_gen++;
 673         if(meta->mro_nextmethod)
 674             hv_clear(meta->mro_nextmethod);
 675     }
 676
 677     XSRETURN_EMPTY;
 678 }
 679
 680
 681 XS(XS_mro_get_mro)
 682 {
 683     dVAR;
 684     dXSARGS;
 685     SV* classname;
 686     HV* class_stash;
 687
 688     if (items != 1)
 689         croak_xs_usage(cv, "classname");
 690
 691     classname = ST(0);
 692     class_stash = gv_stashsv(classname, 0);
 693
 694     ST(0) = sv_2mortal(newSVpv(class_stash
 695                                ? HvMROMETA(class_stash)->mro_which->name
 696                                : "dfs", 0));
 697     XSRETURN(1);
 698 }
 699
 700 XS(XS_mro_get_isarev)
 701 {
 702     dVAR;
 703     dXSARGS;
 704     SV* classname;
 705     HE* he;
 706     HV* isarev;
 707     AV* ret_array;
 708
 709     if (items != 1)
 710         croak_xs_usage(cv, "classname");
 711
 712     classname = ST(0);
 713
 714     SP -= items;
 715
 716
 717     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 718     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 719
 720     ret_array = newAV();
 721     if(isarev) {
 722         HE* iter;
 723         hv_iterinit(isarev);
 724         while((iter = hv_iternext(isarev)))
 725             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
 726     }
 727     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
 728
 729     PUTBACK;
 730     return;
 731 }
 732
 733 XS(XS_mro_is_universal)
 734 {
 735     dVAR;
 736     dXSARGS;
 737     SV* classname;
 738     HV* isarev;
 739     char* classname_pv;
 740     STRLEN classname_len;
 741     HE* he;
 742
 743     if (items != 1)
 744         croak_xs_usage(cv, "classname");
 745
 746     classname = ST(0);
 747
 748     classname_pv = SvPV(classname,classname_len);
 749
 750     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 751     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 752
 753     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 754         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 755         XSRETURN_YES;
 756     else
 757         XSRETURN_NO;
 758 }
 759
 760 XS(XS_mro_invalidate_method_caches)
 761 {
 762     dVAR;
 763     dXSARGS;
 764
 765     if (items != 0)
 766         croak_xs_usage(cv, "");
 767
 768     PL_sub_generation++;
 769
 770     XSRETURN_EMPTY;
 771 }
 772
 773 XS(XS_mro_method_changed_in)
 774 {
 775     dVAR;
 776     dXSARGS;
 777     SV* classname;
 778     HV* class_stash;
 779
 780     if(items != 1)
 781         croak_xs_usage(cv, "classname");
 782
 783     classname = ST(0);
 784
 785     class_stash = gv_stashsv(classname, 0);
 786     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 787
 788     mro_method_changed_in(class_stash);
 789
 790     XSRETURN_EMPTY;
 791 }
 792
 793 XS(XS_mro_get_pkg_gen)
 794 {
 795     dVAR;
 796     dXSARGS;
 797     SV* classname;
 798     HV* class_stash;
 799
 800     if(items != 1)
 801         croak_xs_usage(cv, "classname");
 802
 803     classname = ST(0);
 804
 805     class_stash = gv_stashsv(classname, 0);
 806
 807     SP -= items;
 808
 809     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
 810
 811     PUTBACK;
 812     return;
 813 }
 814
 815 /*
 816  * Local variables:
 817  * c-indentation-style: bsd
 818  * c-basic-offset: 4
 819  * indent-tabs-mode: t
 820  * End:
 821  *
 822  * ex: set ts=8 sts=4 sw=4 noet:
 823  */