mro.c

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