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