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