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