mro.c

   1 /*    mro.c
   2  *
   3  *    Copyright (c) 2007 Brandon L Black
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first?
  12  *  You'll be last either way, Master Peregrin."
  13  */
  14
  15 /*
  16 =head1 MRO Functions
  17
  18 These functions are related to the method resolution order of perl classes
  19
  20 =cut
  21 */
  22
  23 #include "EXTERN.h"
  24 #define PERL_IN_MRO_C
  25 #include "perl.h"
  26
  27 struct mro_alg {
  28     const char *name;
  29     AV *(*resolve)(pTHX_ HV* stash, I32 level);
  30 };
  31
  32 /* First one is the default */
  33 static struct mro_alg mros[] = {
  34     {"dfs", S_mro_get_linear_isa_dfs},
  35     {"c3", S_mro_get_linear_isa_c3}
  36 };
  37
  38 #define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
  39
  40 static const struct mro_alg *
  41 S_get_mro_from_name(pTHX_ const char *const name) {
  42     const struct mro_alg *algo = mros;
  43     const struct mro_alg *const end = mros + NUMBER_OF_MROS;
  44     while (algo < end) {
  45         if(strEQ(name, algo->name))
  46             return algo;
  47         ++algo;
  48     }
  49     return NULL;
  50 }
  51
  52 struct mro_meta*
  53 Perl_mro_meta_init(pTHX_ HV* stash)
  54 {
  55     struct mro_meta* newmeta;
  56
  57     PERL_ARGS_ASSERT_MRO_META_INIT;
  58     assert(HvAUX(stash));
  59     assert(!(HvAUX(stash)->xhv_mro_meta));
  60     Newxz(newmeta, 1, struct mro_meta);
  61     HvAUX(stash)->xhv_mro_meta = newmeta;
  62     newmeta->cache_gen = 1;
  63     newmeta->pkg_gen = 1;
  64     newmeta->mro_which = mros;
  65
  66     return newmeta;
  67 }
  68
  69 #if defined(USE_ITHREADS)
  70
  71 /* for sv_dup on new threads */
  72 struct mro_meta*
  73 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
  74 {
  75     struct mro_meta* newmeta;
  76
  77     PERL_ARGS_ASSERT_MRO_META_DUP;
  78
  79     Newx(newmeta, 1, struct mro_meta);
  80     Copy(smeta, newmeta, 1, struct mro_meta);
  81
  82     if (newmeta->mro_linear_dfs)
  83         newmeta->mro_linear_dfs
  84             = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
  85     if (newmeta->mro_linear_c3)
  86         newmeta->mro_linear_c3
  87             = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
  88     if (newmeta->mro_nextmethod)
  89         newmeta->mro_nextmethod
  90             = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
  91
  92     return newmeta;
  93 }
  94
  95 #endif /* USE_ITHREADS */
  96
  97 /*
  98 =for apidoc mro_get_linear_isa_dfs
  99
 100 Returns the Depth-First Search linearization of @ISA
 101 the given stash.  The return value is a read-only AV*.
 102 C<level> should be 0 (it is used internally in this
 103 function's recursion).
 104
 105 You are responsible for C<SvREFCNT_inc()> on the
 106 return value if you plan to store it anywhere
 107 semi-permanently (otherwise it might be deleted
 108 out from under you the next time the cache is
 109 invalidated).
 110
 111 =cut
 112 */
 113 static AV*
 114 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
 115 {
 116     AV* retval;
 117     GV** gvp;
 118     GV* gv;
 119     AV* av;
 120     const HEK* stashhek;
 121     struct mro_meta* meta;
 122
 123     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
 124     assert(HvAUX(stash));
 125
 126     stashhek = HvNAME_HEK(stash);
 127     if (!stashhek)
 128       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 129
 130     if (level > 100)
 131         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 132                    HEK_KEY(stashhek));
 133
 134     meta = HvMROMETA(stash);
 135
 136     /* return cache if valid */
 137     if((retval = meta->mro_linear_dfs)) {
 138         return retval;
 139     }
 140
 141     /* not in cache, make a new one */
 142
 143     retval = (AV*)sv_2mortal((SV *)newAV());
 144     av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */
 145
 146     /* fetch our @ISA */
 147     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 148     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 149
 150     if(av && AvFILLp(av) >= 0) {
 151
 152         /* "stored" is used to keep track of all of the classnames
 153            we have added to the MRO so far, so we can do a quick
 154            exists check and avoid adding duplicate classnames to
 155            the MRO as we go. */
 156
 157         HV* const stored = (HV*)sv_2mortal((SV*)newHV());
 158         SV **svp = AvARRAY(av);
 159         I32 items = AvFILLp(av) + 1;
 160
 161         /* foreach(@ISA) */
 162         while (items--) {
 163             SV* const sv = *svp++;
 164             HV* const basestash = gv_stashsv(sv, 0);
 165             SV *const *subrv_p;
 166             I32 subrv_items;
 167
 168             if (!basestash) {
 169                 /* if no stash exists for this @ISA member,
 170                    simply add it to the MRO and move on */
 171                 subrv_p = &sv;
 172                 subrv_items = 1;
 173             }
 174             else {
 175                 /* otherwise, recurse into ourselves for the MRO
 176                    of this @ISA member, and append their MRO to ours.
 177                    The recursive call could throw an exception, which
 178                    has memory management implications here, hence the use of
 179                    the mortal.  */
 180                 const AV *const subrv
 181                     = mro_get_linear_isa_dfs(basestash, level + 1);
 182
 183                 subrv_p = AvARRAY(subrv);
 184                 subrv_items = AvFILLp(subrv) + 1;
 185             }
 186             while(subrv_items--) {
 187                 SV *const subsv = *subrv_p++;
 188                 /* LVALUE fetch will create a new undefined SV if necessary
 189                  */
 190                 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
 191                 assert(he);
 192                 if(HeVAL(he) != &PL_sv_undef) {
 193                     /* It was newly created.  Steal it for our new SV, and
 194                        replace it in the hash with the "real" thing.  */
 195                     SV *const val = HeVAL(he);
 196                     HEK *const key = HeKEY_hek(he);
 197
 198                     HeVAL(he) = &PL_sv_undef;
 199                     /* Save copying by making a shared hash key scalar. We
 200                        inline this here rather than calling Perl_newSVpvn_share
 201                        because we already have the scalar, and we already have
 202                        the hash key.  */
 203                     assert(SvTYPE(val) == SVt_NULL);
 204                     sv_upgrade(val, SVt_PV);
 205                     SvPV_set(val, HEK_KEY(share_hek_hek(key)));
 206                     SvCUR_set(val, HEK_LEN(key));
 207                     SvREADONLY_on(val);
 208                     SvFAKE_on(val);
 209                     SvPOK_on(val);
 210                     if (HEK_UTF8(key))
 211                         SvUTF8_on(val);
 212
 213                     av_push(retval, val);
 214                 }
 215             }
 216         }
 217     }
 218
 219     /* now that we're past the exception dangers, grab our own reference to
 220        the AV we're about to use for the result. The reference owned by the
 221        mortals' stack will be released soon, so everything will balance.  */
 222     SvREFCNT_inc_simple_void_NN(retval);
 223     SvTEMP_off(retval);
 224
 225     /* we don't want anyone modifying the cache entry but us,
 226        and we do so by replacing it completely */
 227     SvREADONLY_on(retval);
 228
 229     meta->mro_linear_dfs = retval;
 230     return retval;
 231 }
 232
 233 /*
 234 =for apidoc mro_get_linear_isa_c3
 235
 236 Returns the C3 linearization of @ISA
 237 the given stash.  The return value is a read-only AV*.
 238 C<level> should be 0 (it is used internally in this
 239 function's recursion).
 240
 241 You are responsible for C<SvREFCNT_inc()> on the
 242 return value if you plan to store it anywhere
 243 semi-permanently (otherwise it might be deleted
 244 out from under you the next time the cache is
 245 invalidated).
 246
 247 =cut
 248 */
 249
 250 static AV*
 251 S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
 252 {
 253     AV* retval;
 254     GV** gvp;
 255     GV* gv;
 256     AV* isa;
 257     const HEK* stashhek;
 258     struct mro_meta* meta;
 259
 260     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
 261     assert(HvAUX(stash));
 262
 263     stashhek = HvNAME_HEK(stash);
 264     if (!stashhek)
 265       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 266
 267     if (level > 100)
 268         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 269                    HEK_KEY(stashhek));
 270
 271     meta = HvMROMETA(stash);
 272
 273     /* return cache if valid */
 274     if((retval = meta->mro_linear_c3)) {
 275         return retval;
 276     }
 277
 278     /* not in cache, make a new one */
 279
 280     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 281     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 282
 283     /* For a better idea how the rest of this works, see the much clearer
 284        pure perl version in Algorithm::C3 0.01:
 285        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
 286        (later versions go about it differently than this code for speed reasons)
 287     */
 288
 289     if(isa && AvFILLp(isa) >= 0) {
 290         SV** seqs_ptr;
 291         I32 seqs_items;
 292         HV* const tails = (HV*)sv_2mortal((SV*)newHV());
 293         AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
 294         I32* heads;
 295
 296         /* This builds @seqs, which is an array of arrays.
 297            The members of @seqs are the MROs of
 298            the members of @ISA, followed by @ISA itself.
 299         */
 300         I32 items = AvFILLp(isa) + 1;
 301         SV** isa_ptr = AvARRAY(isa);
 302         while(items--) {
 303             SV* const isa_item = *isa_ptr++;
 304             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
 305             if(!isa_item_stash) {
 306                 /* if no stash, make a temporary fake MRO
 307                    containing just itself */
 308                 AV* const isa_lin = newAV();
 309                 av_push(isa_lin, newSVsv(isa_item));
 310                 av_push(seqs, (SV*)isa_lin);
 311             }
 312             else {
 313                 /* recursion */
 314                 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
 315                 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
 316             }
 317         }
 318         av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
 319
 320         /* This builds "heads", which as an array of integer array
 321            indices, one per seq, which point at the virtual "head"
 322            of the seq (initially zero) */
 323         Newxz(heads, AvFILLp(seqs)+1, I32);
 324
 325         /* This builds %tails, which has one key for every class
 326            mentioned in the tail of any sequence in @seqs (tail meaning
 327            everything after the first class, the "head").  The value
 328            is how many times this key appears in the tails of @seqs.
 329         */
 330         seqs_ptr = AvARRAY(seqs);
 331         seqs_items = AvFILLp(seqs) + 1;
 332         while(seqs_items--) {
 333             AV* const seq = (AV*)*seqs_ptr++;
 334             I32 seq_items = AvFILLp(seq);
 335             if(seq_items > 0) {
 336                 SV** seq_ptr = AvARRAY(seq) + 1;
 337                 while(seq_items--) {
 338                     SV* const seqitem = *seq_ptr++;
 339                     /* LVALUE fetch will create a new undefined SV if necessary
 340                      */
 341                     HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
 342                     if(he) {
 343                         SV* const val = HeVAL(he);
 344                         /* This will increment undef to 1, which is what we
 345                            want for a newly created entry.  */
 346                         sv_inc(val);
 347                     }
 348                 }
 349             }
 350         }
 351
 352         /* Initialize retval to build the return value in */
 353         retval = newAV();
 354         av_push(retval, newSVhek(stashhek)); /* us first */
 355
 356         /* This loop won't terminate until we either finish building
 357            the MRO, or get an exception. */
 358         while(1) {
 359             SV* cand = NULL;
 360             SV* winner = NULL;
 361             int s;
 362
 363             /* "foreach $seq (@seqs)" */
 364             SV** const avptr = AvARRAY(seqs);
 365             for(s = 0; s <= AvFILLp(seqs); s++) {
 366                 SV** svp;
 367                 AV * const seq = (AV*)(avptr[s]);
 368                 SV* seqhead;
 369                 if(!seq) continue; /* skip empty seqs */
 370                 svp = av_fetch(seq, heads[s], 0);
 371                 seqhead = *svp; /* seqhead = head of this seq */
 372                 if(!winner) {
 373                     HE* tail_entry;
 374                     SV* val;
 375                     /* if we haven't found a winner for this round yet,
 376                        and this seqhead is not in tails (or the count
 377                        for it in tails has dropped to zero), then this
 378                        seqhead is our new winner, and is added to the
 379                        final MRO immediately */
 380                     cand = seqhead;
 381                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
 382                        && (val = HeVAL(tail_entry))
 383                        && (SvIVX(val) > 0))
 384                            continue;
 385                     winner = newSVsv(cand);
 386                     av_push(retval, winner);
 387                     /* note however that even when we find a winner,
 388                        we continue looping over @seqs to do housekeeping */
 389                 }
 390                 if(!sv_cmp(seqhead, winner)) {
 391                     /* Once we have a winner (including the iteration
 392                        where we first found him), inc the head ptr
 393                        for any seq which had the winner as a head,
 394                        NULL out any seq which is now empty,
 395                        and adjust tails for consistency */
 396
 397                     const int new_head = ++heads[s];
 398                     if(new_head > AvFILLp(seq)) {
 399                         SvREFCNT_dec(avptr[s]);
 400                         avptr[s] = NULL;
 401                     }
 402                     else {
 403                         HE* tail_entry;
 404                         SV* val;
 405                         /* Because we know this new seqhead used to be
 406                            a tail, we can assume it is in tails and has
 407                            a positive value, which we need to dec */
 408                         svp = av_fetch(seq, new_head, 0);
 409                         seqhead = *svp;
 410                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
 411                         val = HeVAL(tail_entry);
 412                         sv_dec(val);
 413                     }
 414                 }
 415             }
 416
 417             /* if we found no candidates, we are done building the MRO.
 418                !cand means no seqs have any entries left to check */
 419             if(!cand) {
 420                 Safefree(heads);
 421                 break;
 422             }
 423
 424             /* If we had candidates, but nobody won, then the @ISA
 425                hierarchy is not C3-incompatible */
 426             if(!winner) {
 427                 /* we have to do some cleanup before we croak */
 428
 429                 SvREFCNT_dec(retval);
 430                 Safefree(heads);
 431
 432                 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
 433                     "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
 434             }
 435         }
 436     }
 437     else { /* @ISA was undefined or empty */
 438         /* build a retval containing only ourselves */
 439         retval = newAV();
 440         av_push(retval, newSVhek(stashhek));
 441     }
 442
 443     /* we don't want anyone modifying the cache entry but us,
 444        and we do so by replacing it completely */
 445     SvREADONLY_on(retval);
 446
 447     meta->mro_linear_c3 = retval;
 448     return retval;
 449 }
 450
 451 /*
 452 =for apidoc mro_get_linear_isa
 453
 454 Returns either C<mro_get_linear_isa_c3> or
 455 C<mro_get_linear_isa_dfs> for the given stash,
 456 dependant upon which MRO is in effect
 457 for that stash.  The return value is a
 458 read-only AV*.
 459
 460 You are responsible for C<SvREFCNT_inc()> on the
 461 return value if you plan to store it anywhere
 462 semi-permanently (otherwise it might be deleted
 463 out from under you the next time the cache is
 464 invalidated).
 465
 466 =cut
 467 */
 468 AV*
 469 Perl_mro_get_linear_isa(pTHX_ HV *stash)
 470 {
 471     struct mro_meta* meta;
 472
 473     PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
 474     if(!SvOOK(stash))
 475         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 476
 477     meta = HvMROMETA(stash);
 478     if (!meta->mro_which)
 479         Perl_croak(aTHX_ "panic: invalid MRO!");
 480     return meta->mro_which->resolve(aTHX_ stash, 0);
 481 }
 482
 483 /*
 484 =for apidoc mro_isa_changed_in
 485
 486 Takes the necessary steps (cache invalidations, mostly)
 487 when the @ISA of the given package has changed.  Invoked
 488 by the C<setisa> magic, should not need to invoke directly.
 489
 490 =cut
 491 */
 492 void
 493 Perl_mro_isa_changed_in(pTHX_ HV* stash)
 494 {
 495     dVAR;
 496     HV* isarev;
 497     AV* linear_mro;
 498     HE* iter;
 499     SV** svp;
 500     I32 items;
 501     bool is_universal;
 502     struct mro_meta * meta;
 503
 504     const char * const stashname = HvNAME_get(stash);
 505     const STRLEN stashname_len = HvNAMELEN_get(stash);
 506
 507     PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
 508
 509     if(!stashname)
 510         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
 511
 512     /* wipe out the cached linearizations for this stash */
 513     meta = HvMROMETA(stash);
 514     SvREFCNT_dec((SV*)meta->mro_linear_dfs);
 515     SvREFCNT_dec((SV*)meta->mro_linear_c3);
 516     meta->mro_linear_dfs = NULL;
 517     meta->mro_linear_c3 = NULL;
 518
 519     /* Inc the package generation, since our @ISA changed */
 520     meta->pkg_gen++;
 521
 522     /* Wipe the global method cache if this package
 523        is UNIVERSAL or one of its parents */
 524
 525     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 526     isarev = svp ? (HV*)*svp : NULL;
 527
 528     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 529         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 530         PL_sub_generation++;
 531         is_universal = TRUE;
 532     }
 533     else { /* Wipe the local method cache otherwise */
 534         meta->cache_gen++;
 535         is_universal = FALSE;
 536     }
 537
 538     /* wipe next::method cache too */
 539     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
 540
 541     /* Iterate the isarev (classes that are our children),
 542        wiping out their linearization and method caches */
 543     if(isarev) {
 544         hv_iterinit(isarev);
 545         while((iter = hv_iternext(isarev))) {
 546             I32 len;
 547             const char* const revkey = hv_iterkey(iter, &len);
 548             HV* revstash = gv_stashpvn(revkey, len, 0);
 549             struct mro_meta* revmeta;
 550
 551             if(!revstash) continue;
 552             revmeta = HvMROMETA(revstash);
 553             SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
 554             SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
 555             revmeta->mro_linear_dfs = NULL;
 556             revmeta->mro_linear_c3 = NULL;
 557             if(!is_universal)
 558                 revmeta->cache_gen++;
 559             if(revmeta->mro_nextmethod)
 560                 hv_clear(revmeta->mro_nextmethod);
 561         }
 562     }
 563
 564     /* Now iterate our MRO (parents), and do a few things:
 565          1) instantiate with the "fake" flag if they don't exist
 566          2) flag them as universal if we are universal
 567          3) Add everything from our isarev to their isarev
 568     */
 569
 570     /* We're starting at the 2nd element, skipping ourselves here */
 571     linear_mro = mro_get_linear_isa(stash);
 572     svp = AvARRAY(linear_mro) + 1;
 573     items = AvFILLp(linear_mro);
 574
 575     while (items--) {
 576         SV* const sv = *svp++;
 577         HV* mroisarev;
 578
 579         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
 580
 581         /* That fetch should not fail.  But if it had to create a new SV for
 582            us, then will need to upgrade it to an HV (which sv_upgrade() can
 583            now do for us. */
 584
 585         mroisarev = (HV*)HeVAL(he);
 586
 587         SvUPGRADE((SV*)mroisarev, SVt_PVHV);
 588
 589         /* This hash only ever contains PL_sv_yes. Storing it over itself is
 590            almost as cheap as calling hv_exists, so on aggregate we expect to
 591            save time by not making two calls to the common HV code for the
 592            case where it doesn't exist.  */
 593
 594         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
 595
 596         if(isarev) {
 597             hv_iterinit(isarev);
 598             while((iter = hv_iternext(isarev))) {
 599                 I32 revkeylen;
 600                 char* const revkey = hv_iterkey(iter, &revkeylen);
 601                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
 602             }
 603         }
 604     }
 605 }
 606
 607 /*
 608 =for apidoc mro_method_changed_in
 609
 610 Invalidates method caching on any child classes
 611 of the given stash, so that they might notice
 612 the changes in this one.
 613
 614 Ideally, all instances of C<PL_sub_generation++> in
 615 perl source outside of C<mro.c> should be
 616 replaced by calls to this.
 617
 618 Perl automatically handles most of the common
 619 ways a method might be redefined.  However, there
 620 are a few ways you could change a method in a stash
 621 without the cache code noticing, in which case you
 622 need to call this method afterwards:
 623
 624 1) Directly manipulating the stash HV entries from
 625 XS code.
 626
 627 2) Assigning a reference to a readonly scalar
 628 constant into a stash entry in order to create
 629 a constant subroutine (like constant.pm
 630 does).
 631
 632 This same method is available from pure perl
 633 via, C<mro::method_changed_in(classname)>.
 634
 635 =cut
 636 */
 637 void
 638 Perl_mro_method_changed_in(pTHX_ HV *stash)
 639 {
 640     const char * const stashname = HvNAME_get(stash);
 641     const STRLEN stashname_len = HvNAMELEN_get(stash);
 642
 643     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 644     HV * const isarev = svp ? (HV*)*svp : NULL;
 645
 646     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
 647
 648     if(!stashname)
 649         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
 650
 651     /* Inc the package generation, since a local method changed */
 652     HvMROMETA(stash)->pkg_gen++;
 653
 654     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
 655        invalidate all method caches globally */
 656     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 657         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 658         PL_sub_generation++;
 659         return;
 660     }
 661
 662     /* else, invalidate the method caches of all child classes,
 663        but not itself */
 664     if(isarev) {
 665         HE* iter;
 666
 667         hv_iterinit(isarev);
 668         while((iter = hv_iternext(isarev))) {
 669             I32 len;
 670             const char* const revkey = hv_iterkey(iter, &len);
 671             HV* const revstash = gv_stashpvn(revkey, len, 0);
 672             struct mro_meta* mrometa;
 673
 674             if(!revstash) continue;
 675             mrometa = HvMROMETA(revstash);
 676             mrometa->cache_gen++;
 677             if(mrometa->mro_nextmethod)
 678                 hv_clear(mrometa->mro_nextmethod);
 679         }
 680     }
 681 }
 682
 683 /* These two are static helpers for next::method and friends,
 684    and re-implement a bunch of the code from pp_caller() in
 685    a more efficient manner for this particular usage.
 686 */
 687
 688 STATIC I32
 689 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 690     I32 i;
 691     for (i = startingblock; i >= 0; i--) {
 692         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 693     }
 694     return i;
 695 }
 696
 697 #include "XSUB.h"
 698
 699 XS(XS_mro_get_linear_isa);
 700 XS(XS_mro_set_mro);
 701 XS(XS_mro_get_mro);
 702 XS(XS_mro_get_isarev);
 703 XS(XS_mro_is_universal);
 704 XS(XS_mro_invalidate_method_caches);
 705 XS(XS_mro_method_changed_in);
 706 XS(XS_mro_get_pkg_gen);
 707 XS(XS_mro_nextcan);
 708
 709 void
 710 Perl_boot_core_mro(pTHX)
 711 {
 712     dVAR;
 713     static const char file[] = __FILE__;
 714
 715     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
 716     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
 717     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
 718     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
 719     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
 720     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
 721     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 722     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
 723     newXS("mro::_nextcan", XS_mro_nextcan, file);
 724 }
 725
 726 XS(XS_mro_get_linear_isa) {
 727     dVAR;
 728     dXSARGS;
 729     AV* RETVAL;
 730     HV* class_stash;
 731     SV* classname;
 732
 733     if(items < 1 || items > 2)
 734         croak_xs_usage(cv, "classname [, type ]");
 735
 736     classname = ST(0);
 737     class_stash = gv_stashsv(classname, 0);
 738
 739     if(!class_stash) {
 740         /* No stash exists yet, give them just the classname */
 741         AV* isalin = newAV();
 742         av_push(isalin, newSVsv(classname));
 743         ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
 744         XSRETURN(1);
 745     }
 746     else if(items > 1) {
 747         const char* const which = SvPV_nolen(ST(1));
 748         const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
 749         if (!algo)
 750             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
 751         RETVAL = algo->resolve(aTHX_ class_stash, 0);
 752     }
 753     else {
 754         RETVAL = mro_get_linear_isa(class_stash);
 755     }
 756
 757     ST(0) = newRV_inc((SV*)RETVAL);
 758     sv_2mortal(ST(0));
 759     XSRETURN(1);
 760 }
 761
 762 XS(XS_mro_set_mro)
 763 {
 764     dVAR;
 765     dXSARGS;
 766     SV* classname;
 767     const char* whichstr;
 768     const struct mro_alg *which;
 769     HV* class_stash;
 770     struct mro_meta* meta;
 771
 772     if (items != 2)
 773         croak_xs_usage(cv, "classname, type");
 774
 775     classname = ST(0);
 776     whichstr = SvPV_nolen(ST(1));
 777     class_stash = gv_stashsv(classname, GV_ADD);
 778     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 779     meta = HvMROMETA(class_stash);
 780
 781     which = S_get_mro_from_name(aTHX_ whichstr);
 782     if (!which)
 783         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
 784
 785     if(meta->mro_which != which) {
 786         meta->mro_which = which;
 787         /* Only affects local method cache, not
 788            even child classes */
 789         meta->cache_gen++;
 790         if(meta->mro_nextmethod)
 791             hv_clear(meta->mro_nextmethod);
 792     }
 793
 794     XSRETURN_EMPTY;
 795 }
 796
 797
 798 XS(XS_mro_get_mro)
 799 {
 800     dVAR;
 801     dXSARGS;
 802     SV* classname;
 803     HV* class_stash;
 804
 805     if (items != 1)
 806         croak_xs_usage(cv, "classname");
 807
 808     classname = ST(0);
 809     class_stash = gv_stashsv(classname, 0);
 810
 811     ST(0) = sv_2mortal(newSVpv(class_stash
 812                                ? HvMROMETA(class_stash)->mro_which->name
 813                                : "dfs", 0));
 814     XSRETURN(1);
 815 }
 816
 817 XS(XS_mro_get_isarev)
 818 {
 819     dVAR;
 820     dXSARGS;
 821     SV* classname;
 822     HE* he;
 823     HV* isarev;
 824     AV* ret_array;
 825
 826     if (items != 1)
 827         croak_xs_usage(cv, "classname");
 828
 829     classname = ST(0);
 830
 831     SP -= items;
 832
 833
 834     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 835     isarev = he ? (HV*)HeVAL(he) : NULL;
 836
 837     ret_array = newAV();
 838     if(isarev) {
 839         HE* iter;
 840         hv_iterinit(isarev);
 841         while((iter = hv_iternext(isarev)))
 842             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
 843     }
 844     mXPUSHs(newRV_noinc((SV*)ret_array));
 845
 846     PUTBACK;
 847     return;
 848 }
 849
 850 XS(XS_mro_is_universal)
 851 {
 852     dVAR;
 853     dXSARGS;
 854     SV* classname;
 855     HV* isarev;
 856     char* classname_pv;
 857     STRLEN classname_len;
 858     HE* he;
 859
 860     if (items != 1)
 861         croak_xs_usage(cv, "classname");
 862
 863     classname = ST(0);
 864
 865     classname_pv = SvPV(classname,classname_len);
 866
 867     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 868     isarev = he ? (HV*)HeVAL(he) : NULL;
 869
 870     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 871         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 872         XSRETURN_YES;
 873     else
 874         XSRETURN_NO;
 875 }
 876
 877 XS(XS_mro_invalidate_method_caches)
 878 {
 879     dVAR;
 880     dXSARGS;
 881
 882     if (items != 0)
 883         croak_xs_usage(cv, "");
 884
 885     PL_sub_generation++;
 886
 887     XSRETURN_EMPTY;
 888 }
 889
 890 XS(XS_mro_method_changed_in)
 891 {
 892     dVAR;
 893     dXSARGS;
 894     SV* classname;
 895     HV* class_stash;
 896
 897     if(items != 1)
 898         croak_xs_usage(cv, "classname");
 899
 900     classname = ST(0);
 901
 902     class_stash = gv_stashsv(classname, 0);
 903     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 904
 905     mro_method_changed_in(class_stash);
 906
 907     XSRETURN_EMPTY;
 908 }
 909
 910 XS(XS_mro_get_pkg_gen)
 911 {
 912     dVAR;
 913     dXSARGS;
 914     SV* classname;
 915     HV* class_stash;
 916
 917     if(items != 1)
 918         croak_xs_usage(cv, "classname");
 919
 920     classname = ST(0);
 921
 922     class_stash = gv_stashsv(classname, 0);
 923
 924     SP -= items;
 925
 926     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
 927
 928     PUTBACK;
 929     return;
 930 }
 931
 932 XS(XS_mro_nextcan)
 933 {
 934     dVAR;
 935     dXSARGS;
 936     SV* self = ST(0);
 937     const I32 throw_nomethod = SvIVX(ST(1));
 938     register I32 cxix = cxstack_ix;
 939     register const PERL_CONTEXT *ccstack = cxstack;
 940     const PERL_SI *top_si = PL_curstackinfo;
 941     HV* selfstash;
 942     SV *stashname;
 943     const char *fq_subname;
 944     const char *subname;
 945     STRLEN stashname_len;
 946     STRLEN subname_len;
 947     SV* sv;
 948     GV** gvp;
 949     AV* linear_av;
 950     SV** linear_svp;
 951     const char *hvname;
 952     I32 entries;
 953     struct mro_meta* selfmeta;
 954     HV* nmcache;
 955     I32 i;
 956
 957     PERL_UNUSED_ARG(cv);
 958
 959     SP -= items;
 960
 961     if(sv_isobject(self))
 962         selfstash = SvSTASH(SvRV(self));
 963     else
 964         selfstash = gv_stashsv(self, GV_ADD);
 965
 966     assert(selfstash);
 967
 968     hvname = HvNAME_get(selfstash);
 969     if (!hvname)
 970         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 971
 972     /* This block finds the contextually-enclosing fully-qualified subname,
 973        much like looking at (caller($i))[3] until you find a real sub that
 974        isn't ANON, etc (also skips over pureperl next::method, etc) */
 975     for(i = 0; i < 2; i++) {
 976         cxix = __dopoptosub_at(ccstack, cxix);
 977         for (;;) {
 978             GV* cvgv;
 979             STRLEN fq_subname_len;
 980
 981             /* we may be in a higher stacklevel, so dig down deeper */
 982             while (cxix < 0) {
 983                 if(top_si->si_type == PERLSI_MAIN)
 984                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 985                 top_si = top_si->si_prev;
 986                 ccstack = top_si->si_cxstack;
 987                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 988             }
 989
 990             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 991               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 992                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 993                 continue;
 994             }
 995
 996             {
 997                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 998                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 999                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1000                         cxix = dbcxix;
1001                         continue;
1002                     }
1003                 }
1004             }
1005
1006             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1007
1008             if(!isGV(cvgv)) {
1009                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1010                 continue;
1011             }
1012
1013             /* we found a real sub here */
1014             sv = sv_2mortal(newSV(0));
1015
1016             gv_efullname3(sv, cvgv, NULL);
1017
1018             fq_subname = SvPVX(sv);
1019             fq_subname_len = SvCUR(sv);
1020
1021             subname = strrchr(fq_subname, ':');
1022             if(!subname)
1023                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1024
1025             subname++;
1026             subname_len = fq_subname_len - (subname - fq_subname);
1027             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1028                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1029                 continue;
1030             }
1031             break;
1032         }
1033         cxix--;
1034     }
1035
1036     /* If we made it to here, we found our context */
1037
1038     /* Initialize the next::method cache for this stash
1039        if necessary */
1040     selfmeta = HvMROMETA(selfstash);
1041     if(!(nmcache = selfmeta->mro_nextmethod)) {
1042         nmcache = selfmeta->mro_nextmethod = newHV();
1043     }
1044     else { /* Use the cached coderef if it exists */
1045         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1046         if (cache_entry) {
1047             SV* const val = HeVAL(cache_entry);
1048             if(val == &PL_sv_undef) {
1049                 if(throw_nomethod)
1050                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1051                 XSRETURN_EMPTY;
1052             }
1053             mXPUSHs(newRV_inc(val));
1054             XSRETURN(1);
1055         }
1056     }
1057
1058     /* beyond here is just for cache misses, so perf isn't as critical */
1059
1060     stashname_len = subname - fq_subname - 2;
1061     stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1062
1063     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1064
1065     linear_svp = AvARRAY(linear_av);
1066     entries = AvFILLp(linear_av) + 1;
1067
1068     /* Walk down our MRO, skipping everything up
1069        to the contextually enclosing class */
1070     while (entries--) {
1071         SV * const linear_sv = *linear_svp++;
1072         assert(linear_sv);
1073         if(sv_eq(linear_sv, stashname))
1074             break;
1075     }
1076
1077     /* Now search the remainder of the MRO for the
1078        same method name as the contextually enclosing
1079        method */
1080     if(entries > 0) {
1081         while (entries--) {
1082             SV * const linear_sv = *linear_svp++;
1083             HV* curstash;
1084             GV* candidate;
1085             CV* cand_cv;
1086
1087             assert(linear_sv);
1088             curstash = gv_stashsv(linear_sv, FALSE);
1089
1090             if (!curstash) {
1091                 if (ckWARN(WARN_SYNTAX))
1092                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1093                         (void*)linear_sv, hvname);
1094                 continue;
1095             }
1096
1097             assert(curstash);
1098
1099             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1100             if (!gvp) continue;
1101
1102             candidate = *gvp;
1103             assert(candidate);
1104
1105             if (SvTYPE(candidate) != SVt_PVGV)
1106                 gv_init(candidate, curstash, subname, subname_len, TRUE);
1107
1108             /* Notably, we only look for real entries, not method cache
1109                entries, because in C3 the method cache of a parent is not
1110                valid for the child */
1111             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1112                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1113                 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1114                 mXPUSHs(newRV_inc((SV*)cand_cv));
1115                 XSRETURN(1);
1116             }
1117         }
1118     }
1119
1120     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1121     if(throw_nomethod)
1122         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1123     XSRETURN_EMPTY;
1124 }
1125
1126 /*
1127  * Local variables:
1128  * c-indentation-style: bsd
1129  * c-basic-offset: 4
1130  * indent-tabs-mode: t
1131  * End:
1132  *
1133  * ex: set ts=8 sts=4 sw=4 noet:
1134  */