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