mro.c

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