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                    The recursive call could throw an exception, which
 151                    has memory management implications here, hence the use of
 152                    the mortal.  */
 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(retval, newSVsv(subsv));
 164                 }
 165             }
 166         }
 167     }
 168
 169     /* now that we're past the exception dangers, grab our own reference to
 170        the AV we're about to use for the result. The reference owned by the
 171        mortals' stack will be released soon, so everything will balance.  */
 172     SvREFCNT_inc_simple_void_NN(retval);
 173     SvTEMP_off(retval);
 174
 175     /* we don't want anyone modifying the cache entry but us,
 176        and we do so by replacing it completely */
 177     SvREADONLY_on(retval);
 178
 179     meta->mro_linear_dfs = retval;
 180     return retval;
 181 }
 182
 183 /*
 184 =for apidoc mro_get_linear_isa_c3
 185
 186 Returns the C3 linearization of @ISA
 187 the given stash.  The return value is a read-only AV*.
 188 C<level> should be 0 (it is used internally in this
 189 function's recursion).
 190
 191 You are responsible for C<SvREFCNT_inc()> on the
 192 return value if you plan to store it anywhere
 193 semi-permanently (otherwise it might be deleted
 194 out from under you the next time the cache is
 195 invalidated).
 196
 197 =cut
 198 */
 199
 200 AV*
 201 Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
 202 {
 203     AV* retval;
 204     GV** gvp;
 205     GV* gv;
 206     AV* isa;
 207     const char* stashname;
 208     STRLEN stashname_len;
 209     struct mro_meta* meta;
 210
 211     assert(stash);
 212     assert(HvAUX(stash));
 213
 214     stashname = HvNAME_get(stash);
 215     stashname_len = HvNAMELEN_get(stash);
 216     if (!stashname)
 217       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 218
 219     if (level > 100)
 220         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 221               stashname);
 222
 223     meta = HvMROMETA(stash);
 224
 225     /* return cache if valid */
 226     if((retval = meta->mro_linear_c3)) {
 227         return retval;
 228     }
 229
 230     /* not in cache, make a new one */
 231
 232     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 233     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 234
 235     /* For a better idea how the rest of this works, see the much clearer
 236        pure perl version in Algorithm::C3 0.01:
 237        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
 238        (later versions go about it differently than this code for speed reasons)
 239     */
 240
 241     if(isa && AvFILLp(isa) >= 0) {
 242         SV** seqs_ptr;
 243         I32 seqs_items;
 244         HV* const tails = (HV*)sv_2mortal((SV*)newHV());
 245         AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
 246         I32* heads;
 247
 248         /* This builds @seqs, which is an array of arrays.
 249            The members of @seqs are the MROs of
 250            the members of @ISA, followed by @ISA itself.
 251         */
 252         I32 items = AvFILLp(isa) + 1;
 253         SV** isa_ptr = AvARRAY(isa);
 254         while(items--) {
 255             SV* const isa_item = *isa_ptr++;
 256             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
 257             if(!isa_item_stash) {
 258                 /* if no stash, make a temporary fake MRO
 259                    containing just itself */
 260                 AV* const isa_lin = newAV();
 261                 av_push(isa_lin, newSVsv(isa_item));
 262                 av_push(seqs, (SV*)isa_lin);
 263             }
 264             else {
 265                 /* recursion */
 266                 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
 267                 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
 268             }
 269         }
 270         av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
 271
 272         /* This builds "heads", which as an array of integer array
 273            indices, one per seq, which point at the virtual "head"
 274            of the seq (initially zero) */
 275         Newxz(heads, AvFILLp(seqs)+1, I32);
 276
 277         /* This builds %tails, which has one key for every class
 278            mentioned in the tail of any sequence in @seqs (tail meaning
 279            everything after the first class, the "head").  The value
 280            is how many times this key appears in the tails of @seqs.
 281         */
 282         seqs_ptr = AvARRAY(seqs);
 283         seqs_items = AvFILLp(seqs) + 1;
 284         while(seqs_items--) {
 285             AV* const seq = (AV*)*seqs_ptr++;
 286             I32 seq_items = AvFILLp(seq);
 287             if(seq_items > 0) {
 288                 SV** seq_ptr = AvARRAY(seq) + 1;
 289                 while(seq_items--) {
 290                     SV* const seqitem = *seq_ptr++;
 291                     HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
 292                     if(!he) {
 293                         hv_store_ent(tails, seqitem, newSViv(1), 0);
 294                     }
 295                     else {
 296                         SV* const val = HeVAL(he);
 297                         sv_inc(val);
 298                     }
 299                 }
 300             }
 301         }
 302
 303         /* Initialize retval to build the return value in */
 304         retval = newAV();
 305         av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
 306
 307         /* This loop won't terminate until we either finish building
 308            the MRO, or get an exception. */
 309         while(1) {
 310             SV* cand = NULL;
 311             SV* winner = NULL;
 312             int s;
 313
 314             /* "foreach $seq (@seqs)" */
 315             SV** const avptr = AvARRAY(seqs);
 316             for(s = 0; s <= AvFILLp(seqs); s++) {
 317                 SV** svp;
 318                 AV * const seq = (AV*)(avptr[s]);
 319                 SV* seqhead;
 320                 if(!seq) continue; /* skip empty seqs */
 321                 svp = av_fetch(seq, heads[s], 0);
 322                 seqhead = *svp; /* seqhead = head of this seq */
 323                 if(!winner) {
 324                     HE* tail_entry;
 325                     SV* val;
 326                     /* if we haven't found a winner for this round yet,
 327                        and this seqhead is not in tails (or the count
 328                        for it in tails has dropped to zero), then this
 329                        seqhead is our new winner, and is added to the
 330                        final MRO immediately */
 331                     cand = seqhead;
 332                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
 333                        && (val = HeVAL(tail_entry))
 334                        && (SvIVX(val) > 0))
 335                            continue;
 336                     winner = newSVsv(cand);
 337                     av_push(retval, winner);
 338                     /* note however that even when we find a winner,
 339                        we continue looping over @seqs to do housekeeping */
 340                 }
 341                 if(!sv_cmp(seqhead, winner)) {
 342                     /* Once we have a winner (including the iteration
 343                        where we first found him), inc the head ptr
 344                        for any seq which had the winner as a head,
 345                        NULL out any seq which is now empty,
 346                        and adjust tails for consistency */
 347
 348                     const int new_head = ++heads[s];
 349                     if(new_head > AvFILLp(seq)) {
 350                         SvREFCNT_dec(avptr[s]);
 351                         avptr[s] = NULL;
 352                     }
 353                     else {
 354                         HE* tail_entry;
 355                         SV* val;
 356                         /* Because we know this new seqhead used to be
 357                            a tail, we can assume it is in tails and has
 358                            a positive value, which we need to dec */
 359                         svp = av_fetch(seq, new_head, 0);
 360                         seqhead = *svp;
 361                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
 362                         val = HeVAL(tail_entry);
 363                         sv_dec(val);
 364                     }
 365                 }
 366             }
 367
 368             /* if we found no candidates, we are done building the MRO.
 369                !cand means no seqs have any entries left to check */
 370             if(!cand) {
 371                 Safefree(heads);
 372                 break;
 373             }
 374
 375             /* If we had candidates, but nobody won, then the @ISA
 376                hierarchy is not C3-incompatible */
 377             if(!winner) {
 378                 /* we have to do some cleanup before we croak */
 379
 380                 SvREFCNT_dec(retval);
 381                 Safefree(heads);
 382
 383                 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
 384                     "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
 385             }
 386         }
 387     }
 388     else { /* @ISA was undefined or empty */
 389         /* build a retval containing only ourselves */
 390         retval = newAV();
 391         av_push(retval, newSVpvn(stashname, stashname_len));
 392     }
 393
 394     /* we don't want anyone modifying the cache entry but us,
 395        and we do so by replacing it completely */
 396     SvREADONLY_on(retval);
 397
 398     meta->mro_linear_c3 = retval;
 399     return retval;
 400 }
 401
 402 /*
 403 =for apidoc mro_get_linear_isa
 404
 405 Returns either C<mro_get_linear_isa_c3> or
 406 C<mro_get_linear_isa_dfs> for the given stash,
 407 dependant upon which MRO is in effect
 408 for that stash.  The return value is a
 409 read-only AV*.
 410
 411 You are responsible for C<SvREFCNT_inc()> on the
 412 return value if you plan to store it anywhere
 413 semi-permanently (otherwise it might be deleted
 414 out from under you the next time the cache is
 415 invalidated).
 416
 417 =cut
 418 */
 419 AV*
 420 Perl_mro_get_linear_isa(pTHX_ HV *stash)
 421 {
 422     struct mro_meta* meta;
 423
 424     assert(stash);
 425     if(!SvOOK(stash))
 426         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
 427
 428     meta = HvMROMETA(stash);
 429     if(meta->mro_which == MRO_DFS) {
 430         return mro_get_linear_isa_dfs(stash, 0);
 431     } else if(meta->mro_which == MRO_C3) {
 432         return mro_get_linear_isa_c3(stash, 0);
 433     } else {
 434         Perl_croak(aTHX_ "panic: invalid MRO!");
 435     }
 436     return NULL; /* NOT REACHED */
 437 }
 438
 439 /*
 440 =for apidoc mro_isa_changed_in
 441
 442 Takes the necessary steps (cache invalidations, mostly)
 443 when the @ISA of the given package has changed.  Invoked
 444 by the C<setisa> magic, should not need to invoke directly.
 445
 446 =cut
 447 */
 448 void
 449 Perl_mro_isa_changed_in(pTHX_ HV* stash)
 450 {
 451     dVAR;
 452     HV* isarev;
 453     AV* linear_mro;
 454     HE* iter;
 455     SV** svp;
 456     I32 items;
 457     bool is_universal;
 458     struct mro_meta * meta;
 459
 460     const char * const stashname = HvNAME_get(stash);
 461     const STRLEN stashname_len = HvNAMELEN_get(stash);
 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  */