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     if (meta->isa) {
 550         SvREFCNT_dec(meta->isa);
 551         meta->isa = NULL;
 552     }
 553
 554     /* Inc the package generation, since our @ISA changed */
 555     meta->pkg_gen++;
 556
 557     /* Wipe the global method cache if this package
 558        is UNIVERSAL or one of its parents */
 559
 560     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 561     isarev = svp ? (HV*)*svp : NULL;
 562
 563     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 564         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 565         PL_sub_generation++;
 566         is_universal = TRUE;
 567     }
 568     else { /* Wipe the local method cache otherwise */
 569         meta->cache_gen++;
 570         is_universal = FALSE;
 571     }
 572
 573     /* wipe next::method cache too */
 574     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
 575
 576     /* Iterate the isarev (classes that are our children),
 577        wiping out their linearization and method caches */
 578     if(isarev) {
 579         hv_iterinit(isarev);
 580         while((iter = hv_iternext(isarev))) {
 581             I32 len;
 582             const char* const revkey = hv_iterkey(iter, &len);
 583             HV* revstash = gv_stashpvn(revkey, len, 0);
 584             struct mro_meta* revmeta;
 585
 586             if(!revstash) continue;
 587             revmeta = HvMROMETA(revstash);
 588             SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
 589             SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
 590             revmeta->mro_linear_dfs = NULL;
 591             revmeta->mro_linear_c3 = NULL;
 592             if(!is_universal)
 593                 revmeta->cache_gen++;
 594             if(revmeta->mro_nextmethod)
 595                 hv_clear(revmeta->mro_nextmethod);
 596         }
 597     }
 598
 599     /* Now iterate our MRO (parents), and do a few things:
 600          1) instantiate with the "fake" flag if they don't exist
 601          2) flag them as universal if we are universal
 602          3) Add everything from our isarev to their isarev
 603     */
 604
 605     /* We're starting at the 2nd element, skipping ourselves here */
 606     linear_mro = mro_get_linear_isa(stash);
 607     svp = AvARRAY(linear_mro) + 1;
 608     items = AvFILLp(linear_mro);
 609
 610     while (items--) {
 611         SV* const sv = *svp++;
 612         HV* mroisarev;
 613
 614         HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
 615
 616         /* That fetch should not fail.  But if it had to create a new SV for
 617            us, then will need to upgrade it to an HV (which sv_upgrade() can
 618            now do for us. */
 619
 620         mroisarev = (HV*)HeVAL(he);
 621
 622         SvUPGRADE((SV*)mroisarev, SVt_PVHV);
 623
 624         /* This hash only ever contains PL_sv_yes. Storing it over itself is
 625            almost as cheap as calling hv_exists, so on aggregate we expect to
 626            save time by not making two calls to the common HV code for the
 627            case where it doesn't exist.  */
 628
 629         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
 630
 631         if(isarev) {
 632             hv_iterinit(isarev);
 633             while((iter = hv_iternext(isarev))) {
 634                 I32 revkeylen;
 635                 char* const revkey = hv_iterkey(iter, &revkeylen);
 636                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
 637             }
 638         }
 639     }
 640 }
 641
 642 /*
 643 =for apidoc mro_method_changed_in
 644
 645 Invalidates method caching on any child classes
 646 of the given stash, so that they might notice
 647 the changes in this one.
 648
 649 Ideally, all instances of C<PL_sub_generation++> in
 650 perl source outside of C<mro.c> should be
 651 replaced by calls to this.
 652
 653 Perl automatically handles most of the common
 654 ways a method might be redefined.  However, there
 655 are a few ways you could change a method in a stash
 656 without the cache code noticing, in which case you
 657 need to call this method afterwards:
 658
 659 1) Directly manipulating the stash HV entries from
 660 XS code.
 661
 662 2) Assigning a reference to a readonly scalar
 663 constant into a stash entry in order to create
 664 a constant subroutine (like constant.pm
 665 does).
 666
 667 This same method is available from pure perl
 668 via, C<mro::method_changed_in(classname)>.
 669
 670 =cut
 671 */
 672 void
 673 Perl_mro_method_changed_in(pTHX_ HV *stash)
 674 {
 675     const char * const stashname = HvNAME_get(stash);
 676     const STRLEN stashname_len = HvNAMELEN_get(stash);
 677
 678     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 679     HV * const isarev = svp ? (HV*)*svp : NULL;
 680
 681     PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
 682
 683     if(!stashname)
 684         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
 685
 686     /* Inc the package generation, since a local method changed */
 687     HvMROMETA(stash)->pkg_gen++;
 688
 689     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
 690        invalidate all method caches globally */
 691     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 692         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 693         PL_sub_generation++;
 694         return;
 695     }
 696
 697     /* else, invalidate the method caches of all child classes,
 698        but not itself */
 699     if(isarev) {
 700         HE* iter;
 701
 702         hv_iterinit(isarev);
 703         while((iter = hv_iternext(isarev))) {
 704             I32 len;
 705             const char* const revkey = hv_iterkey(iter, &len);
 706             HV* const revstash = gv_stashpvn(revkey, len, 0);
 707             struct mro_meta* mrometa;
 708
 709             if(!revstash) continue;
 710             mrometa = HvMROMETA(revstash);
 711             mrometa->cache_gen++;
 712             if(mrometa->mro_nextmethod)
 713                 hv_clear(mrometa->mro_nextmethod);
 714         }
 715     }
 716 }
 717
 718 /* These two are static helpers for next::method and friends,
 719    and re-implement a bunch of the code from pp_caller() in
 720    a more efficient manner for this particular usage.
 721 */
 722
 723 STATIC I32
 724 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 725     I32 i;
 726     for (i = startingblock; i >= 0; i--) {
 727         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 728     }
 729     return i;
 730 }
 731
 732 #include "XSUB.h"
 733
 734 XS(XS_mro_get_linear_isa);
 735 XS(XS_mro_set_mro);
 736 XS(XS_mro_get_mro);
 737 XS(XS_mro_get_isarev);
 738 XS(XS_mro_is_universal);
 739 XS(XS_mro_invalidate_method_caches);
 740 XS(XS_mro_method_changed_in);
 741 XS(XS_mro_get_pkg_gen);
 742 XS(XS_mro_nextcan);
 743
 744 void
 745 Perl_boot_core_mro(pTHX)
 746 {
 747     dVAR;
 748     static const char file[] = __FILE__;
 749
 750     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
 751     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
 752     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
 753     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
 754     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
 755     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
 756     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 757     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
 758     newXS("mro::_nextcan", XS_mro_nextcan, file);
 759 }
 760
 761 XS(XS_mro_get_linear_isa) {
 762     dVAR;
 763     dXSARGS;
 764     AV* RETVAL;
 765     HV* class_stash;
 766     SV* classname;
 767
 768     if(items < 1 || items > 2)
 769         croak_xs_usage(cv, "classname [, type ]");
 770
 771     classname = ST(0);
 772     class_stash = gv_stashsv(classname, 0);
 773
 774     if(!class_stash) {
 775         /* No stash exists yet, give them just the classname */
 776         AV* isalin = newAV();
 777         av_push(isalin, newSVsv(classname));
 778         ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
 779         XSRETURN(1);
 780     }
 781     else if(items > 1) {
 782         const char* const which = SvPV_nolen(ST(1));
 783         const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
 784         if (!algo)
 785             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
 786         RETVAL = algo->resolve(aTHX_ class_stash, 0);
 787     }
 788     else {
 789         RETVAL = mro_get_linear_isa(class_stash);
 790     }
 791
 792     ST(0) = newRV_inc((SV*)RETVAL);
 793     sv_2mortal(ST(0));
 794     XSRETURN(1);
 795 }
 796
 797 XS(XS_mro_set_mro)
 798 {
 799     dVAR;
 800     dXSARGS;
 801     SV* classname;
 802     const char* whichstr;
 803     const struct mro_alg *which;
 804     HV* class_stash;
 805     struct mro_meta* meta;
 806
 807     if (items != 2)
 808         croak_xs_usage(cv, "classname, type");
 809
 810     classname = ST(0);
 811     whichstr = SvPV_nolen(ST(1));
 812     class_stash = gv_stashsv(classname, GV_ADD);
 813     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 814     meta = HvMROMETA(class_stash);
 815
 816     which = S_get_mro_from_name(aTHX_ whichstr);
 817     if (!which)
 818         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
 819
 820     if(meta->mro_which != which) {
 821         meta->mro_which = which;
 822         /* Only affects local method cache, not
 823            even child classes */
 824         meta->cache_gen++;
 825         if(meta->mro_nextmethod)
 826             hv_clear(meta->mro_nextmethod);
 827     }
 828
 829     XSRETURN_EMPTY;
 830 }
 831
 832
 833 XS(XS_mro_get_mro)
 834 {
 835     dVAR;
 836     dXSARGS;
 837     SV* classname;
 838     HV* class_stash;
 839
 840     if (items != 1)
 841         croak_xs_usage(cv, "classname");
 842
 843     classname = ST(0);
 844     class_stash = gv_stashsv(classname, 0);
 845
 846     ST(0) = sv_2mortal(newSVpv(class_stash
 847                                ? HvMROMETA(class_stash)->mro_which->name
 848                                : "dfs", 0));
 849     XSRETURN(1);
 850 }
 851
 852 XS(XS_mro_get_isarev)
 853 {
 854     dVAR;
 855     dXSARGS;
 856     SV* classname;
 857     HE* he;
 858     HV* isarev;
 859     AV* ret_array;
 860
 861     if (items != 1)
 862         croak_xs_usage(cv, "classname");
 863
 864     classname = ST(0);
 865
 866     SP -= items;
 867
 868
 869     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 870     isarev = he ? (HV*)HeVAL(he) : NULL;
 871
 872     ret_array = newAV();
 873     if(isarev) {
 874         HE* iter;
 875         hv_iterinit(isarev);
 876         while((iter = hv_iternext(isarev)))
 877             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
 878     }
 879     mXPUSHs(newRV_noinc((SV*)ret_array));
 880
 881     PUTBACK;
 882     return;
 883 }
 884
 885 XS(XS_mro_is_universal)
 886 {
 887     dVAR;
 888     dXSARGS;
 889     SV* classname;
 890     HV* isarev;
 891     char* classname_pv;
 892     STRLEN classname_len;
 893     HE* he;
 894
 895     if (items != 1)
 896         croak_xs_usage(cv, "classname");
 897
 898     classname = ST(0);
 899
 900     classname_pv = SvPV(classname,classname_len);
 901
 902     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 903     isarev = he ? (HV*)HeVAL(he) : NULL;
 904
 905     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 906         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 907         XSRETURN_YES;
 908     else
 909         XSRETURN_NO;
 910 }
 911
 912 XS(XS_mro_invalidate_method_caches)
 913 {
 914     dVAR;
 915     dXSARGS;
 916
 917     if (items != 0)
 918         croak_xs_usage(cv, "");
 919
 920     PL_sub_generation++;
 921
 922     XSRETURN_EMPTY;
 923 }
 924
 925 XS(XS_mro_method_changed_in)
 926 {
 927     dVAR;
 928     dXSARGS;
 929     SV* classname;
 930     HV* class_stash;
 931
 932     if(items != 1)
 933         croak_xs_usage(cv, "classname");
 934
 935     classname = ST(0);
 936
 937     class_stash = gv_stashsv(classname, 0);
 938     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 939
 940     mro_method_changed_in(class_stash);
 941
 942     XSRETURN_EMPTY;
 943 }
 944
 945 XS(XS_mro_get_pkg_gen)
 946 {
 947     dVAR;
 948     dXSARGS;
 949     SV* classname;
 950     HV* class_stash;
 951
 952     if(items != 1)
 953         croak_xs_usage(cv, "classname");
 954
 955     classname = ST(0);
 956
 957     class_stash = gv_stashsv(classname, 0);
 958
 959     SP -= items;
 960
 961     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
 962
 963     PUTBACK;
 964     return;
 965 }
 966
 967 XS(XS_mro_nextcan)
 968 {
 969     dVAR;
 970     dXSARGS;
 971     SV* self = ST(0);
 972     const I32 throw_nomethod = SvIVX(ST(1));
 973     register I32 cxix = cxstack_ix;
 974     register const PERL_CONTEXT *ccstack = cxstack;
 975     const PERL_SI *top_si = PL_curstackinfo;
 976     HV* selfstash;
 977     SV *stashname;
 978     const char *fq_subname;
 979     const char *subname;
 980     STRLEN stashname_len;
 981     STRLEN subname_len;
 982     SV* sv;
 983     GV** gvp;
 984     AV* linear_av;
 985     SV** linear_svp;
 986     const char *hvname;
 987     I32 entries;
 988     struct mro_meta* selfmeta;
 989     HV* nmcache;
 990     I32 i;
 991
 992     PERL_UNUSED_ARG(cv);
 993
 994     SP -= items;
 995
 996     if(sv_isobject(self))
 997         selfstash = SvSTASH(SvRV(self));
 998     else
 999         selfstash = gv_stashsv(self, GV_ADD);
1000
1001     assert(selfstash);
1002
1003     hvname = HvNAME_get(selfstash);
1004     if (!hvname)
1005         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
1006
1007     /* This block finds the contextually-enclosing fully-qualified subname,
1008        much like looking at (caller($i))[3] until you find a real sub that
1009        isn't ANON, etc (also skips over pureperl next::method, etc) */
1010     for(i = 0; i < 2; i++) {
1011         cxix = __dopoptosub_at(ccstack, cxix);
1012         for (;;) {
1013             GV* cvgv;
1014             STRLEN fq_subname_len;
1015
1016             /* we may be in a higher stacklevel, so dig down deeper */
1017             while (cxix < 0) {
1018                 if(top_si->si_type == PERLSI_MAIN)
1019                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
1020                 top_si = top_si->si_prev;
1021                 ccstack = top_si->si_cxstack;
1022                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
1023             }
1024
1025             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
1026               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
1027                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1028                 continue;
1029             }
1030
1031             {
1032                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
1033                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
1034                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1035                         cxix = dbcxix;
1036                         continue;
1037                     }
1038                 }
1039             }
1040
1041             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1042
1043             if(!isGV(cvgv)) {
1044                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1045                 continue;
1046             }
1047
1048             /* we found a real sub here */
1049             sv = sv_2mortal(newSV(0));
1050
1051             gv_efullname3(sv, cvgv, NULL);
1052
1053             fq_subname = SvPVX(sv);
1054             fq_subname_len = SvCUR(sv);
1055
1056             subname = strrchr(fq_subname, ':');
1057             if(!subname)
1058                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1059
1060             subname++;
1061             subname_len = fq_subname_len - (subname - fq_subname);
1062             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1063                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1064                 continue;
1065             }
1066             break;
1067         }
1068         cxix--;
1069     }
1070
1071     /* If we made it to here, we found our context */
1072
1073     /* Initialize the next::method cache for this stash
1074        if necessary */
1075     selfmeta = HvMROMETA(selfstash);
1076     if(!(nmcache = selfmeta->mro_nextmethod)) {
1077         nmcache = selfmeta->mro_nextmethod = newHV();
1078     }
1079     else { /* Use the cached coderef if it exists */
1080         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1081         if (cache_entry) {
1082             SV* const val = HeVAL(cache_entry);
1083             if(val == &PL_sv_undef) {
1084                 if(throw_nomethod)
1085                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1086                 XSRETURN_EMPTY;
1087             }
1088             mXPUSHs(newRV_inc(val));
1089             XSRETURN(1);
1090         }
1091     }
1092
1093     /* beyond here is just for cache misses, so perf isn't as critical */
1094
1095     stashname_len = subname - fq_subname - 2;
1096     stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1097
1098     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1099
1100     linear_svp = AvARRAY(linear_av);
1101     entries = AvFILLp(linear_av) + 1;
1102
1103     /* Walk down our MRO, skipping everything up
1104        to the contextually enclosing class */
1105     while (entries--) {
1106         SV * const linear_sv = *linear_svp++;
1107         assert(linear_sv);
1108         if(sv_eq(linear_sv, stashname))
1109             break;
1110     }
1111
1112     /* Now search the remainder of the MRO for the
1113        same method name as the contextually enclosing
1114        method */
1115     if(entries > 0) {
1116         while (entries--) {
1117             SV * const linear_sv = *linear_svp++;
1118             HV* curstash;
1119             GV* candidate;
1120             CV* cand_cv;
1121
1122             assert(linear_sv);
1123             curstash = gv_stashsv(linear_sv, FALSE);
1124
1125             if (!curstash) {
1126                 if (ckWARN(WARN_SYNTAX))
1127                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1128                         (void*)linear_sv, hvname);
1129                 continue;
1130             }
1131
1132             assert(curstash);
1133
1134             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1135             if (!gvp) continue;
1136
1137             candidate = *gvp;
1138             assert(candidate);
1139
1140             if (SvTYPE(candidate) != SVt_PVGV)
1141                 gv_init(candidate, curstash, subname, subname_len, TRUE);
1142
1143             /* Notably, we only look for real entries, not method cache
1144                entries, because in C3 the method cache of a parent is not
1145                valid for the child */
1146             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1147                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1148                 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1149                 mXPUSHs(newRV_inc((SV*)cand_cv));
1150                 XSRETURN(1);
1151             }
1152         }
1153     }
1154
1155     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1156     if(throw_nomethod)
1157         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1158     XSRETURN_EMPTY;
1159 }
1160
1161 /*
1162  * Local variables:
1163  * c-indentation-style: bsd
1164  * c-basic-offset: 4
1165  * indent-tabs-mode: t
1166  * End:
1167  *
1168  * ex: set ts=8 sts=4 sw=4 noet:
1169  */