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 = 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         RETVAL = 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(classname,classname_len);
 844
 845     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 846     isarev = he ? (HV*)HeVAL(he) : NULL;
 847
 848     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 849         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 850         XSRETURN_YES;
 851     else
 852         XSRETURN_NO;
 853 }
 854
 855 XS(XS_mro_invalidate_method_caches)
 856 {
 857     dVAR;
 858     dXSARGS;
 859
 860     PERL_UNUSED_ARG(cv);
 861
 862     if (items != 0)
 863         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
 864
 865     PL_sub_generation++;
 866
 867     XSRETURN_EMPTY;
 868 }
 869
 870 XS(XS_mro_method_changed_in)
 871 {
 872     dVAR;
 873     dXSARGS;
 874     SV* classname;
 875     HV* class_stash;
 876
 877     PERL_UNUSED_ARG(cv);
 878
 879     if(items != 1)
 880         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
 881
 882     classname = ST(0);
 883
 884     class_stash = gv_stashsv(classname, 0);
 885     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 886
 887     mro_method_changed_in(class_stash);
 888
 889     XSRETURN_EMPTY;
 890 }
 891
 892 XS(XS_mro_get_pkg_gen)
 893 {
 894     dVAR;
 895     dXSARGS;
 896     SV* classname;
 897     HV* class_stash;
 898
 899     PERL_UNUSED_ARG(cv);
 900
 901     if(items != 1)
 902         Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
 903
 904     classname = ST(0);
 905
 906     class_stash = gv_stashsv(classname, 0);
 907
 908     SP -= items;
 909
 910     XPUSHs(sv_2mortal(newSViv(
 911         class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
 912     )));
 913
 914     PUTBACK;
 915     return;
 916 }
 917
 918 XS(XS_mro_nextcan)
 919 {
 920     dVAR;
 921     dXSARGS;
 922     SV* self = ST(0);
 923     const I32 throw_nomethod = SvIVX(ST(1));
 924     register I32 cxix = cxstack_ix;
 925     register const PERL_CONTEXT *ccstack = cxstack;
 926     const PERL_SI *top_si = PL_curstackinfo;
 927     HV* selfstash;
 928     SV *stashname;
 929     const char *fq_subname;
 930     const char *subname;
 931     STRLEN stashname_len;
 932     STRLEN subname_len;
 933     SV* sv;
 934     GV** gvp;
 935     AV* linear_av;
 936     SV** linear_svp;
 937     const char *hvname;
 938     I32 entries;
 939     struct mro_meta* selfmeta;
 940     HV* nmcache;
 941     I32 i;
 942
 943     PERL_UNUSED_ARG(cv);
 944
 945     SP -= items;
 946
 947     if(sv_isobject(self))
 948         selfstash = SvSTASH(SvRV(self));
 949     else
 950         selfstash = gv_stashsv(self, 0);
 951
 952     assert(selfstash);
 953
 954     hvname = HvNAME_get(selfstash);
 955     if (!hvname)
 956         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 957
 958     /* This block finds the contextually-enclosing fully-qualified subname,
 959        much like looking at (caller($i))[3] until you find a real sub that
 960        isn't ANON, etc (also skips over pureperl next::method, etc) */
 961     for(i = 0; i < 2; i++) {
 962         cxix = __dopoptosub_at(ccstack, cxix);
 963         for (;;) {
 964             GV* cvgv;
 965             STRLEN fq_subname_len;
 966
 967             /* we may be in a higher stacklevel, so dig down deeper */
 968             while (cxix < 0) {
 969                 if(top_si->si_type == PERLSI_MAIN)
 970                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 971                 top_si = top_si->si_prev;
 972                 ccstack = top_si->si_cxstack;
 973                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 974             }
 975
 976             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 977               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 978                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 979                 continue;
 980             }
 981
 982             {
 983                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 984                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 985                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 986                         cxix = dbcxix;
 987                         continue;
 988                     }
 989                 }
 990             }
 991
 992             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 993
 994             if(!isGV(cvgv)) {
 995                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 996                 continue;
 997             }
 998
 999             /* we found a real sub here */
1000             sv = sv_2mortal(newSV(0));
1001
1002             gv_efullname3(sv, cvgv, NULL);
1003
1004             fq_subname = SvPVX(sv);
1005             fq_subname_len = SvCUR(sv);
1006
1007             subname = strrchr(fq_subname, ':');
1008             if(!subname)
1009                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1010
1011             subname++;
1012             subname_len = fq_subname_len - (subname - fq_subname);
1013             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1014                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1015                 continue;
1016             }
1017             break;
1018         }
1019         cxix--;
1020     }
1021
1022     /* If we made it to here, we found our context */
1023
1024     /* Initialize the next::method cache for this stash
1025        if necessary */
1026     selfmeta = HvMROMETA(selfstash);
1027     if(!(nmcache = selfmeta->mro_nextmethod)) {
1028         nmcache = selfmeta->mro_nextmethod = newHV();
1029     }
1030     else { /* Use the cached coderef if it exists */
1031         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1032         if (cache_entry) {
1033             SV* const val = HeVAL(cache_entry);
1034             if(val == &PL_sv_undef) {
1035                 if(throw_nomethod)
1036                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1037                 XSRETURN_EMPTY;
1038             }
1039             XPUSHs(sv_2mortal(newRV_inc(val)));
1040             XSRETURN(1);
1041         }
1042     }
1043
1044     /* beyond here is just for cache misses, so perf isn't as critical */
1045
1046     stashname_len = subname - fq_subname - 2;
1047     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
1048
1049     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1050
1051     linear_svp = AvARRAY(linear_av);
1052     entries = AvFILLp(linear_av) + 1;
1053
1054     /* Walk down our MRO, skipping everything up
1055        to the contextually enclosing class */
1056     while (entries--) {
1057         SV * const linear_sv = *linear_svp++;
1058         assert(linear_sv);
1059         if(sv_eq(linear_sv, stashname))
1060             break;
1061     }
1062
1063     /* Now search the remainder of the MRO for the
1064        same method name as the contextually enclosing
1065        method */
1066     if(entries > 0) {
1067         while (entries--) {
1068             SV * const linear_sv = *linear_svp++;
1069             HV* curstash;
1070             GV* candidate;
1071             CV* cand_cv;
1072
1073             assert(linear_sv);
1074             curstash = gv_stashsv(linear_sv, FALSE);
1075
1076             if (!curstash) {
1077                 if (ckWARN(WARN_SYNTAX))
1078                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1079                         (void*)linear_sv, hvname);
1080                 continue;
1081             }
1082
1083             assert(curstash);
1084
1085             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1086             if (!gvp) continue;
1087
1088             candidate = *gvp;
1089             assert(candidate);
1090
1091             if (SvTYPE(candidate) != SVt_PVGV)
1092                 gv_init(candidate, curstash, subname, subname_len, TRUE);
1093
1094             /* Notably, we only look for real entries, not method cache
1095                entries, because in C3 the method cache of a parent is not
1096                valid for the child */
1097             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1098                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1099                 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1100                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1101                 XSRETURN(1);
1102             }
1103         }
1104     }
1105
1106     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1107     if(throw_nomethod)
1108         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1109     XSRETURN_EMPTY;
1110 }
1111
1112 /*
1113  * Local variables:
1114  * c-indentation-style: bsd
1115  * c-basic-offset: 4
1116  * indent-tabs-mode: t
1117  * End:
1118  *
1119  * ex: set ts=8 sts=4 sw=4 noet:
1120  */