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