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