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