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                     av_push(retval, newSVsv(subsv));
 173                     hv_store_ent(stored, subsv, &PL_sv_undef, 0);
 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         if(!hv_exists(mroisarev, stashname, strlen(stashname)))
 484             hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
 485
 486         if(isarev) {
 487             hv_iterinit(isarev);
 488             while((iter = hv_iternext(isarev))) {
 489                 SV* revkey = hv_iterkeysv(iter);
 490                 if(!hv_exists_ent(mroisarev, revkey, 0))
 491                     hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
 492             }
 493         }
 494     }
 495 }
 496
 497 /*
 498 =for apidoc mro_method_changed_in
 499
 500 Like C<mro_isa_changed_in>, but invalidates method
 501 caching on any child classes of the given stash, so
 502 that they might notice the changes in this one.
 503
 504 Ideally, all instances of C<PL_sub_generation++> in
 505 the perl source should be replaced by calls to this.
 506 Some already are, but some are more difficult to
 507 replace.
 508
 509 Perl has always had problems with method caches
 510 getting out of sync when one directly manipulates
 511 stashes via things like C<%{Foo::} = %{Bar::}> or
 512 C<${Foo::}{bar} = ...> or the equivalent.  If
 513 you do this in core or XS code, call this afterwards
 514 on the destination stash to get things back in sync.
 515
 516 If you're doing such a thing from pure perl, use
 517 C<mro::method_changed_in(classname)>, which
 518 just calls this.
 519
 520 =cut
 521 */
 522 void
 523 Perl_mro_method_changed_in(pTHX_ HV *stash)
 524 {
 525     struct mro_meta* meta = HvMROMETA(stash);
 526     HV* isarev;
 527     HE* iter;
 528
 529     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
 530        invalidate all method caches globally */
 531     if(meta->is_universal) {
 532         PL_sub_generation++;
 533         return;
 534     }
 535
 536     /* else, invalidate the method caches of all child classes,
 537        but not itself */
 538     if((isarev = meta->mro_isarev)) {
 539         hv_iterinit(isarev);
 540         while((iter = hv_iternext(isarev))) {
 541             SV* revkey = hv_iterkeysv(iter);
 542             HV* revstash = gv_stashsv(revkey, 0);
 543             struct mro_meta* mrometa = HvMROMETA(revstash);
 544             mrometa->sub_generation++;
 545             if(mrometa->mro_nextmethod)
 546                 hv_clear(mrometa->mro_nextmethod);
 547         }
 548     }
 549 }
 550
 551 /* These two are static helpers for next::method and friends,
 552    and re-implement a bunch of the code from pp_caller() in
 553    a more efficient manner for this particular usage.
 554 */
 555
 556 STATIC I32
 557 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 558     I32 i;
 559     for (i = startingblock; i >= 0; i--) {
 560         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 561     }
 562     return i;
 563 }
 564
 565 STATIC SV*
 566 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
 567 {
 568     register I32 cxix;
 569     register const PERL_CONTEXT *ccstack = cxstack;
 570     const PERL_SI *top_si = PL_curstackinfo;
 571     HV* selfstash;
 572     GV* cvgv;
 573     SV *stashname;
 574     const char *fq_subname;
 575     const char *subname;
 576     STRLEN fq_subname_len;
 577     STRLEN stashname_len;
 578     STRLEN subname_len;
 579     SV* sv;
 580     GV** gvp;
 581     AV* linear_av;
 582     SV** linear_svp;
 583     SV* linear_sv;
 584     HV* curstash;
 585     GV* candidate = NULL;
 586     CV* cand_cv = NULL;
 587     const char *hvname;
 588     I32 items;
 589     struct mro_meta* selfmeta;
 590     HV* nmcache;
 591     HE* cache_entry;
 592
 593     if(sv_isobject(self))
 594         selfstash = SvSTASH(SvRV(self));
 595     else
 596         selfstash = gv_stashsv(self, 0);
 597
 598     assert(selfstash);
 599
 600     hvname = HvNAME_get(selfstash);
 601     if (!hvname)
 602         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 603
 604     cxix = __dopoptosub_at(cxstack, cxstack_ix);
 605
 606     /* This block finds the contextually-enclosing fully-qualified subname,
 607        much like looking at (caller($i))[3] until you find a real sub that
 608        isn't ANON, etc */
 609     for (;;) {
 610         /* we may be in a higher stacklevel, so dig down deeper */
 611         while (cxix < 0) {
 612             if(top_si->si_type == PERLSI_MAIN)
 613                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 614             top_si = top_si->si_prev;
 615             ccstack = top_si->si_cxstack;
 616             cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 617         }
 618
 619         if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 620           || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 621             cxix = __dopoptosub_at(ccstack, cxix - 1);
 622             continue;
 623         }
 624
 625         {
 626             const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 627             if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 628                 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 629                     cxix = dbcxix;
 630                     continue;
 631                 }
 632             }
 633         }
 634
 635         cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 636
 637         if(!isGV(cvgv)) {
 638             cxix = __dopoptosub_at(ccstack, cxix - 1);
 639             continue;
 640         }
 641
 642         /* we found a real sub here */
 643         sv = sv_2mortal(newSV(0));
 644
 645         gv_efullname3(sv, cvgv, NULL);
 646
 647         fq_subname = SvPVX(sv);
 648         fq_subname_len = SvCUR(sv);
 649
 650         subname = strrchr(fq_subname, ':');
 651         if(!subname)
 652             Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 653
 654         subname++;
 655         subname_len = fq_subname_len - (subname - fq_subname);
 656         if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 657             cxix = __dopoptosub_at(ccstack, cxix - 1);
 658             continue;
 659         }
 660         break;
 661     }
 662
 663     /* If we made it to here, we found our context */
 664
 665     /* Initialize the next::method cache for this stash
 666        if necessary */
 667     selfmeta = HvMROMETA(selfstash);
 668     if(!(nmcache = selfmeta->mro_nextmethod)) {
 669         nmcache = selfmeta->mro_nextmethod = newHV();
 670     }
 671
 672     /* Use the cached coderef if it exists */
 673     else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
 674         SV* val = HeVAL(cache_entry);
 675         if(val == &PL_sv_undef) {
 676             if(throw_nomethod)
 677                 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 678         }
 679         return val;
 680     }
 681
 682     /* beyond here is just for cache misses, so perf isn't as critical */
 683
 684     stashname_len = subname - fq_subname - 2;
 685     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
 686
 687     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
 688
 689     linear_svp = AvARRAY(linear_av);
 690     items = AvFILLp(linear_av) + 1;
 691
 692     /* Walk down our MRO, skipping everything up
 693        to the contextually enclosing class */
 694     while (items--) {
 695         linear_sv = *linear_svp++;
 696         assert(linear_sv);
 697         if(sv_eq(linear_sv, stashname))
 698             break;
 699     }
 700
 701     /* Now search the remainder of the MRO for the
 702        same method name as the contextually enclosing
 703        method */
 704     if(items > 0) {
 705         while (items--) {
 706             linear_sv = *linear_svp++;
 707             assert(linear_sv);
 708             curstash = gv_stashsv(linear_sv, FALSE);
 709
 710             if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
 711                 if (ckWARN(WARN_SYNTAX))
 712                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 713                         (void*)linear_sv, hvname);
 714                 continue;
 715             }
 716
 717             assert(curstash);
 718
 719             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
 720             if (!gvp) continue;
 721
 722             candidate = *gvp;
 723             assert(candidate);
 724
 725             if (SvTYPE(candidate) != SVt_PVGV)
 726                 gv_init(candidate, curstash, subname, subname_len, TRUE);
 727
 728             /* Notably, we only look for real entries, not method cache
 729                entries, because in C3 the method cache of a parent is not
 730                valid for the child */
 731             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 732                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
 733                 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
 734                 return (SV*)cand_cv;
 735             }
 736         }
 737     }
 738
 739     hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
 740     if(throw_nomethod)
 741         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 742     return &PL_sv_undef;
 743 }
 744
 745 #include "XSUB.h"
 746
 747 XS(XS_mro_get_linear_isa);
 748 XS(XS_mro_set_mro);
 749 XS(XS_mro_get_mro);
 750 XS(XS_mro_get_isarev);
 751 XS(XS_mro_is_universal);
 752 XS(XS_mro_get_global_sub_generation);
 753 XS(XS_mro_invalidate_all_method_caches);
 754 XS(XS_mro_get_sub_generation);
 755 XS(XS_mro_method_changed_in);
 756 XS(XS_next_can);
 757 XS(XS_next_method);
 758 XS(XS_maybe_next_method);
 759
 760 void
 761 Perl_boot_core_mro(pTHX)
 762 {
 763     dVAR;
 764     static const char file[] = __FILE__;
 765
 766     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
 767     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
 768     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
 769     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
 770     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
 771     newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_generation, file, "");
 772     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_all_method_caches, file, "");
 773     newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
 774     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
 775     newXS("next::can", XS_next_can, file);
 776     newXS("next::method", XS_next_method, file);
 777     newXS("maybe::next::method", XS_maybe_next_method, file);
 778 }
 779
 780 XS(XS_mro_get_linear_isa) {
 781     dVAR;
 782     dXSARGS;
 783     AV* RETVAL;
 784     HV* class_stash;
 785     SV* classname;
 786
 787     PERL_UNUSED_ARG(cv);
 788
 789     if(items < 1 || items > 2)
 790        Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
 791
 792     classname = ST(0);
 793     class_stash = gv_stashsv(classname, 0);
 794     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 795
 796     if(items > 1) {
 797         char* which = SvPV_nolen(ST(1));
 798         if(strEQ(which, "dfs"))
 799             RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
 800         else if(strEQ(which, "c3"))
 801             RETVAL = mro_get_linear_isa_c3(class_stash, 0);
 802         else
 803             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
 804     }
 805     else {
 806         RETVAL = mro_get_linear_isa(class_stash);
 807     }
 808
 809     ST(0) = newRV_inc((SV*)RETVAL);
 810     sv_2mortal(ST(0));
 811     XSRETURN(1);
 812 }
 813
 814 XS(XS_mro_set_mro)
 815 {
 816     dVAR;
 817     dXSARGS;
 818     SV* classname;
 819     char* whichstr;
 820     mro_alg which;
 821     HV* class_stash;
 822     struct mro_meta* meta;
 823
 824     PERL_UNUSED_ARG(cv);
 825
 826     if (items != 2)
 827        Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
 828
 829     classname = ST(0);
 830     whichstr = SvPV_nolen(ST(1));
 831     class_stash = gv_stashsv(classname, GV_ADD);
 832     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 833     meta = HvMROMETA(class_stash);
 834
 835     if(strEQ(whichstr, "dfs"))
 836         which = MRO_DFS;
 837     else if(strEQ(whichstr, "c3"))
 838         which = MRO_C3;
 839     else
 840         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
 841
 842     if(meta->mro_which != which) {
 843         meta->mro_which = which;
 844         /* Only affects local method cache, not
 845            even child classes */
 846         meta->sub_generation++;
 847         if(meta->mro_nextmethod)
 848             hv_clear(meta->mro_nextmethod);
 849     }
 850
 851     XSRETURN_EMPTY;
 852 }
 853
 854
 855 XS(XS_mro_get_mro)
 856 {
 857     dVAR;
 858     dXSARGS;
 859     SV* classname;
 860     HV* class_stash;
 861     struct mro_meta* meta;
 862
 863     PERL_UNUSED_ARG(cv);
 864
 865     if (items != 1)
 866        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
 867
 868     classname = ST(0);
 869     class_stash = gv_stashsv(classname, 0);
 870     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 871     meta = HvMROMETA(class_stash);
 872
 873     if(meta->mro_which == MRO_DFS)
 874         ST(0) = sv_2mortal(newSVpvn("dfs", 3));
 875     else
 876         ST(0) = sv_2mortal(newSVpvn("c3", 2));
 877
 878     XSRETURN(1);
 879 }
 880
 881 XS(XS_mro_get_isarev)
 882 {
 883     dVAR;
 884     dXSARGS;
 885     SV* classname;
 886     HV* class_stash;
 887     HV* isarev;
 888
 889     PERL_UNUSED_ARG(cv);
 890
 891     if (items != 1)
 892        Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
 893
 894     classname = ST(0);
 895
 896     class_stash = gv_stashsv(classname, 0);
 897     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 898
 899     SP -= items;
 900
 901     if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
 902         HE* iter;
 903         hv_iterinit(isarev);
 904         while((iter = hv_iternext(isarev)))
 905             XPUSHs(hv_iterkeysv(iter));
 906     }
 907
 908     PUTBACK;
 909     return;
 910 }
 911
 912 XS(XS_mro_is_universal)
 913 {
 914     dVAR;
 915     dXSARGS;
 916     SV* classname;
 917     HV* class_stash;
 918
 919     PERL_UNUSED_ARG(cv);
 920
 921     if (items != 1)
 922        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
 923
 924     classname = ST(0);
 925     class_stash = gv_stashsv(classname, 0);
 926     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 927
 928     if (HvMROMETA(class_stash)->is_universal)
 929         XSRETURN_YES;
 930     else
 931         XSRETURN_NO;
 932 }
 933
 934 XS(XS_mro_get_global_sub_generation)
 935 {
 936     dVAR;
 937     dXSARGS;
 938
 939     PERL_UNUSED_ARG(cv);
 940
 941     if (items != 0)
 942         Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
 943
 944     ST(0) = sv_2mortal(newSViv(PL_sub_generation));
 945     XSRETURN(1);
 946 }
 947
 948 XS(XS_mro_invalidate_all_method_caches)
 949 {
 950     dVAR;
 951     dXSARGS;
 952
 953     PERL_UNUSED_ARG(cv);
 954
 955     if (items != 0)
 956         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
 957
 958     PL_sub_generation++;
 959
 960     XSRETURN_EMPTY;
 961 }
 962
 963 XS(XS_mro_get_sub_generation)
 964 {
 965     dVAR;
 966     dXSARGS;
 967     SV* classname;
 968     HV* class_stash;
 969
 970     PERL_UNUSED_ARG(cv);
 971
 972     if(items != 1)
 973         Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
 974
 975     classname = ST(0);
 976     class_stash = gv_stashsv(classname, 0);
 977     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 978
 979     ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
 980     XSRETURN(1);
 981 }
 982
 983 XS(XS_mro_method_changed_in)
 984 {
 985     dVAR;
 986     dXSARGS;
 987     SV* classname;
 988     HV* class_stash;
 989
 990     PERL_UNUSED_ARG(cv);
 991
 992     if(items != 1)
 993         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
 994
 995     classname = ST(0);
 996
 997     class_stash = gv_stashsv(classname, 0);
 998     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
 999
1000     mro_method_changed_in(class_stash);
1001
1002     XSRETURN_EMPTY;
1003 }
1004
1005 XS(XS_next_can)
1006 {
1007     dVAR;
1008     dXSARGS;
1009     SV* self = ST(0);
1010     SV* methcv = __nextcan(aTHX_ self, 0);
1011
1012     PERL_UNUSED_ARG(cv);
1013     PERL_UNUSED_VAR(items);
1014
1015     if(methcv == &PL_sv_undef) {
1016         ST(0) = &PL_sv_undef;
1017     }
1018     else {
1019         ST(0) = sv_2mortal(newRV_inc(methcv));
1020     }
1021
1022     XSRETURN(1);
1023 }
1024
1025 XS(XS_next_method)
1026 {
1027     dMARK;
1028     dAX;
1029     SV* self = ST(0);
1030     SV* methcv = __nextcan(aTHX_ self, 1);
1031
1032     PERL_UNUSED_ARG(cv);
1033
1034     PL_markstack_ptr++;
1035     call_sv(methcv, GIMME_V);
1036 }
1037
1038 XS(XS_maybe_next_method)
1039 {
1040     dMARK;
1041     dAX;
1042     SV* self = ST(0);
1043     SV* methcv = __nextcan(aTHX_ self, 0);
1044
1045     PERL_UNUSED_ARG(cv);
1046
1047     if(methcv == &PL_sv_undef) {
1048         ST(0) = &PL_sv_undef;
1049         XSRETURN(1);
1050     }
1051
1052     PL_markstack_ptr++;
1053     call_sv(methcv, GIMME_V);
1054 }
1055
1056 /*
1057  * Local variables:
1058  * c-indentation-style: bsd
1059  * c-basic-offset: 4
1060  * indent-tabs-mode: t
1061  * End:
1062  *
1063  * ex: set ts=8 sts=4 sw=4 noet:
1064  */