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