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