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