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 #include "XSUB.h"
 623
 624 XS(XS_mro_get_linear_isa);
 625 XS(XS_mro_set_mro);
 626 XS(XS_mro_get_mro);
 627 XS(XS_mro_get_isarev);
 628 XS(XS_mro_is_universal);
 629 XS(XS_mro_invalidate_method_caches);
 630 XS(XS_mro_method_changed_in);
 631 XS(XS_mro_get_pkg_gen);
 632
 633 void
 634 Perl_boot_core_mro(pTHX)
 635 {
 636     dVAR;
 637     static const char file[] = __FILE__;
 638
 639     Perl_mro_register(aTHX_ &dfs_alg);
 640
 641     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
 642     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
 643     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
 644     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
 645     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
 646     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
 647     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 648     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
 649 }
 650
 651 XS(XS_mro_get_linear_isa) {
 652     dVAR;
 653     dXSARGS;
 654     AV* RETVAL;
 655     HV* class_stash;
 656     SV* classname;
 657
 658     if(items < 1 || items > 2)
 659         croak_xs_usage(cv, "classname [, type ]");
 660
 661     classname = ST(0);
 662     class_stash = gv_stashsv(classname, 0);
 663
 664     if(!class_stash) {
 665         /* No stash exists yet, give them just the classname */
 666         AV* isalin = newAV();
 667         av_push(isalin, newSVsv(classname));
 668         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
 669         XSRETURN(1);
 670     }
 671     else if(items > 1) {
 672         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
 673         if (!algo)
 674             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
 675         RETVAL = algo->resolve(aTHX_ class_stash, 0);
 676     }
 677     else {
 678         RETVAL = mro_get_linear_isa(class_stash);
 679     }
 680
 681     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
 682     sv_2mortal(ST(0));
 683     XSRETURN(1);
 684 }
 685
 686 XS(XS_mro_set_mro)
 687 {
 688     dVAR;
 689     dXSARGS;
 690     SV* classname;
 691     const struct mro_alg *which;
 692     HV* class_stash;
 693     struct mro_meta* meta;
 694
 695     if (items != 2)
 696         croak_xs_usage(cv, "classname, type");
 697
 698     classname = ST(0);
 699     class_stash = gv_stashsv(classname, GV_ADD);
 700     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 701     meta = HvMROMETA(class_stash);
 702
 703     which = Perl_mro_get_from_name(aTHX_ ST(1));
 704     if (!which)
 705         Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
 706
 707     if(meta->mro_which != which) {
 708         if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
 709             /* If we were storing something directly, put it in the hash before
 710                we lose it. */
 711             Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
 712                                       MUTABLE_SV(meta->mro_linear_c3));
 713         }
 714         meta->mro_which = which;
 715         /* Scrub our cached pointer to the private data.  */
 716         meta->mro_linear_c3 = NULL;
 717         /* Only affects local method cache, not
 718            even child classes */
 719         meta->cache_gen++;
 720         if(meta->mro_nextmethod)
 721             hv_clear(meta->mro_nextmethod);
 722     }
 723
 724     XSRETURN_EMPTY;
 725 }
 726
 727
 728 XS(XS_mro_get_mro)
 729 {
 730     dVAR;
 731     dXSARGS;
 732     SV* classname;
 733     HV* class_stash;
 734
 735     if (items != 1)
 736         croak_xs_usage(cv, "classname");
 737
 738     classname = ST(0);
 739     class_stash = gv_stashsv(classname, 0);
 740
 741     ST(0) = sv_2mortal(newSVpv(class_stash
 742                                ? HvMROMETA(class_stash)->mro_which->name
 743                                : "dfs", 0));
 744     XSRETURN(1);
 745 }
 746
 747 XS(XS_mro_get_isarev)
 748 {
 749     dVAR;
 750     dXSARGS;
 751     SV* classname;
 752     HE* he;
 753     HV* isarev;
 754     AV* ret_array;
 755
 756     if (items != 1)
 757         croak_xs_usage(cv, "classname");
 758
 759     classname = ST(0);
 760
 761     SP -= items;
 762
 763
 764     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 765     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 766
 767     ret_array = newAV();
 768     if(isarev) {
 769         HE* iter;
 770         hv_iterinit(isarev);
 771         while((iter = hv_iternext(isarev)))
 772             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
 773     }
 774     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
 775
 776     PUTBACK;
 777     return;
 778 }
 779
 780 XS(XS_mro_is_universal)
 781 {
 782     dVAR;
 783     dXSARGS;
 784     SV* classname;
 785     HV* isarev;
 786     char* classname_pv;
 787     STRLEN classname_len;
 788     HE* he;
 789
 790     if (items != 1)
 791         croak_xs_usage(cv, "classname");
 792
 793     classname = ST(0);
 794
 795     classname_pv = SvPV(classname,classname_len);
 796
 797     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 798     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 799
 800     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 801         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 802         XSRETURN_YES;
 803     else
 804         XSRETURN_NO;
 805 }
 806
 807 XS(XS_mro_invalidate_method_caches)
 808 {
 809     dVAR;
 810     dXSARGS;
 811
 812     if (items != 0)
 813         croak_xs_usage(cv, "");
 814
 815     PL_sub_generation++;
 816
 817     XSRETURN_EMPTY;
 818 }
 819
 820 XS(XS_mro_method_changed_in)
 821 {
 822     dVAR;
 823     dXSARGS;
 824     SV* classname;
 825     HV* class_stash;
 826
 827     if(items != 1)
 828         croak_xs_usage(cv, "classname");
 829
 830     classname = ST(0);
 831
 832     class_stash = gv_stashsv(classname, 0);
 833     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 834
 835     mro_method_changed_in(class_stash);
 836
 837     XSRETURN_EMPTY;
 838 }
 839
 840 XS(XS_mro_get_pkg_gen)
 841 {
 842     dVAR;
 843     dXSARGS;
 844     SV* classname;
 845     HV* class_stash;
 846
 847     if(items != 1)
 848         croak_xs_usage(cv, "classname");
 849
 850     classname = ST(0);
 851
 852     class_stash = gv_stashsv(classname, 0);
 853
 854     SP -= items;
 855
 856     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
 857
 858     PUTBACK;
 859     return;
 860 }
 861
 862 /*
 863  * Local variables:
 864  * c-indentation-style: bsd
 865  * c-basic-offset: 4
 866  * indent-tabs-mode: t
 867  * End:
 868  *
 869  * ex: set ts=8 sts=4 sw=4 noet:
 870  */