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