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