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 = stash ? HvNAME_get(stash) : NULL;
 452     const STRLEN stashname_len = stash ? HvNAMELEN_get(stash) : 0;
 453
 454     if(!stash) return;
 455
 456     if(!stashname)
 457         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
 458
 459     /* wipe out the cached linearizations for this stash */
 460     meta = HvMROMETA(stash);
 461     SvREFCNT_dec((SV*)meta->mro_linear_dfs);
 462     SvREFCNT_dec((SV*)meta->mro_linear_c3);
 463     meta->mro_linear_dfs = NULL;
 464     meta->mro_linear_c3 = NULL;
 465
 466     /* Inc the package generation, since our @ISA changed */
 467     meta->pkg_gen++;
 468
 469     /* Wipe the global method cache if this package
 470        is UNIVERSAL or one of its parents */
 471
 472     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 473     isarev = svp ? (HV*)*svp : NULL;
 474
 475     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 476         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 477         PL_sub_generation++;
 478         is_universal = TRUE;
 479     }
 480     else { /* Wipe the local method cache otherwise */
 481         meta->cache_gen++;
 482         is_universal = FALSE;
 483     }
 484
 485     /* wipe next::method cache too */
 486     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
 487
 488     /* Iterate the isarev (classes that are our children),
 489        wiping out their linearization and method caches */
 490     if(isarev) {
 491         hv_iterinit(isarev);
 492         while((iter = hv_iternext(isarev))) {
 493             SV* const revkey = hv_iterkeysv(iter);
 494             HV* revstash = gv_stashsv(revkey, 0);
 495             struct mro_meta* revmeta;
 496
 497             if(!revstash) continue;
 498             revmeta = HvMROMETA(revstash);
 499             SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
 500             SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
 501             revmeta->mro_linear_dfs = NULL;
 502             revmeta->mro_linear_c3 = NULL;
 503             if(!is_universal)
 504                 revmeta->cache_gen++;
 505             if(revmeta->mro_nextmethod)
 506                 hv_clear(revmeta->mro_nextmethod);
 507         }
 508     }
 509
 510     /* Now iterate our MRO (parents), and do a few things:
 511          1) instantiate with the "fake" flag if they don't exist
 512          2) flag them as universal if we are universal
 513          3) Add everything from our isarev to their isarev
 514     */
 515
 516     /* We're starting at the 2nd element, skipping ourselves here */
 517     linear_mro = mro_get_linear_isa(stash);
 518     svp = AvARRAY(linear_mro) + 1;
 519     items = AvFILLp(linear_mro);
 520
 521     while (items--) {
 522         SV* const sv = *svp++;
 523         HV* mroisarev;
 524
 525         HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
 526         if(!he) {
 527             he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
 528         }
 529         mroisarev = (HV*)HeVAL(he);
 530
 531         /* This hash only ever contains PL_sv_yes. Storing it over itself is
 532            almost as cheap as calling hv_exists, so on aggregate we expect to
 533            save time by not making two calls to the common HV code for the
 534            case where it doesn't exist.  */
 535
 536         hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
 537
 538         if(isarev) {
 539             hv_iterinit(isarev);
 540             while((iter = hv_iternext(isarev))) {
 541                 I32 revkeylen;
 542                 char* const revkey = hv_iterkey(iter, &revkeylen);
 543                 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
 544             }
 545         }
 546     }
 547 }
 548
 549 /*
 550 =for apidoc mro_method_changed_in
 551
 552 Invalidates method caching on any child classes
 553 of the given stash, so that they might notice
 554 the changes in this one.
 555
 556 Ideally, all instances of C<PL_sub_generation++> in
 557 perl source outside of C<mro.c> should be
 558 replaced by calls to this.
 559
 560 Perl automatically handles most of the common
 561 ways a method might be redefined.  However, there
 562 are a few ways you could change a method in a stash
 563 without the cache code noticing, in which case you
 564 need to call this method afterwards:
 565
 566 1) Directly manipulating the stash HV entries from
 567 XS code.
 568
 569 2) Assigning a reference to a readonly scalar
 570 constant into a stash entry in order to create
 571 a constant subroutine (like constant.pm
 572 does).
 573
 574 This same method is available from pure perl
 575 via, C<mro::method_changed_in(classname)>.
 576
 577 =cut
 578 */
 579 void
 580 Perl_mro_method_changed_in(pTHX_ HV *stash)
 581 {
 582     const char * const stashname = HvNAME_get(stash);
 583     const STRLEN stashname_len = HvNAMELEN_get(stash);
 584
 585     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
 586     HV * const isarev = svp ? (HV*)*svp : NULL;
 587
 588     if(!stashname)
 589         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
 590
 591     /* Inc the package generation, since a local method changed */
 592     HvMROMETA(stash)->pkg_gen++;
 593
 594     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
 595        invalidate all method caches globally */
 596     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
 597         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
 598         PL_sub_generation++;
 599         return;
 600     }
 601
 602     /* else, invalidate the method caches of all child classes,
 603        but not itself */
 604     if(isarev) {
 605         HE* iter;
 606
 607         hv_iterinit(isarev);
 608         while((iter = hv_iternext(isarev))) {
 609             SV* const revkey = hv_iterkeysv(iter);
 610             HV* const revstash = gv_stashsv(revkey, 0);
 611             struct mro_meta* mrometa;
 612
 613             if(!revstash) continue;
 614             mrometa = HvMROMETA(revstash);
 615             mrometa->cache_gen++;
 616             if(mrometa->mro_nextmethod)
 617                 hv_clear(mrometa->mro_nextmethod);
 618         }
 619     }
 620 }
 621
 622 /* These two are static helpers for next::method and friends,
 623    and re-implement a bunch of the code from pp_caller() in
 624    a more efficient manner for this particular usage.
 625 */
 626
 627 STATIC I32
 628 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 629     I32 i;
 630     for (i = startingblock; i >= 0; i--) {
 631         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 632     }
 633     return i;
 634 }
 635
 636 #include "XSUB.h"
 637
 638 XS(XS_mro_get_linear_isa);
 639 XS(XS_mro_set_mro);
 640 XS(XS_mro_get_mro);
 641 XS(XS_mro_get_isarev);
 642 XS(XS_mro_is_universal);
 643 XS(XS_mro_invalidate_method_caches);
 644 XS(XS_mro_method_changed_in);
 645 XS(XS_mro_get_pkg_gen);
 646 XS(XS_mro_nextcan);
 647
 648 void
 649 Perl_boot_core_mro(pTHX)
 650 {
 651     dVAR;
 652     static const char file[] = __FILE__;
 653
 654     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
 655     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
 656     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
 657     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
 658     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
 659     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
 660     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 661     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
 662     newXS("mro::_nextcan", XS_mro_nextcan, file);
 663 }
 664
 665 XS(XS_mro_get_linear_isa) {
 666     dVAR;
 667     dXSARGS;
 668     AV* RETVAL;
 669     HV* class_stash;
 670     SV* classname;
 671
 672     PERL_UNUSED_ARG(cv);
 673
 674     if(items < 1 || items > 2)
 675        Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
 676
 677     classname = ST(0);
 678     class_stash = gv_stashsv(classname, 0);
 679
 680     if(!class_stash) {
 681         /* No stash exists yet, give them just the classname */
 682         AV* isalin = newAV();
 683         av_push(isalin, newSVsv(classname));
 684         ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
 685         XSRETURN(1);
 686     }
 687     else if(items > 1) {
 688         const char* const which = SvPV_nolen(ST(1));
 689         if(strEQ(which, "dfs"))
 690             RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
 691         else if(strEQ(which, "c3"))
 692             RETVAL = mro_get_linear_isa_c3(class_stash, 0);
 693         else
 694             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
 695     }
 696     else {
 697         RETVAL = mro_get_linear_isa(class_stash);
 698     }
 699
 700     ST(0) = newRV_inc((SV*)RETVAL);
 701     sv_2mortal(ST(0));
 702     XSRETURN(1);
 703 }
 704
 705 XS(XS_mro_set_mro)
 706 {
 707     dVAR;
 708     dXSARGS;
 709     SV* classname;
 710     char* whichstr;
 711     mro_alg which;
 712     HV* class_stash;
 713     struct mro_meta* meta;
 714
 715     PERL_UNUSED_ARG(cv);
 716
 717     if (items != 2)
 718        Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
 719
 720     classname = ST(0);
 721     whichstr = SvPV_nolen(ST(1));
 722     class_stash = gv_stashsv(classname, GV_ADD);
 723     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 724     meta = HvMROMETA(class_stash);
 725
 726     if(strEQ(whichstr, "dfs"))
 727         which = MRO_DFS;
 728     else if(strEQ(whichstr, "c3"))
 729         which = MRO_C3;
 730     else
 731         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
 732
 733     if(meta->mro_which != which) {
 734         meta->mro_which = which;
 735         /* Only affects local method cache, not
 736            even child classes */
 737         meta->cache_gen++;
 738         if(meta->mro_nextmethod)
 739             hv_clear(meta->mro_nextmethod);
 740     }
 741
 742     XSRETURN_EMPTY;
 743 }
 744
 745
 746 XS(XS_mro_get_mro)
 747 {
 748     dVAR;
 749     dXSARGS;
 750     SV* classname;
 751     HV* class_stash;
 752
 753     PERL_UNUSED_ARG(cv);
 754
 755     if (items != 1)
 756        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
 757
 758     classname = ST(0);
 759     class_stash = gv_stashsv(classname, 0);
 760
 761     if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
 762         ST(0) = sv_2mortal(newSVpvn("dfs", 3));
 763     else
 764         ST(0) = sv_2mortal(newSVpvn("c3", 2));
 765
 766     XSRETURN(1);
 767 }
 768
 769 XS(XS_mro_get_isarev)
 770 {
 771     dVAR;
 772     dXSARGS;
 773     SV* classname;
 774     SV** svp;
 775     HV* isarev;
 776     char* classname_pv;
 777     STRLEN classname_len;
 778     AV* ret_array;
 779
 780     PERL_UNUSED_ARG(cv);
 781
 782     if (items != 1)
 783        Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
 784
 785     classname = ST(0);
 786
 787     SP -= items;
 788
 789
 790     classname_pv = SvPV_nolen(classname);
 791     classname_len = strlen(classname_pv);
 792     svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
 793     isarev = svp ? (HV*)*svp : NULL;
 794
 795     ret_array = newAV();
 796     if(isarev) {
 797         HE* iter;
 798         hv_iterinit(isarev);
 799         while((iter = hv_iternext(isarev)))
 800             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
 801     }
 802     XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
 803
 804     PUTBACK;
 805     return;
 806 }
 807
 808 XS(XS_mro_is_universal)
 809 {
 810     dVAR;
 811     dXSARGS;
 812     SV* classname;
 813     HV* isarev;
 814     char* classname_pv;
 815     STRLEN classname_len;
 816     SV** svp;
 817
 818     PERL_UNUSED_ARG(cv);
 819
 820     if (items != 1)
 821        Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
 822
 823     classname = ST(0);
 824
 825     classname_pv = SvPV_nolen(classname);
 826     classname_len = strlen(classname_pv);
 827
 828     svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
 829     isarev = svp ? (HV*)*svp : NULL;
 830
 831     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 832         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 833         XSRETURN_YES;
 834     else
 835         XSRETURN_NO;
 836 }
 837
 838 XS(XS_mro_invalidate_method_caches)
 839 {
 840     dVAR;
 841     dXSARGS;
 842
 843     PERL_UNUSED_ARG(cv);
 844
 845     if (items != 0)
 846         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
 847
 848     PL_sub_generation++;
 849
 850     XSRETURN_EMPTY;
 851 }
 852
 853 XS(XS_mro_method_changed_in)
 854 {
 855     dVAR;
 856     dXSARGS;
 857     SV* classname;
 858     HV* class_stash;
 859
 860     PERL_UNUSED_ARG(cv);
 861
 862     if(items != 1)
 863         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
 864
 865     classname = ST(0);
 866
 867     class_stash = gv_stashsv(classname, 0);
 868     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 869
 870     mro_method_changed_in(class_stash);
 871
 872     XSRETURN_EMPTY;
 873 }
 874
 875 XS(XS_mro_get_pkg_gen)
 876 {
 877     dVAR;
 878     dXSARGS;
 879     SV* classname;
 880     HV* class_stash;
 881
 882     PERL_UNUSED_ARG(cv);
 883
 884     if(items != 1)
 885         Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
 886
 887     classname = ST(0);
 888
 889     class_stash = gv_stashsv(classname, 0);
 890
 891     SP -= items;
 892
 893     XPUSHs(sv_2mortal(newSViv(
 894         class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
 895     )));
 896
 897     PUTBACK;
 898     return;
 899 }
 900
 901 XS(XS_mro_nextcan)
 902 {
 903     dVAR;
 904     dXSARGS;
 905     SV* self = ST(0);
 906     const I32 throw_nomethod = SvIVX(ST(1));
 907     register I32 cxix = cxstack_ix;
 908     register const PERL_CONTEXT *ccstack = cxstack;
 909     const PERL_SI *top_si = PL_curstackinfo;
 910     HV* selfstash;
 911     SV *stashname;
 912     const char *fq_subname;
 913     const char *subname;
 914     STRLEN stashname_len;
 915     STRLEN subname_len;
 916     SV* sv;
 917     GV** gvp;
 918     AV* linear_av;
 919     SV** linear_svp;
 920     const char *hvname;
 921     I32 entries;
 922     struct mro_meta* selfmeta;
 923     HV* nmcache;
 924     I32 i;
 925
 926     PERL_UNUSED_ARG(cv);
 927
 928     SP -= items;
 929
 930     if(sv_isobject(self))
 931         selfstash = SvSTASH(SvRV(self));
 932     else
 933         selfstash = gv_stashsv(self, 0);
 934
 935     assert(selfstash);
 936
 937     hvname = HvNAME_get(selfstash);
 938     if (!hvname)
 939         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 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 (also skips over pureperl next::method, etc) */
 944     for(i = 0; i < 2; i++) {
 945         cxix = __dopoptosub_at(ccstack, cxix);
 946         for (;;) {
 947             GV* cvgv;
 948             STRLEN fq_subname_len;
 949
 950             /* we may be in a higher stacklevel, so dig down deeper */
 951             while (cxix < 0) {
 952                 if(top_si->si_type == PERLSI_MAIN)
 953                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 954                 top_si = top_si->si_prev;
 955                 ccstack = top_si->si_cxstack;
 956                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 957             }
 958
 959             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 960               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 961                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 962                 continue;
 963             }
 964
 965             {
 966                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 967                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 968                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 969                         cxix = dbcxix;
 970                         continue;
 971                     }
 972                 }
 973             }
 974
 975             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 976
 977             if(!isGV(cvgv)) {
 978                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 979                 continue;
 980             }
 981
 982             /* we found a real sub here */
 983             sv = sv_2mortal(newSV(0));
 984
 985             gv_efullname3(sv, cvgv, NULL);
 986
 987             fq_subname = SvPVX(sv);
 988             fq_subname_len = SvCUR(sv);
 989
 990             subname = strrchr(fq_subname, ':');
 991             if(!subname)
 992                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 993
 994             subname++;
 995             subname_len = fq_subname_len - (subname - fq_subname);
 996             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 997                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 998                 continue;
 999             }
