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