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