mro.c

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