1000             break;
1001         }
1002         cxix--;
1003     }
1004
1005     /* If we made it to here, we found our context */
1006
1007     /* Initialize the next::method cache for this stash
1008        if necessary */
1009     selfmeta = HvMROMETA(selfstash);
1010     if(!(nmcache = selfmeta->mro_nextmethod)) {
1011         nmcache = selfmeta->mro_nextmethod = newHV();
1012     }
1013     else { /* Use the cached coderef if it exists */
1014         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1015         if (cache_entry) {
1016             SV* const val = HeVAL(cache_entry);
1017             if(val == &PL_sv_undef) {
1018                 if(throw_nomethod)
1019                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1020                 XSRETURN_EMPTY;
1021             }
1022             XPUSHs(sv_2mortal(newRV_inc(val)));
1023             XSRETURN(1);
1024         }
1025     }
1026
1027     /* beyond here is just for cache misses, so perf isn't as critical */
1028
1029     stashname_len = subname - fq_subname - 2;
1030     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
1031
1032     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1033
1034     linear_svp = AvARRAY(linear_av);
1035     entries = AvFILLp(linear_av) + 1;
1036
1037     /* Walk down our MRO, skipping everything up
1038        to the contextually enclosing class */
1039     while (entries--) {
1040         SV * const linear_sv = *linear_svp++;
1041         assert(linear_sv);
1042         if(sv_eq(linear_sv, stashname))
1043             break;
1044     }
1045
1046     /* Now search the remainder of the MRO for the
1047        same method name as the contextually enclosing
1048        method */
1049     if(entries > 0) {
1050         while (entries--) {
1051             SV * const linear_sv = *linear_svp++;
1052             HV* curstash;
1053             GV* candidate;
1054             CV* cand_cv;
1055
1056             assert(linear_sv);
1057             curstash = gv_stashsv(linear_sv, FALSE);
1058
1059             if (!curstash) {
1060                 if (ckWARN(WARN_SYNTAX))
1061                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1062                         (void*)linear_sv, hvname);
1063                 continue;
1064             }
1065
1066             assert(curstash);
1067
1068             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1069             if (!gvp) continue;
1070
1071             candidate = *gvp;
1072             assert(candidate);
1073
1074             if (SvTYPE(candidate) != SVt_PVGV)
1075                 gv_init(candidate, curstash, subname, subname_len, TRUE);
1076
1077             /* Notably, we only look for real entries, not method cache
1078                entries, because in C3 the method cache of a parent is not
1079                valid for the child */
1080             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1081                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1082                 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1083                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1084                 XSRETURN(1);
1085             }
1086         }
1087     }
1088
1089     hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1090     if(throw_nomethod)
1091         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1092     XSRETURN_EMPTY;
1093 }
1094
1095 /*
1096  * Local variables:
1097  * c-indentation-style: bsd
1098  * c-basic-offset: 4
1099  * indent-tabs-mode: t
1100  * End:
1101  *
1102  * ex: set ts=8 sts=4 sw=4 noet:
1103  */