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