XS.xs

   1
   2 #include "EXTERN.h"
   3 #include "perl.h"
   4 #include "XSUB.h"
   5
   6 /* *********** ppport stuff */
   7
   8 #ifndef PERL_UNUSED_VAR
   9 #  define PERL_UNUSED_VAR(x) ((void)x)
  10 #endif
  11
  12 #if defined(PERL_GCC_PEDANTIC)
  13 #  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
  14 #    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
  15 #  endif
  16 #endif
  17
  18 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
  19 #  ifndef PERL_USE_GCC_BRACE_GROUPS
  20 #    define PERL_USE_GCC_BRACE_GROUPS
  21 #  endif
  22 #endif
  23
  24 #ifndef SvREFCNT_inc
  25 #  ifdef PERL_USE_GCC_BRACE_GROUPS
  26 #    define SvREFCNT_inc(sv) \
  27       ({ \
  28           SV * const _sv = (SV*)(sv); \
  29           if (_sv) \
  30                (SvREFCNT(_sv))++; \
  31           _sv; \
  32       })
  33 #  else
  34 #    define SvREFCNT_inc(sv) \
  35           ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
  36 #  endif
  37 #endif
  38
  39 #ifndef dAX
  40 #  define dAX                            I32 ax = MARK - PL_stack_base + 1
  41 #endif
  42
  43 #ifndef dVAR
  44 #  define dVAR                           dNOOP
  45 #endif
  46
  47 #ifndef packWARN
  48 #  define packWARN(a)                    (a)
  49 #endif
  50
  51 /* *********** end ppport.h stuff */
  52
  53 #ifndef SVfARG
  54 #  define SVfARG(p)                      ((void*)(p))
  55 #endif
  56
  57 /* Most of this code is backported from the bleadperl patch's
  58    mro.c, and then modified to work with Class::C3's
  59    internals.
  60 */
  61
  62 AV*
  63 __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
  64 {
  65     AV* retval;
  66     GV** gvp;
  67     GV* gv;
  68     AV* isa;
  69     const char* stashname;
  70     STRLEN stashname_len;
  71     I32 made_mortal_cache = 0;
  72
  73     assert(stash);
  74
  75     stashname = HvNAME(stash);
  76     stashname_len = strlen(stashname);
  77     if (!stashname)
  78       Perl_croak(aTHX_
  79                  "Can't linearize anonymous symbol table");
  80
  81     if (level > 100)
  82         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  83               stashname);
  84
  85     if(!cache) {
  86         cache = (HV*)sv_2mortal((SV*)newHV());
  87         made_mortal_cache = 1;
  88     }
  89     else {
  90         SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
  91         if(cache_entry)
  92             return (AV*)SvREFCNT_inc(*cache_entry);
  93     }
  94
  95     /* not in cache, make a new one */
  96
  97     gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
  98     isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
  99     if(isa && AvFILLp(isa) >= 0) {
 100         SV** seqs_ptr;
 101         I32 seqs_items;
 102         HV* tails;
 103         AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
 104         I32* heads;
 105
 106         /* This builds @seqs, which is an array of arrays.
 107            The members of @seqs are the MROs of
 108            the members of @ISA, followed by @ISA itself.
 109         */
 110         I32 items = AvFILLp(isa) + 1;
 111         SV** isa_ptr = AvARRAY(isa);
 112         while(items--) {
 113             SV* const isa_item = *isa_ptr++;
 114             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
 115             if(!isa_item_stash) {
 116                 /* if no stash, make a temporary fake MRO
 117                    containing just itself */
 118                 AV* const isa_lin = newAV();
 119                 av_push(isa_lin, newSVsv(isa_item));
 120                 av_push(seqs, (SV*)isa_lin);
 121             }
 122             else {
 123                 /* recursion */
 124                 AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1);
 125
 126                 if(items == 0 && AvFILLp(seqs) == -1) {
 127                     /* Only one parent class. For this case, the C3
 128                        linearisation is this class followed by the parent's
 129                        linearisation, so don't bother with the expensive
 130                        calculation.  */
 131                     SV **svp;
 132                     I32 subrv_items = AvFILLp(isa_lin) + 1;
 133                     SV *const *subrv_p = AvARRAY(isa_lin);
 134
 135                     /* Hijack the allocated but unused array seqs to be the
 136                        return value. It's currently mortalised.  */
 137
 138                     retval = seqs;
 139
 140                     av_extend(retval, subrv_items);
 141                     AvFILLp(retval) = subrv_items;
 142                     svp = AvARRAY(retval);
 143
 144                     /* First entry is this class.  */
 145                     *svp++ = newSVpvn(stashname, stashname_len);
 146
 147                     while(subrv_items--) {
 148                         /* These values are unlikely to be shared hash key
 149                            scalars, so no point in adding code to optimising
 150                            for a case that is unlikely to be true.
 151                            (Or prove me wrong and do it.)  */
 152
 153                         SV *const val = *subrv_p++;
 154                         *svp++ = newSVsv(val);
 155                     }
 156
 157                     SvREFCNT_dec(isa_lin);
 158                     SvREFCNT_inc(retval);
 159
 160                     goto done;
 161                 }
 162                 av_push(seqs, (SV*)isa_lin);
 163             }
 164         }
 165         av_push(seqs, SvREFCNT_inc((SV*)isa));
 166         tails = (HV*)sv_2mortal((SV*)newHV());
 167
 168         /* This builds "heads", which as an array of integer array
 169            indices, one per seq, which point at the virtual "head"
 170            of the seq (initially zero) */
 171         Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
 172
 173         /* This builds %tails, which has one key for every class
 174            mentioned in the tail of any sequence in @seqs (tail meaning
 175            everything after the first class, the "head").  The value
 176            is how many times this key appears in the tails of @seqs.
 177         */
 178         seqs_ptr = AvARRAY(seqs);
 179         seqs_items = AvFILLp(seqs) + 1;
 180         while(seqs_items--) {
 181             AV* const seq = (AV*)*seqs_ptr++;
 182             I32 seq_items = AvFILLp(seq);
 183             if(seq_items > 0) {
 184                 SV** seq_ptr = AvARRAY(seq) + 1;
 185                 while(seq_items--) {
 186                     SV* const seqitem = *seq_ptr++;
 187                     /* LVALUE fetch will create a new undefined SV if necessary
 188                      */
 189                     HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
 190                     if(he) {
 191                         SV* const val = HeVAL(he);
 192                         /* This will increment undef to 1, which is what we
 193                            want for a newly created entry.  */
 194                         sv_inc(val);
 195                     } else {
 196                         croak("failed to store value in hash");
 197                     }
 198                 }
 199             }
 200         }
 201
 202         /* Initialize retval to build the return value in */
 203         retval = newAV();
 204         av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
 205
 206         /* This loop won't terminate until we either finish building
 207            the MRO, or get an exception. */
 208         while(1) {
 209             SV* cand = NULL;
 210             SV* winner = NULL;
 211             int s;
 212
 213             /* "foreach $seq (@seqs)" */
 214             SV** const avptr = AvARRAY(seqs);
 215             for(s = 0; s <= AvFILLp(seqs); s++) {
 216                 SV** svp;
 217                 AV * const seq = (AV*)(avptr[s]);
 218                 SV* seqhead;
 219                 if(!seq) continue; /* skip empty seqs */
 220                 svp = av_fetch(seq, heads[s], 0);
 221                 seqhead = *svp; /* seqhead = head of this seq */
 222                 if(!winner) {
 223                     HE* tail_entry;
 224                     SV* val;
 225                     /* if we haven't found a winner for this round yet,
 226                        and this seqhead is not in tails (or the count
 227                        for it in tails has dropped to zero), then this
 228                        seqhead is our new winner, and is added to the
 229                        final MRO immediately */
 230                     cand = seqhead;
 231                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
 232                        && (val = HeVAL(tail_entry))
 233                        && (SvIVX(val) > 0))
 234                            continue;
 235                     winner = newSVsv(cand);
 236                     av_push(retval, winner);
 237                     /* note however that even when we find a winner,
 238                        we continue looping over @seqs to do housekeeping */
 239                 }
 240                 if(!sv_cmp(seqhead, winner)) {
 241                     /* Once we have a winner (including the iteration
 242                        where we first found him), inc the head ptr
 243                        for any seq which had the winner as a head,
 244                        NULL out any seq which is now empty,
 245                        and adjust tails for consistency */
 246
 247                     const int new_head = ++heads[s];
 248                     if(new_head > AvFILLp(seq)) {
 249                         SvREFCNT_dec(avptr[s]);
 250                         avptr[s] = NULL;
 251                     }
 252                     else {
 253                         HE* tail_entry;
 254                         SV* val;
 255                         /* Because we know this new seqhead used to be
 256                            a tail, we can assume it is in tails and has
 257                            a positive value, which we need to dec */
 258                         svp = av_fetch(seq, new_head, 0);
 259                         seqhead = *svp;
 260                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
 261                         val = HeVAL(tail_entry);
 262                         sv_dec(val);
 263                     }
 264                 }
 265             }
 266
 267             /* if we found no candidates, we are done building the MRO.
 268                !cand means no seqs have any entries left to check */
 269             if(!cand) {
 270                 Safefree(heads);
 271                 break;
 272             }
 273
 274             /* If we had candidates, but nobody won, then the @ISA
 275                hierarchy is not C3-incompatible */
 276             if(!winner) {
 277                 SV *errmsg;
 278                 I32 i;
 279                 /* we have to do some cleanup before we croak */
 280
 281                 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
 282                                   "current merge results [\n", stashname);
 283                 for (i = 0; i <= av_len(retval); i++) {
 284                     SV **elem = av_fetch(retval, i, 0);
 285                     sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
 286                 }
 287                 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
 288
 289                 SvREFCNT_dec(retval);
 290                 Safefree(heads);
 291
 292                 croak("%"SVf, SVfARG(errmsg));
 293             }
 294         }
 295     }
 296     else { /* @ISA was undefined or empty */
 297         /* build a retval containing only ourselves */
 298         retval = newAV();
 299         av_push(retval, newSVpvn(stashname, stashname_len));
 300     }
 301
 302 done:
 303     /* we don't want anyone modifying the cache entry but us,
 304        and we do so by replacing it completely */
 305     SvREADONLY_on(retval);
 306
 307     if(!made_mortal_cache) {
 308         SvREFCNT_inc(retval);
 309         if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
 310             croak("failed to store value in hash");
 311         }
 312     }
 313
 314     return retval;
 315 }
 316
 317 STATIC I32
 318 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 319     I32 i;
 320     for (i = startingblock; i >= 0; i--) {
 321         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 322     }
 323     return i;
 324 }
 325
 326 XS(XS_Class_C3_XS_nextcan);
 327 XS(XS_Class_C3_XS_nextcan)
 328 {
 329     dVAR; dXSARGS;
 330
 331     SV* self = ST(0);
 332     const I32 throw_nomethod = SvIVX(ST(1));
 333     register I32 cxix = cxstack_ix;
 334     register const PERL_CONTEXT *ccstack = cxstack;
 335     const PERL_SI *top_si = PL_curstackinfo;
 336     HV* selfstash;
 337     GV* cvgv;
 338     SV *stashname;
 339     const char *fq_subname;
 340     const char *subname;
 341     STRLEN fq_subname_len;
 342     STRLEN stashname_len;
 343     STRLEN subname_len;
 344     SV* sv;
 345     GV** gvp;
 346     AV* linear_av;
 347     SV** linear_svp;
 348     HV* cstash;
 349     GV* candidate = NULL;
 350     CV* cand_cv = NULL;
 351     const char *hvname;
 352     I32 entries;
 353     HV* nmcache;
 354     HE* cache_entry;
 355     SV* cachekey;
 356     I32 i;
 357
 358     SP -= items;
 359
 360     if(sv_isobject(self))
 361         selfstash = SvSTASH(SvRV(self));
 362     else
 363         selfstash = gv_stashsv(self, 0);
 364
 365     assert(selfstash);
 366
 367     hvname = HvNAME(selfstash);
 368     if (!hvname)
 369         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 370
 371     /* This block finds the contextually-enclosing fully-qualified subname,
 372        much like looking at (caller($i))[3] until you find a real sub that
 373        isn't ANON, etc (also skips over pureperl next::method, etc) */
 374     for(i = 0; i < 2; i++) {
 375         cxix = __dopoptosub_at(ccstack, cxix);
 376         for (;;) {
 377             /* we may be in a higher stacklevel, so dig down deeper */
 378             while (cxix < 0) {
 379                 if(top_si->si_type == PERLSI_MAIN)
 380                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 381                 top_si = top_si->si_prev;
 382                 ccstack = top_si->si_cxstack;
 383                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 384             }
 385
 386             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 387               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 388                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 389                 continue;
 390             }
 391
 392             {
 393                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 394                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 395                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 396                         cxix = dbcxix;
 397                         continue;
 398                     }
 399                 }
 400             }
 401
 402             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 403
 404             if(!isGV(cvgv)) {
 405                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 406                 continue;
 407             }
 408
 409             /* we found a real sub here */
 410             sv = sv_newmortal();
 411
 412             gv_efullname3(sv, cvgv, NULL);
 413
 414             if (SvPOK(sv)) {
 415                 fq_subname = SvPVX(sv);
 416                 fq_subname_len = SvCUR(sv);
 417
 418                 subname = strrchr(fq_subname, ':');
 419             } else {
 420                 subname = NULL;
 421             }
 422
 423             subname = strrchr(fq_subname, ':');
 424             if(!subname)
 425                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 426
 427             subname++;
 428             subname_len = fq_subname_len - (subname - fq_subname);
 429             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 430                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 431                 continue;
 432             }
 433             break;
 434         }
 435         cxix--;
 436     }
 437
 438     /* If we made it to here, we found our context */
 439
 440     /* cachekey = "objpkg|context::method::name" */
 441     cachekey = sv_2mortal(newSVpv(hvname, 0));
 442     sv_catpvn(cachekey, "|", 1);
 443     sv_catsv(cachekey, sv);
 444
 445     nmcache = get_hv("next::METHOD_CACHE", 1);
 446     if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
 447         SV* val = HeVAL(cache_entry);
 448         if(val == &PL_sv_undef) {
 449             if(throw_nomethod)
 450                 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 451             XSRETURN_EMPTY;
 452         }
 453         XPUSHs(sv_2mortal(newRV_inc(val)));
 454         XSRETURN(1);
 455     }
 456
 457     /* beyond here is just for cache misses, so perf isn't as critical */
 458
 459     stashname_len = subname - fq_subname - 2;
 460     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
 461
 462     linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
 463
 464     linear_svp = AvARRAY(linear_av);
 465     entries = AvFILLp(linear_av) + 1;
 466
 467     while (entries--) {
 468         SV* const linear_sv = *linear_svp++;
 469         assert(linear_sv);
 470         if(sv_eq(linear_sv, stashname))
 471             break;
 472     }
 473
 474     if(entries > 0) {
 475         SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
 476         HV* cc3_mro = get_hv("Class::C3::MRO", 0);
 477
 478         while (entries--) {
 479             SV* const linear_sv = *linear_svp++;
 480             assert(linear_sv);
 481
 482             if(cc3_mro) {
 483                 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
 484                 if(he_cc3_mro_class) {
 485                     SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
 486                     if(SvROK(cc3_mro_class_sv)) {
 487                         HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
 488                         SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
 489                         if(svp_cc3_mro_class_methods) {
 490                             SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
 491                             if(SvROK(cc3_mro_class_methods_sv)) {
 492                                 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
 493                                 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
 494                                     continue;
 495                             }
 496                         }
 497                     }
 498                 }
 499             }
 500
 501             cstash = gv_stashsv(linear_sv, FALSE);
 502
 503             if (!cstash) {
 504                 if (ckWARN(WARN_MISC))
 505                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 506                         (void*)linear_sv, hvname);
 507                 continue;
 508             }
 509
 510             assert(cstash);
 511
 512             gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
 513             if (!gvp) continue;
 514
 515             candidate = *gvp;
 516             assert(candidate);
 517
 518             if (SvTYPE(candidate) != SVt_PVGV)
 519                 gv_init(candidate, cstash, subname, subname_len, TRUE);
 520             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 521                 SvREFCNT_dec(linear_av);
 522                 SvREFCNT_inc((SV*)cand_cv);
 523                 if (!hv_store_ent(nmcache, cachekey, (SV*)cand_cv, 0)) {
 524                     croak("failed to store value in hash");
 525                 }
 526                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
 527                 XSRETURN(1);
 528             }
 529         }
 530     }
 531
 532     SvREFCNT_dec(linear_av);
 533     if (!hv_store_ent(nmcache, cachekey, &PL_sv_undef, 0)) {
 534         croak("failed to store value in hash");
 535     }
 536     if(throw_nomethod)
 537         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 538     XSRETURN_EMPTY;
 539 }
 540
 541 XS(XS_Class_C3_XS_calculateMRO);
 542 XS(XS_Class_C3_XS_calculateMRO)
 543 {
 544     dVAR; dXSARGS;
 545
 546     SV* classname;
 547     HV* class_stash;
 548     HV* cache = NULL;
 549     AV* res;
 550     I32 res_items;
 551     I32 ret_items;
 552     SV** res_ptr;
 553
 554     if(items < 1 || items > 2)
 555         croak("Usage: calculateMRO(classname[, cache])");
 556
 557     classname = ST(0);
 558     if(items == 2) cache = (HV*)SvRV(ST(1));
 559
 560     class_stash = gv_stashsv(classname, 0);
 561     if(!class_stash)
 562         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 563
 564     res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 565
 566     res_items = ret_items = AvFILLp(res) + 1;
 567     res_ptr = AvARRAY(res);
 568
 569     SP -= items;
 570
 571     while(res_items--) {
 572         SV* res_item = *res_ptr++;
 573         XPUSHs(sv_2mortal(newSVsv(res_item)));
 574     }
 575     SvREFCNT_dec(res);
 576
 577     PUTBACK;
 578
 579     return;
 580 }
 581
 582 XS(XS_Class_C3_XS_plsubgen);
 583 XS(XS_Class_C3_XS_plsubgen)
 584 {
 585     dVAR; dXSARGS;
 586
 587     SP -= items;
 588     XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
 589     PUTBACK;
 590     return;
 591 }
 592
 593 XS(XS_Class_C3_XS_calc_mdt);
 594 XS(XS_Class_C3_XS_calc_mdt)
 595 {
 596     dVAR; dXSARGS;
 597
 598     SV* classname;
 599     HV* cache;
 600     HV* class_stash;
 601     AV* class_mro;
 602     HV* our_c3mro; /* $Class::C3::MRO{classname} */
 603     SV* has_ovf = NULL;
 604     HV* methods;
 605     I32 mroitems;
 606
 607     /* temps */
 608     HV* hv;
 609     HE* he;
 610     SV** svp;
 611
 612     if(items < 1 || items > 2)
 613         croak("Usage: calculate_method_dispatch_table(classname[, cache])");
 614
 615     classname = ST(0);
 616     class_stash = gv_stashsv(classname, 0);
 617     if(!class_stash)
 618         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 619
 620     if(items == 2) cache = (HV*)SvRV(ST(1));
 621
 622     class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 623
 624     our_c3mro = newHV();
 625     if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
 626         croak("failed to store value in hash");
 627     }
 628
 629     hv = get_hv("Class::C3::MRO", 1);
 630     if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
 631         croak("failed to store value in hash");
 632     }
 633
 634     methods = newHV();
 635
 636     /* skip first entry */
 637     mroitems = AvFILLp(class_mro);
 638     svp = AvARRAY(class_mro) + 1;
 639     while(mroitems--) {
 640         SV* mro_class = *svp++;
 641         HV* mro_stash = gv_stashsv(mro_class, 0);
 642
 643         if(!mro_stash) continue;
 644
 645         if(!has_ovf) {
 646             SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
 647             if(ovfp) has_ovf = *ovfp;
 648         }
 649
 650         hv_iterinit(mro_stash);
 651         while((he = hv_iternext(mro_stash))) {
 652             CV* code;
 653             SV* mskey;
 654             SV* msval;
 655             HE* ourent;
 656             HV* meth_hash;
 657             SV* orig;
 658
 659             mskey = hv_iterkeysv(he);
 660             if(hv_exists_ent(methods, mskey, 0)) continue;
 661
 662             msval = hv_iterval(mro_stash, he);
 663             if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
 664                 continue;
 665
 666             if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
 667                 SV* val = HeVAL(ourent);
 668                 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
 669                     continue;
 670             }
 671
 672             meth_hash = newHV();
 673             orig = newSVsv(mro_class);
 674             sv_catpvn(orig, "::", 2);
 675             sv_catsv(orig, mskey);
 676             if( !hv_store(meth_hash, "orig", 4, orig, 0)
 677              || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
 678              || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
 679                 croak("failed to store value in hash");
 680             }
 681         }
 682     }
 683
 684     if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
 685         croak("failed to store value in hash");
 686     }
 687     if(has_ovf) {
 688         if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
 689             croak("failed to store value in hash");
 690         }
 691     }
 692     XSRETURN_EMPTY;
 693 }
 694
 695 MODULE = Class::C3::XS  PACKAGE = Class::C3::XS
 696
 697 PROTOTYPES: DISABLED
 698
 699 BOOT:
 700     newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
 701     newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
 702     newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
 703     newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
 704