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