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     return NULL; /* NOT REACHED */
 435 }
 436
 437 /*
 438 =for apidoc mro_isa_changed_in
 439
 440 Takes the necessary steps (cache invalidations, mostly)
 441 when the @ISA of the given package has changed.  Invoked
 442 by the C<setisa> magic, should not need to invoke directly.
 443
 444 =cut
 445 */
 446 void
 447 Perl_mro_isa_changed_in(pTHX_ HV* stash)
 448 {
 449     dVAR;
 450     HV* isarev;
 451     AV* linear_mro;
 452     HE* iter;
 453     SV** svp;
 454     I32 items;
 455     struct mro_meta* meta;
 456     char* stashname;
 457
 458     stashname = HvNAME_get(stash);
 459
 460     /* wipe out the cached linearizations for this stash */
 461     meta = HvMROMETA(stash);
 462     SvREFCNT_dec((SV*)meta->mro_linear_dfs);
 463     SvREFCNT_dec((SV*)meta->mro_linear_c3);
 464     meta->mro_linear_dfs = NULL;
 465     meta->mro_linear_c3 = NULL;
 466
 467     /* Wipe the global method cache if this package
 468        is UNIVERSAL or one of its parents */
 469     if(meta->is_universal)
 470         PL_sub_generation++;
 471
 472     /* Wipe the local method cache otherwise */
 473     else
 474         meta->sub_generation++;
 475
 476     /* wipe next::method cache too */
 477     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
 478
 479     /* Iterate the isarev (classes that are our children),
 480        wiping out their linearization and method caches */
 481     if((isarev = meta->mro_isarev)) {
 482         hv_iterinit(isarev);
 483         while((iter = hv_iternext(isarev))) {
 484             SV* revkey = hv_iterkeysv(iter);
 485             HV* revstash = gv_stashsv(revkey, 0);
 486             struct mro_meta* revmeta = HvMROMETA(revstash);
 487             SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
 488             SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
 489             revmeta->mro_linear_dfs = NULL;
 490             revmeta->mro_linear_c3 = NULL;
 491             if(!meta->is_universal)
 492                 revmeta->sub_generation++;
 493             if(revmeta->mro_nextmethod)
 494                 hv_clear(revmeta->mro_nextmethod);
 495         }
 496     }
 497
 498     /* Now iterate our MRO (parents), and do a few things:
 499          1) instantiate with the "fake" flag if they don't exist
 500          2) flag them as universal if we are universal
 501          3) Add everything from our isarev to their isarev
 502     */
 503
 504     /* We're starting at the 2nd element, skipping ourselves here */
 505     linear_mro = mro_get_linear_isa(stash);
 506     svp = AvARRAY(linear_mro) + 1;
 507     items = AvFILLp(linear_mro);
 508
 509     while (items--) {
 510         SV* const sv = *svp++;
 511         struct mro_meta* mrometa;
 512         HV* mroisarev;
 513
 514         HV* mrostash = gv_stashsv(sv, 0);
 515         if(!mrostash) {
 516             mrostash = gv_stashsv(sv, GV_ADD);
 517             /*
 518                We created the package on the fly, so
 519                that we could store isarev information.
 520                This flag lets gv_fetchmeth know about it,
 521                so that it can still generate the very useful
 522                "Can't locate package Foo for @Bar::ISA" warning.
 523             */
 524             HvMROMETA(mrostash)->fake = 1;
 525         }
 526
 527         mrometa = HvMROMETA(mrostash);
 528         mroisarev = mrometa->mro_isarev;
 529
 530         /* is_universal is viral */
 531         if(meta->is_universal)
 532             mrometa->is_universal = 1;
 533
 534         if(!mroisarev)
 535             mroisarev = mrometa->mro_isarev = newHV();
 536
 537         /* This hash only ever contains PL_sv_yes. Storing it over itself is
 538            almost as cheap as calling hv_exists, so on aggregate we expect to
 539            save time by not making two calls to the common HV code for the
 540            case where it doesn't exist.  */
 541
 542         hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
 543
 544         if(isarev) {
 545             hv_iterinit(isarev);
 546             while((iter = hv_iternext(isarev))) {
 547                 SV* revkey = hv_iterkeysv(iter);
 548                 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
 549             }
 550         }
 551     }
 552 }
 553
 554 /*
 555 =for apidoc mro_method_changed_in
 556
 557 Invalidates method caching on any child classes
 558 of the given stash, so that they might notice
 559 the changes in this one.
 560
 561 Ideally, all instances of C<PL_sub_generation++> in
 562 the perl source outside of C<mro.c> should be
 563 replaced by calls to this.  This conversion is
 564 nearly complete.
 565
 566 Perl has always had problems with method caches
 567 getting out of sync when one directly manipulates
 568 stashes via things like C<%{Foo::} = %{Bar::}> or
 569 C<${Foo::}{bar} = ...> or the equivalent.  If
 570 you do this in core or XS code, call this afterwards
 571 on the destination stash to get things back in sync.
 572
 573 If you're doing such a thing from pure perl, use
 574 C<mro::method_changed_in(classname)>, which
 575 just calls this.
 576
 577 =cut
 578 */
 579 void
 580 Perl_mro_method_changed_in(pTHX_ HV *stash)
 581 {
 582     struct mro_meta* meta = HvMROMETA(stash);
 583     HV* isarev;
 584     HE* iter;
 585
 586     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
 587        invalidate all method caches globally */
 588     if(meta->is_universal) {
 589         PL_sub_generation++;
 590         return;
 591     }
 592
 593     /* else, invalidate the method caches of all child classes,
 594        but not itself */
 595     if((isarev = meta->mro_isarev)) {
 596         hv_iterinit(isarev);
 597         while((iter = hv_iternext(isarev))) {
 598             SV* revkey = hv_iterkeysv(iter);
 599             HV* revstash = gv_stashsv(revkey, 0);
 600             struct mro_meta* mrometa = HvMROMETA(revstash);
 601             mrometa->sub_generation++;
 602             if(mrometa->mro_nextmethod)
 603                 hv_clear(mrometa->mro_nextmethod);
 604         }
 605     }
 606 }
 607
 608 /* These two are static helpers for next::method and friends,
 609    and re-implement a bunch of the code from pp_caller() in
 610    a more efficient manner for this particular usage.
 611 */
 612
 613 STATIC I32
 614 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 615     I32 i;
 616     for (i = startingblock; i >= 0; i--) {
 617         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 618     }
 619     return i;
 620 }
 621
 622 STATIC SV*
 623 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
 624 {
 625     register I32 cxix;
 626     register const PERL_CONTEXT *ccstack = cxstack;
 627     const PERL_SI *top_si = PL_curstackinfo;
 628     HV* selfstash;
 629     GV* cvgv;
 630     SV *stashname;
 631     const char *fq_subname;
 632     const char *subname;
 633     STRLEN fq_subname_len;
 634     STRLEN stashname_len;
 635     STRLEN subname_len;
 636     SV* sv;
 637     GV** gvp;
 638     AV* linear_av;
 639     SV** linear_svp;
 640     SV* linear_sv;
 641     HV* curstash;
 642     GV* candidate = NULL;
 643     CV* cand_cv = NULL;
 644     const char *hvname;
 645     I32 items;
 646     struct mro_meta* selfmeta;
 647     HV* nmcache;
 648     HE* cache_entry;
 649
 650     if(sv_isobject(self))
 651         selfstash = SvSTASH(SvRV(self));
 652     else
 653         selfstash = gv_stashsv(self, 0);
 654
 655     assert(selfstash);
 656
 657     hvname = HvNAME_get(selfstash);
 658     if (!hvname)
 659         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 660
 661     cxix = __dopoptosub_at(cxstack, cxstack_ix);
 662
 663     /* This block finds the contextually-enclosing fully-qualified subname,
 664        much like looking at (caller($i))[3] until you find a real sub that
 665        isn't ANON, etc */
 666     for (;;) {
 667         /* we may be in a higher stacklevel, so dig down deeper */
 668         while (cxix < 0) {
 669             if(top_si->si_type == PERLSI_MAIN)
 670                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 671             top_si = top_si->si_prev;
 672             ccstack = top_si->si_cxstack;
 673             cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 674         }
 675
 676         if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 677           || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 678             cxix = __dopoptosub_at(ccstack, cxix - 1);
 679             continue;
 680         }
 681
 682         {
 683             const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 684             if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 685                 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 686                     cxix = dbcxix;
 687                     continue;
 688                 }
 689             }
 690         }
 691
 692         cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 693
 694         if(!isGV(cvgv)) {
 695             cxix = __dopoptosub_at(ccstack, cxix - 1);
 696             continue;
 697         }
 698
 699         /* we found a real sub here */
 700         sv = sv_2mortal(newSV(0));
 701
 702         gv_efullname3(sv, cvgv, NULL);
 703
 704         fq_subname = SvPVX(sv);
 705         fq_subname_len = SvCUR(sv);
 706
 707         subname = strrchr(fq_subname, ':');
 708         if(!subname)
 709             Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 710
 711         subname++;
 712         subname_len = fq_subname_len - (subname - fq_subname);
 713         if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 714             cxix = __dopoptosub_at(ccstack, cxix - 1);
 715             continue;
 716         }
 717         break;
 718     }
 719
 720     /* If we made it to here, we found our context */
 721
 722     /* Initialize the next::method cache for this stash
 723        if necessary */
 724     selfmeta = HvMROMETA(selfstash);
 725     if(!(nmcache = selfmeta->mro_nextmethod)) {
 726         nmcache = selfmeta->mro_nextmethod = newHV();
 727     }
 728
 729     /* Use the cached coderef if it exists */
 730     else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
 731         SV* val = HeVAL(cache_entry);
 732         if(val == &PL_sv_undef) {
 733             if(throw_nomethod)
 734                 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 735         }
 736         return val;
 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         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             linear_sv = *linear_svp++;
 764             assert(linear_sv);
 765             curstash = gv_stashsv(linear_sv, FALSE);
 766
 767             if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
 768                 if (ckWARN(WARN_SYNTAX))
 769                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 770                         (void*)linear_sv, hvname);
 771                 continue;
 772             }
 773
 774             assert(curstash);
 775
 776             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
 777             if (!gvp) continue;
 778
 779             candidate = *gvp;
 780             assert(candidate);
 781
 782             if (SvTYPE(candidate) != SVt_PVGV)
 783                 gv_init(candidate, curstash, subname, subname_len, TRUE);
 784
 785             /* Notably, we only look for real entries, not method cache
 786                entries, because in C3 the method cache of a parent is not
 787                valid for the child */
 788             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 789                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
 790                 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
 791                 return (SV*)cand_cv;
 792             }
 793         }
 794     }
 795
 796     hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
 797     if(throw_nomethod)
 798         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 799     return &PL_sv_undef;
 800 }
 801
 802 #include "XSUB.h"
 803
 804 XS(XS_mro_get_linear_isa);
 805 XS(XS_mro_set_mro);
 806 XS(XS_mro_get_mro);
 807 XS(XS_mro_get_isarev);
 808 XS(XS_mro_is_universal);
 809 XS(XS_mro_get_global_sub_gen);
 810 XS(XS_mro_invalidate_method_caches);
 811 XS(XS_mro_get_sub_generation);
 812 XS(XS_mro_method_changed_in);
 813 XS(XS_next_can);
 814 XS(XS_next_method);
 815 XS(XS_maybe_next_method);
 816
 817 void
 818 Perl_boot_core_mro(pTHX)
 819 {
 820     dVAR;
 821     static const char file[] = __FILE__;
 822
 823     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
 824     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
 825     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
 826     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
 827     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
 828     newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, "");
 829     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
 830     newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
 831     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 832     newXS("next::can", XS_next_can, file);
 833     newXS("next::method", XS_next_method, file);
 834     newXS("maybe::next::method", XS_maybe_next_method, file);
 835 }
 836
 837 XS(XS_mro_get_linear_isa) {
 838     dVAR;
 839     dXSARGS;
 840     AV* RETVAL;
 841     HV* class_stash;
 842     SV* classname;
 843
 844     PERL_UNUSED_ARG(cv);
 845
 846     if(items < 1 || items > 2)
 847        Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
 848
 849     classname = ST(0);
 850     class_stash = gv_stashsv(classname, 0);
 851     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 852
 853     if(items > 1) {
 854         char* which = SvPV_nolen(ST(1));
 855         if(strEQ(which, "dfs"))
 856             RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
 857         else if(strEQ(which, "c3"))
 858             RETVAL = mro_get_linear_isa_c3(class_stash, 0);
 859         else
 860             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
 861     }
 862     else {
 863         RETVAL = mro_get_linear_isa(class_stash);
 864     }
 865
 866     ST(0) = newRV_inc((SV*)RETVAL);
 867     sv_2mortal(ST(0));
 868     XSRETURN(1);
 869 }
 870
 871 XS(XS_mro_set_mro)
 872 {
 873     dVAR;
 874     dXSARGS;
 875     SV* classname;
 876     char* whichstr;
 877     mro_alg which;
 878     HV* class_stash;
 879     struct mro_meta* meta;
 880
 881     PERL_UNUSED_ARG(cv);
 882
 883     if (items != 2)
 884        Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
 885
 886     classname = ST(0);
 887     whichstr = SvPV_nolen(ST(1));
 888     class_stash = gv_stashsv(classname, GV_ADD);
 889     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 890     meta = HvMROMETA(class_stash);
 891
 892     if(strEQ(whichstr, "dfs"))
 893         which = MRO_DFS;
 894     else if(strEQ(whichstr, "c3"))
 895         which = MRO_C3;
 896     else
 897         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
 898
 899     if(meta->mro_which != which) {
 900         meta->mro_which = which;
 901         /* Only affects local method cache, not
 902            even child classes */
 903         meta->sub_generation++;
 904         if(meta->mro_nextmethod)
 905             hv_clear(meta->mro_nextmethod);
 906     }
 907
 908     XSRETURN_EMPTY;
 909 }
 910
 911
 912 XS(XS_mro_get_mro)
 913 {
 914     dVAR;
 915     dXSARGS;
 916     SV* classname;
 917     HV* class_stash;
 918     struct mro_meta* meta;
 919
 920     PERL_UNUSED_ARG(cv);
 921
 922     if (items != 1)
 923        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
 924
 925     classname = ST(0);
 926     class_stash = gv_stashsv(classname, 0);
 927     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 928     meta = HvMROMETA(class_stash);
 929
 930     if(meta->mro_which == MRO_DFS)
 931         ST(0) = sv_2mortal(newSVpvn("dfs", 3));
 932     else
 933         ST(0) = sv_2mortal(newSVpvn("c3", 2));
 934
 935     XSRETURN(1);
 936 }
 937
 938 XS(XS_mro_get_isarev)
 939 {
 940     dVAR;
 941     dXSARGS;
 942     SV* classname;
 943     HV* class_stash;
 944     HV* isarev;
 945
 946     PERL_UNUSED_ARG(cv);
 947
 948     if (items != 1)
 949        Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
 950
 951     classname = ST(0);
 952
 953     class_stash = gv_stashsv(classname, 0);
 954     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 955
 956     SP -= items;
 957
 958     if((isarev = HvMROMETA(class_stash)->mro_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
 976     PERL_UNUSED_ARG(cv);
 977
 978     if (items != 1)
 979        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
 980
 981     classname = ST(0);
 982     class_stash = gv_stashsv(classname, 0);
 983     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 984
 985     if (HvMROMETA(class_stash)->is_universal)
 986         XSRETURN_YES;
 987     else
 988         XSRETURN_NO;
 989 }
 990
 991 XS(XS_mro_get_global_sub_gen)
 992 {
 993     dVAR;
 994     dXSARGS;
 995
 996     PERL_UNUSED_ARG(cv);
 997
 998     if (items != 0)
 999         Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
1000
1001     ST(0) = sv_2mortal(newSViv(PL_sub_generation));
1002     XSRETURN(1);
1003 }
1004
1005 XS(XS_mro_invalidate_method_caches)
1006 {
1007     dVAR;
1008     dXSARGS;
1009
1010     PERL_UNUSED_ARG(cv);
1011
1012     if (items != 0)
1013         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1014
1015     PL_sub_generation++;
1016
1017     XSRETURN_EMPTY;
1018 }
1019
1020 XS(XS_mro_get_sub_generation)
1021 {
1022     dVAR;
1023     dXSARGS;
1024     SV* classname;
1025     HV* class_stash;
1026
1027     PERL_UNUSED_ARG(cv);
1028
1029     if(items != 1)
1030         Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
1031
1032     classname = ST(0);
1033     class_stash = gv_stashsv(classname, 0);
1034     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1035
1036     ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
1037     XSRETURN(1);
1038 }
1039
1040 XS(XS_mro_method_changed_in)
1041 {
1042     dVAR;
1043     dXSARGS;
1044     SV* classname;
1045     HV* class_stash;
1046
1047     PERL_UNUSED_ARG(cv);
1048
1049     if(items != 1)
1050         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1051
1052     classname = ST(0);
1053
1054     class_stash = gv_stashsv(classname, 0);
1055     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1056
1057     mro_method_changed_in(class_stash);
1058
1059     XSRETURN_EMPTY;
1060 }
1061
1062 XS(XS_next_can)
1063 {
1064     dVAR;
1065     dXSARGS;
1066     SV* self = ST(0);
1067     SV* methcv = __nextcan(aTHX_ self, 0);
1068
1069     PERL_UNUSED_ARG(cv);
1070     PERL_UNUSED_VAR(items);
1071
1072     if(methcv == &PL_sv_undef) {
1073         ST(0) = &PL_sv_undef;
1074     }
1075     else {
1076         ST(0) = sv_2mortal(newRV_inc(methcv));
1077     }
1078
1079     XSRETURN(1);
1080 }
1081
1082 XS(XS_next_method)
1083 {
1084     dMARK;
1085     dAX;
1086     SV* self = ST(0);
1087     SV* methcv = __nextcan(aTHX_ self, 1);
1088
1089     PERL_UNUSED_ARG(cv);
1090
1091     PL_markstack_ptr++;
1092     call_sv(methcv, GIMME_V);
1093 }
1094
1095 XS(XS_maybe_next_method)
1096 {
1097     dMARK;
1098     dAX;
1099     SV* self = ST(0);
1100     SV* methcv = __nextcan(aTHX_ self, 0);
1101
1102     PERL_UNUSED_ARG(cv);
1103
1104     if(methcv == &PL_sv_undef) {
1105         ST(0) = &PL_sv_undef;
1106         XSRETURN(1);
1107     }
1108
1109     PL_markstack_ptr++;
1110     call_sv(methcv, GIMME_V);
1111 }
1112
1113 /*
1114  * Local variables:
1115  * c-indentation-style: bsd
1116  * c-basic-offset: 4
1117  * indent-tabs-mode: t
1118  * End:
1119  *
1120  * ex: set ts=8 sts=4 sw=4 noet:
1121  */