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             fq_subname = SvPVX(sv);
 415             fq_subname_len = SvCUR(sv);
 416
 417             subname = strrchr(fq_subname, ':');
 418             if(!subname)
 419                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 420
 421             subname++;
 422             subname_len = fq_subname_len - (subname - fq_subname);
 423             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 424                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 425                 continue;
 426             }
 427             break;
 428         }
 429         cxix--;
 430     }
 431
 432     /* If we made it to here, we found our context */
 433
 434     /* cachekey = "objpkg|context::method::name" */
 435     cachekey = sv_2mortal(newSVpv(hvname, 0));
 436     sv_catpvn(cachekey, "|", 1);
 437     sv_catsv(cachekey, sv);
 438
 439     nmcache = get_hv("next::METHOD_CACHE", 1);
 440     if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
 441         SV* val = HeVAL(cache_entry);
 442         if(val == &PL_sv_undef) {
 443             if(throw_nomethod)
 444                 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 445             XSRETURN_EMPTY;
 446         }
 447         XPUSHs(sv_2mortal(newRV_inc(val)));
 448         XSRETURN(1);
 449     }
 450
 451     /* beyond here is just for cache misses, so perf isn't as critical */
 452
 453     stashname_len = subname - fq_subname - 2;
 454     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
 455
 456     linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
 457
 458     linear_svp = AvARRAY(linear_av);
 459     entries = AvFILLp(linear_av) + 1;
 460
 461     while (entries--) {
 462         SV* const linear_sv = *linear_svp++;
 463         assert(linear_sv);
 464         if(sv_eq(linear_sv, stashname))
 465             break;
 466     }
 467
 468     if(entries > 0) {
 469         SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
 470         HV* cc3_mro = get_hv("Class::C3::MRO", 0);
 471
 472         while (entries--) {
 473             SV* const linear_sv = *linear_svp++;
 474             assert(linear_sv);
 475
 476             if(cc3_mro) {
 477                 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
 478                 if(he_cc3_mro_class) {
 479                     SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
 480                     if(SvROK(cc3_mro_class_sv)) {
 481                         HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
 482                         SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
 483                         if(svp_cc3_mro_class_methods) {
 484                             SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
 485                             if(SvROK(cc3_mro_class_methods_sv)) {
 486                                 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
 487                                 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
 488                                     continue;
 489                             }
 490                         }
 491                     }
 492                 }
 493             }
 494
 495             cstash = gv_stashsv(linear_sv, FALSE);
 496
 497             if (!cstash) {
 498                 if (ckWARN(WARN_MISC))
 499                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 500                         (void*)linear_sv, hvname);
 501                 continue;
 502             }
 503
 504             assert(cstash);
 505
 506             gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
 507             if (!gvp) continue;
 508
 509             candidate = *gvp;
 510             assert(candidate);
 511
 512             if (SvTYPE(candidate) != SVt_PVGV)
 513                 gv_init(candidate, cstash, subname, subname_len, TRUE);
 514             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 515                 SvREFCNT_dec(linear_av);
 516                 SvREFCNT_inc((SV*)cand_cv);
 517                 if (!hv_store_ent(nmcache, cachekey, (SV*)cand_cv, 0)) {
 518                     croak("failed to store value in hash");
 519                 }
 520                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
 521                 XSRETURN(1);
 522             }
 523         }
 524     }
 525
 526     SvREFCNT_dec(linear_av);
 527     if (!hv_store_ent(nmcache, cachekey, &PL_sv_undef, 0)) {
 528         croak("failed to store value in hash");
 529     }
 530     if(throw_nomethod)
 531         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 532     XSRETURN_EMPTY;
 533 }
 534
 535 XS(XS_Class_C3_XS_calculateMRO);
 536 XS(XS_Class_C3_XS_calculateMRO)
 537 {
 538     dVAR; dXSARGS;
 539
 540     SV* classname;
 541     HV* class_stash;
 542     HV* cache = NULL;
 543     AV* res;
 544     I32 res_items;
 545     I32 ret_items;
 546     SV** res_ptr;
 547
 548     if(items < 1 || items > 2)
 549         croak("Usage: calculateMRO(classname[, cache])");
 550
 551     classname = ST(0);
 552     if(items == 2) cache = (HV*)SvRV(ST(1));
 553
 554     class_stash = gv_stashsv(classname, 0);
 555     if(!class_stash)
 556         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 557
 558     res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 559
 560     res_items = ret_items = AvFILLp(res) + 1;
 561     res_ptr = AvARRAY(res);
 562
 563     SP -= items;
 564
 565     while(res_items--) {
 566         SV* res_item = *res_ptr++;
 567         XPUSHs(sv_2mortal(newSVsv(res_item)));
 568     }
 569     SvREFCNT_dec(res);
 570
 571     PUTBACK;
 572
 573     return;
 574 }
 575
 576 XS(XS_Class_C3_XS_plsubgen);
 577 XS(XS_Class_C3_XS_plsubgen)
 578 {
 579     dVAR; dXSARGS;
 580
 581     SP -= items;
 582     XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
 583     PUTBACK;
 584     return;
 585 }
 586
 587 XS(XS_Class_C3_XS_calc_mdt);
 588 XS(XS_Class_C3_XS_calc_mdt)
 589 {
 590     dVAR; dXSARGS;
 591
 592     SV* classname;
 593     HV* cache;
 594     HV* class_stash;
 595     AV* class_mro;
 596     HV* our_c3mro; /* $Class::C3::MRO{classname} */
 597     SV* has_ovf = NULL;
 598     HV* methods;
 599     I32 mroitems;
 600
 601     /* temps */
 602     HV* hv;
 603     HE* he;
 604     SV** svp;
 605
 606     if(items < 1 || items > 2)
 607         croak("Usage: calculate_method_dispatch_table(classname[, cache])");
 608
 609     classname = ST(0);
 610     class_stash = gv_stashsv(classname, 0);
 611     if(!class_stash)
 612         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 613
 614     if(items == 2) cache = (HV*)SvRV(ST(1));
 615
 616     class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 617
 618     our_c3mro = newHV();
 619     if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
 620         croak("failed to store value in hash");
 621     }
 622
 623     hv = get_hv("Class::C3::MRO", 1);
 624     if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
 625         croak("failed to store value in hash");
 626     }
 627
 628     methods = newHV();
 629
 630     /* skip first entry */
 631     mroitems = AvFILLp(class_mro);
 632     svp = AvARRAY(class_mro) + 1;
 633     while(mroitems--) {
 634         SV* mro_class = *svp++;
 635         HV* mro_stash = gv_stashsv(mro_class, 0);
 636
 637         if(!mro_stash) continue;
 638
 639         if(!has_ovf) {
 640             SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
 641             if(ovfp) has_ovf = *ovfp;
 642         }
 643
 644         hv_iterinit(mro_stash);
 645         while((he = hv_iternext(mro_stash))) {
 646             CV* code;
 647             SV* mskey;
 648             SV* msval;
 649             HE* ourent;
 650             HV* meth_hash;
 651             SV* orig;
 652
 653             mskey = hv_iterkeysv(he);
 654             if(hv_exists_ent(methods, mskey, 0)) continue;
 655
 656             msval = hv_iterval(mro_stash, he);
 657             if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
 658                 continue;
 659
 660             if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
 661                 SV* val = HeVAL(ourent);
 662                 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
 663                     continue;
 664             }
 665
 666             meth_hash = newHV();
 667             orig = newSVsv(mro_class);
 668             sv_catpvn(orig, "::", 2);
 669             sv_catsv(orig, mskey);
 670             if( !hv_store(meth_hash, "orig", 4, orig, 0)
 671              || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
 672              || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
 673                 croak("failed to store value in hash");
 674             }
 675         }
 676     }
 677
 678     if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
 679         croak("failed to store value in hash");
 680     }
 681     if(has_ovf) {
 682         if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
 683             croak("failed to store value in hash");
 684         }
 685     }
 686     XSRETURN_EMPTY;
 687 }
 688
 689 MODULE = Class::C3::XS  PACKAGE = Class::C3::XS
 690
 691 PROTOTYPES: DISABLED
 692
 693 BOOT:
 694     newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
 695     newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
 696     newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
 697     newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
 698