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     SV** svp;
 106     I32 items;
 107     AV* subrv;
 108     SV** subrv_p;
 109     I32 subrv_items;
 110     const char* stashname;
 111     struct mro_meta* meta;
 112
 113     assert(stash);
 114     assert(HvAUX(stash));
 115
 116     stashname = HvNAME_get(stash);
 117     if (!stashname)
 118       Perl_croak(aTHX_
 119                  "Can't linearize anonymous symbol table");
 120
 121     if (level > 100)
 122         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 123               stashname);
 124
 125     meta = HvMROMETA(stash);
 126
 127     /* return cache if valid */
 128     if((retval = meta->mro_linear_dfs)) {
 129         return retval;
 130     }
 131
 132     /* not in cache, make a new one */
 133
 134     retval = newAV();
 135     av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
 136
 137     /* fetch our @ISA */
 138     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 139     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 140
 141     if(av) {
 142
 143         /* "stored" is used to keep track of all of the classnames
 144            we have added to the MRO so far, so we can do a quick
 145            exists check and avoid adding duplicate classnames to
 146            the MRO as we go. */
 147
 148         HV* stored = (HV*)sv_2mortal((SV*)newHV());
 149         svp = AvARRAY(av);
 150         items = AvFILLp(av) + 1;
 151
 152         /* foreach(@ISA) */
 153         while (items--) {
 154             SV* const sv = *svp++;
 155             HV* const basestash = gv_stashsv(sv, 0);
 156
 157             if (!basestash) {
 158                 /* if no stash exists for this @ISA member,
 159                    simply add it to the MRO and move on */
 160                 if(!hv_exists_ent(stored, sv, 0)) {
 161                     av_push(retval, newSVsv(sv));
 162                     hv_store_ent(stored, sv, &PL_sv_undef, 0);
 163                 }
 164             }
 165             else {
 166                 /* otherwise, recurse into ourselves for the MRO
 167                    of this @ISA member, and append their MRO to ours */
 168                 subrv = mro_get_linear_isa_dfs(basestash, level + 1);
 169                 subrv_p = AvARRAY(subrv);
 170                 subrv_items = AvFILLp(subrv) + 1;
 171                 while(subrv_items--) {
 172                     SV* subsv = *subrv_p++;
 173                     if(!hv_exists_ent(stored, subsv, 0)) {
 174                         av_push(retval, newSVsv(subsv));
 175                         hv_store_ent(stored, subsv, &PL_sv_undef, 0);
 176                     }
 177                 }
 178             }
 179         }
 180     }
 181
 182     /* we don't want anyone modifying the cache entry but us,
 183        and we do so by replacing it completely */
 184     SvREADONLY_on(retval);
 185
 186     meta->mro_linear_dfs = retval;
 187     return retval;
 188 }
 189
 190 /*
 191 =for apidoc mro_get_linear_isa_c3
 192
 193 Returns the C3 linearization of @ISA
 194 the given stash.  The return value is a read-only AV*.
 195 C<level> should be 0 (it is used internally in this
 196 function's recursion).
 197
 198 You are responsible for C<SvREFCNT_inc()> on the
 199 return value if you plan to store it anywhere
 200 semi-permanently (otherwise it might be deleted
 201 out from under you the next time the cache is
 202 invalidated).
 203
 204 =cut
 205 */
 206
 207 AV*
 208 Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
 209 {
 210     AV* retval;
 211     GV** gvp;
 212     GV* gv;
 213     AV* isa;
 214     const char* stashname;
 215     STRLEN stashname_len;
 216     struct mro_meta* meta;
 217
 218     assert(stash);
 219     assert(HvAUX(stash));
 220
 221     stashname = HvNAME_get(stash);
 222     stashname_len = HvNAMELEN_get(stash);
 223     if (!stashname)
 224       Perl_croak(aTHX_
 225                  "Can't linearize anonymous symbol table");
 226
 227     if (level > 100)
 228         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
 229               stashname);
 230
 231     meta = HvMROMETA(stash);
 232
 233     /* return cache if valid */
 234     if((retval = meta->mro_linear_c3)) {
 235         return retval;
 236     }
 237
 238     /* not in cache, make a new one */
 239
 240     retval = newAV();
 241     av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
 242
 243     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
 244     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
 245
 246     /* For a better idea how the rest of this works, see the much clearer
 247        pure perl version in Algorithm::C3 0.01:
 248        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
 249        (later versions go about it differently than this code for speed reasons)
 250     */
 251     if(isa && AvFILLp(isa) >= 0) {
 252         SV** seqs_ptr;
 253         I32 seqs_items;
 254         HV* tails = (HV*)sv_2mortal((SV*)newHV());
 255         AV* seqs = (AV*)sv_2mortal((SV*)newAV());
 256         I32 items = AvFILLp(isa) + 1;
 257         SV** isa_ptr = AvARRAY(isa);
 258         while(items--) {
 259             AV* isa_lin;
 260             SV* isa_item = *isa_ptr++;
 261             HV* isa_item_stash = gv_stashsv(isa_item, 0);
 262             if(!isa_item_stash) {
 263                 isa_lin = newAV();
 264                 av_push(isa_lin, newSVsv(isa_item));
 265             }
 266             else {
 267                 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
 268             }
 269             av_push(seqs, (SV*)av_make(AvFILLp(isa_lin)+1, AvARRAY(isa_lin)));
 270         }
 271         av_push(seqs, (SV*)av_make(AvFILLp(isa)+1, AvARRAY(isa)));
 272
 273         seqs_ptr = AvARRAY(seqs);
 274         seqs_items = AvFILLp(seqs) + 1;
 275         while(seqs_items--) {
 276             AV* seq = (AV*)*seqs_ptr++;
 277             I32 seq_items = AvFILLp(seq);
 278             if(seq_items > 0) {
 279                 SV** seq_ptr = AvARRAY(seq) + 1;
 280                 while(seq_items--) {
 281                     SV* seqitem = *seq_ptr++;
 282                     HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
 283                     if(!he) {
 284                         hv_store_ent(tails, seqitem, newSViv(1), 0);
 285                     }
 286                     else {
 287                         SV* val = HeVAL(he);
 288                         sv_inc(val);
 289                     }
 290                 }
 291             }
 292         }
 293
 294         while(1) {
 295             SV* seqhead = NULL;
 296             SV* cand = NULL;
 297             SV* winner = NULL;
 298             SV* val;
 299             HE* tail_entry;
 300             AV* seq;
 301             SV** avptr = AvARRAY(seqs);
 302             items = AvFILLp(seqs)+1;
 303             while(items--) {
 304                 SV** svp;
 305                 seq = (AV*)*avptr++;
 306                 if(AvFILLp(seq) < 0) continue;
 307                 svp = av_fetch(seq, 0, 0);
 308                 seqhead = *svp;
 309                 if(!winner) {
 310                     cand = seqhead;
 311                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
 312                        && (val = HeVAL(tail_entry))
 313                        && (SvIVx(val) > 0))
 314                            continue;
 315                     winner = newSVsv(cand);
 316                     av_push(retval, winner);
 317                 }
 318                 if(!sv_cmp(seqhead, winner)) {
 319
 320                     /* this is basically shift(@seq) in void context */
 321                     SvREFCNT_dec(*AvARRAY(seq));
 322                     *AvARRAY(seq) = &PL_sv_undef;
 323                     AvARRAY(seq) = AvARRAY(seq) + 1;
 324                     AvMAX(seq)--;
 325                     AvFILLp(seq)--;
 326
 327                     if(AvFILLp(seq) < 0) continue;
 328                     svp = av_fetch(seq, 0, 0);
 329                     seqhead = *svp;
 330                     tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
 331                     val = HeVAL(tail_entry);
 332                     sv_dec(val);
 333                 }
 334             }
 335             if(!cand) break;
 336             if(!winner) {
 337                 SvREFCNT_dec(retval);
 338                 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
 339                     "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
 340             }
 341         }
 342     }
 343
 344     /* we don't want anyone modifying the cache entry but us,
 345        and we do so by replacing it completely */
 346     SvREADONLY_on(retval);
 347
 348     meta->mro_linear_c3 = retval;
 349     return retval;
 350 }
 351
 352 /*
 353 =for apidoc mro_get_linear_isa
 354
 355 Returns either C<mro_get_linear_isa_c3> or
 356 C<mro_get_linear_isa_dfs> for the given stash,
 357 dependant upon which MRO is in effect
 358 for that stash.  The return value is a
 359 read-only AV*.
 360
 361 You are responsible for C<SvREFCNT_inc()> on the
 362 return value if you plan to store it anywhere
 363 semi-permanently (otherwise it might be deleted
 364 out from under you the next time the cache is
 365 invalidated).
 366
 367 =cut
 368 */
 369 AV*
 370 Perl_mro_get_linear_isa(pTHX_ HV *stash)
 371 {
 372     struct mro_meta* meta;
 373     assert(stash);
 374     assert(HvAUX(stash));
 375
 376     meta = HvMROMETA(stash);
 377     if(meta->mro_which == MRO_DFS) {
 378         return mro_get_linear_isa_dfs(stash, 0);
 379     } else if(meta->mro_which == MRO_C3) {
 380         return mro_get_linear_isa_c3(stash, 0);
 381     } else {
 382         Perl_croak(aTHX_ "panic: invalid MRO!");
 383     }
 384 }
 385
 386 /*
 387 =for apidoc mro_isa_changed_in
 388
 389 Takes the necessary steps (cache invalidations, mostly)
 390 when the @ISA of the given package has changed.  Invoked
 391 by the C<setisa> magic, should not need to invoke directly.
 392
 393 =cut
 394 */
 395 void
 396 Perl_mro_isa_changed_in(pTHX_ HV* stash)
 397 {
 398     dVAR;
 399     HV* isarev;
 400     AV* linear_mro;
 401     HE* iter;
 402     SV** svp;
 403     I32 items;
 404     struct mro_meta* meta;
 405     char* stashname;
 406
 407     stashname = HvNAME_get(stash);
 408
 409     /* wipe out the cached linearizations for this stash */
 410     meta = HvMROMETA(stash);
 411     SvREFCNT_dec((SV*)meta->mro_linear_dfs);
 412     SvREFCNT_dec((SV*)meta->mro_linear_c3);
 413     meta->mro_linear_dfs = NULL;
 414     meta->mro_linear_c3 = NULL;
 415
 416     /* Wipe the global method cache if this package
 417        is UNIVERSAL or one of its parents */
 418     if(meta->is_universal)
 419         PL_sub_generation++;
 420
 421     /* Wipe the local method cache otherwise */
 422     else
 423         meta->sub_generation++;
 424
 425     /* wipe next::method cache too */
 426     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
 427
 428     /* Iterate the isarev (classes that are our children),
 429        wiping out their linearization and method caches */
 430     if((isarev = meta->mro_isarev)) {
 431         hv_iterinit(isarev);
 432         while((iter = hv_iternext(isarev))) {
 433             SV* revkey = hv_iterkeysv(iter);
 434             HV* revstash = gv_stashsv(revkey, 0);
 435             struct mro_meta* revmeta = HvMROMETA(revstash);
 436             SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
 437             SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
 438             revmeta->mro_linear_dfs = NULL;
 439             revmeta->mro_linear_c3 = NULL;
 440             if(!meta->is_universal)
 441                 revmeta->sub_generation++;
 442             if(revmeta->mro_nextmethod)
 443                 hv_clear(revmeta->mro_nextmethod);
 444         }
 445     }
 446
 447     /* Now iterate our MRO (parents), and do a few things:
 448          1) instantiate with the "fake" flag if they don't exist
 449          2) flag them as universal if we are universal
 450          3) Add everything from our isarev to their isarev
 451     */
 452
 453     /* We're starting at the 2nd element, skipping ourselves here */
 454     linear_mro = mro_get_linear_isa(stash);
 455     svp = AvARRAY(linear_mro) + 1;
 456     items = AvFILLp(linear_mro);
 457
 458     while (items--) {
 459         SV* const sv = *svp++;
 460         struct mro_meta* mrometa;
 461         HV* mroisarev;
 462
 463         HV* mrostash = gv_stashsv(sv, 0);
 464         if(!mrostash) {
 465             mrostash = gv_stashsv(sv, GV_ADD);
 466             /*
 467                We created the package on the fly, so
 468                that we could store isarev information.
 469                This flag lets gv_fetchmeth know about it,
 470                so that it can still generate the very useful
 471                "Can't locate package Foo for @Bar::ISA" warning.
 472             */
 473             HvMROMETA(mrostash)->fake = 1;
 474         }
 475
 476         mrometa = HvMROMETA(mrostash);
 477         mroisarev = mrometa->mro_isarev;
 478
 479         /* is_universal is viral */
 480         if(meta->is_universal)
 481             mrometa->is_universal = 1;
 482
 483         if(!mroisarev)
 484             mroisarev = mrometa->mro_isarev = newHV();
 485
 486         if(!hv_exists(mroisarev, stashname, strlen(stashname)))
 487             hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
 488
 489         if(isarev) {
 490             hv_iterinit(isarev);
 491             while((iter = hv_iternext(isarev))) {
 492                 SV* revkey = hv_iterkeysv(iter);
 493                 if(!hv_exists_ent(mroisarev, revkey, 0))
 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     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  */