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