mro.c

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