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