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