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