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