mro.c

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