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