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                     HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
 188                     if(!he) {
 189                         if(!hv_store_ent(tails, seqitem, newSViv(1), 0)) {
 190                             croak("failed to store value in hash");
 191                         }
 192                     }
 193                     else {
 194                         SV* const val = HeVAL(he);
 195                         sv_inc(val);
 196                     }
 197                 }
 198             }
 199         }
 200
 201         /* Initialize retval to build the return value in */
 202         retval = newAV();
 203         av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
 204
 205         /* This loop won't terminate until we either finish building
 206            the MRO, or get an exception. */
 207         while(1) {
 208             SV* cand = NULL;
 209             SV* winner = NULL;
 210             int s;
 211
 212             /* "foreach $seq (@seqs)" */
 213             SV** const avptr = AvARRAY(seqs);
 214             for(s = 0; s <= AvFILLp(seqs); s++) {
 215                 SV** svp;
 216                 AV * const seq = (AV*)(avptr[s]);
 217                 SV* seqhead;
 218                 if(!seq) continue; /* skip empty seqs */
 219                 svp = av_fetch(seq, heads[s], 0);
 220                 seqhead = *svp; /* seqhead = head of this seq */
 221                 if(!winner) {
 222                     HE* tail_entry;
 223                     SV* val;
 224                     /* if we haven't found a winner for this round yet,
 225                        and this seqhead is not in tails (or the count
 226                        for it in tails has dropped to zero), then this
 227                        seqhead is our new winner, and is added to the
 228                        final MRO immediately */
 229                     cand = seqhead;
 230                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
 231                        && (val = HeVAL(tail_entry))
 232                        && (SvIVX(val) > 0))
 233                            continue;
 234                     winner = newSVsv(cand);
 235                     av_push(retval, winner);
 236                     /* note however that even when we find a winner,
 237                        we continue looping over @seqs to do housekeeping */
 238                 }
 239                 if(!sv_cmp(seqhead, winner)) {
 240                     /* Once we have a winner (including the iteration
 241                        where we first found him), inc the head ptr
 242                        for any seq which had the winner as a head,
 243                        NULL out any seq which is now empty,
 244                        and adjust tails for consistency */
 245
 246                     const int new_head = ++heads[s];
 247                     if(new_head > AvFILLp(seq)) {
 248                         SvREFCNT_dec(avptr[s]);
 249                         avptr[s] = NULL;
 250                     }
 251                     else {
 252                         HE* tail_entry;
 253                         SV* val;
 254                         /* Because we know this new seqhead used to be
 255                            a tail, we can assume it is in tails and has
 256                            a positive value, which we need to dec */
 257                         svp = av_fetch(seq, new_head, 0);
 258                         seqhead = *svp;
 259                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
 260                         val = HeVAL(tail_entry);
 261                         sv_dec(val);
 262                     }
 263                 }
 264             }
 265
 266             /* if we found no candidates, we are done building the MRO.
 267                !cand means no seqs have any entries left to check */
 268             if(!cand) {
 269                 Safefree(heads);
 270                 break;
 271             }
 272
 273             /* If we had candidates, but nobody won, then the @ISA
 274                hierarchy is not C3-incompatible */
 275             if(!winner) {
 276                 SV *errmsg;
 277                 I32 i;
 278                 /* we have to do some cleanup before we croak */
 279
 280                 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
 281                                   "current merge results [\n", stashname);
 282                 for (i = 0; i <= av_len(retval); i++) {
 283                     SV **elem = av_fetch(retval, i, 0);
 284                     sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
 285                 }
 286                 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
 287
 288                 SvREFCNT_dec(retval);
 289                 Safefree(heads);
 290
 291                 croak("%"SVf, SVfARG(errmsg));
 292             }
 293         }
 294     }
 295     else { /* @ISA was undefined or empty */
 296         /* build a retval containing only ourselves */
 297         retval = newAV();
 298         av_push(retval, newSVpvn(stashname, stashname_len));
 299     }
 300
 301 done:
 302     /* we don't want anyone modifying the cache entry but us,
 303        and we do so by replacing it completely */
 304     SvREADONLY_on(retval);
 305
 306     if(!made_mortal_cache) {
 307         SvREFCNT_inc(retval);
 308         if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) {
 309             croak("failed to store value in hash");
 310         }
 311     }
 312
 313     return retval;
 314 }
 315
 316 STATIC I32
 317 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 318     I32 i;
 319     for (i = startingblock; i >= 0; i--) {
 320         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 321     }
 322     return i;
 323 }
 324
 325 XS(XS_Class_C3_XS_nextcan);
 326 XS(XS_Class_C3_XS_nextcan)
 327 {
 328     dVAR; dXSARGS;
 329
 330     SV* self = ST(0);
 331     const I32 throw_nomethod = SvIVX(ST(1));
 332     register I32 cxix = cxstack_ix;
 333     register const PERL_CONTEXT *ccstack = cxstack;
 334     const PERL_SI *top_si = PL_curstackinfo;
 335     HV* selfstash;
 336     GV* cvgv;
 337     SV *stashname;
 338     const char *fq_subname;
 339     const char *subname;
 340     STRLEN fq_subname_len;
 341     STRLEN stashname_len;
 342     STRLEN subname_len;
 343     SV* sv;
 344     GV** gvp;
 345     AV* linear_av;
 346     SV** linear_svp;
 347     HV* cstash;
 348     GV* candidate = NULL;
 349     CV* cand_cv = NULL;
 350     const char *hvname;
 351     I32 entries;
 352     HV* nmcache;
 353     HE* cache_entry;
 354     SV* cachekey;
 355     I32 i;
 356
 357     SP -= items;
 358
 359     if(sv_isobject(self))
 360         selfstash = SvSTASH(SvRV(self));
 361     else
 362         selfstash = gv_stashsv(self, 0);
 363
 364     assert(selfstash);
 365
 366     hvname = HvNAME(selfstash);
 367     if (!hvname)
 368         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 369
 370     /* This block finds the contextually-enclosing fully-qualified subname,
 371        much like looking at (caller($i))[3] until you find a real sub that
 372        isn't ANON, etc (also skips over pureperl next::method, etc) */
 373     for(i = 0; i < 2; i++) {
 374         cxix = __dopoptosub_at(ccstack, cxix);
 375         for (;;) {
 376             /* we may be in a higher stacklevel, so dig down deeper */
 377             while (cxix < 0) {
 378                 if(top_si->si_type == PERLSI_MAIN)
 379                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 380                 top_si = top_si->si_prev;
 381                 ccstack = top_si->si_cxstack;
 382                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 383             }
 384
 385             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 386               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 387                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 388                 continue;
 389             }
 390
 391             {
 392                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 393                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 394                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 395                         cxix = dbcxix;
 396                         continue;
 397                     }
 398                 }
 399             }
 400
 401             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 402
 403             if(!isGV(cvgv)) {
 404                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 405                 continue;
 406             }
 407
 408             /* we found a real sub here */
 409             sv = sv_2mortal(newSV(0));
 410
 411             gv_efullname3(sv, cvgv, NULL);
 412
 413             fq_subname = SvPVX(sv);
 414             fq_subname_len = SvCUR(sv);
 415
 416             subname = strrchr(fq_subname, ':');
 417             if(!subname)
 418                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 419
 420             subname++;
 421             subname_len = fq_subname_len - (subname - fq_subname);
 422             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 423                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 424                 continue;
 425             }
 426             break;
 427         }
 428         cxix--;
 429     }
 430
 431     /* If we made it to here, we found our context */
 432
 433     /* cachekey = "objpkg|context::method::name" */
 434     cachekey = sv_2mortal(newSVpv(hvname, 0));
 435     sv_catpvn(cachekey, "|", 1);
 436     sv_catsv(cachekey, sv);
 437
 438     nmcache = get_hv("next::METHOD_CACHE", 1);
 439     if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
 440         SV* val = HeVAL(cache_entry);
 441         if(val == &PL_sv_undef) {
 442             if(throw_nomethod)
 443                 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 444             XSRETURN_EMPTY;
 445         }
 446         XPUSHs(sv_2mortal(newRV_inc(val)));
 447         XSRETURN(1);
 448     }
 449
 450     /* beyond here is just for cache misses, so perf isn't as critical */
 451
 452     stashname_len = subname - fq_subname - 2;
 453     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
 454
 455     linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
 456
 457     linear_svp = AvARRAY(linear_av);
 458     entries = AvFILLp(linear_av) + 1;
 459
 460     while (entries--) {
 461         SV* const linear_sv = *linear_svp++;
 462         assert(linear_sv);
 463         if(sv_eq(linear_sv, stashname))
 464             break;
 465     }
 466
 467     if(entries > 0) {
 468         SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
 469         HV* cc3_mro = get_hv("Class::C3::MRO", 0);
 470
 471         while (entries--) {
 472             SV* const linear_sv = *linear_svp++;
 473             assert(linear_sv);
 474
 475             if(cc3_mro) {
 476                 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
 477                 if(he_cc3_mro_class) {
 478                     SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
 479                     if(SvROK(cc3_mro_class_sv)) {
 480                         HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
 481                         SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
 482                         if(svp_cc3_mro_class_methods) {
 483                             SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
 484                             if(SvROK(cc3_mro_class_methods_sv)) {
 485                                 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
 486                                 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
 487                                     continue;
 488                             }
 489                         }
 490                     }
 491                 }
 492             }
 493
 494             cstash = gv_stashsv(linear_sv, FALSE);
 495
 496             if (!cstash) {
 497                 if (ckWARN(WARN_MISC))
 498                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 499                         (void*)linear_sv, hvname);
 500                 continue;
 501             }
 502
 503             assert(cstash);
 504
 505             gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
 506             if (!gvp) continue;
 507
 508             candidate = *gvp;
 509             assert(candidate);
 510
 511             if (SvTYPE(candidate) != SVt_PVGV)
 512                 gv_init(candidate, cstash, subname, subname_len, TRUE);
 513             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 514                 SvREFCNT_dec(linear_av);
 515                 SvREFCNT_inc((SV*)cand_cv);
 516                 if (!hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0)) {
 517                     croak("failed to store value in hash");
 518                 }
 519                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
 520                 XSRETURN(1);
 521             }
 522         }
 523     }
 524
 525     SvREFCNT_dec(linear_av);
 526     if (!hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0)) {
 527         croak("failed to store value in hash");
 528     }
 529     if(throw_nomethod)
 530         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 531     XSRETURN_EMPTY;
 532 }
 533
 534 XS(XS_Class_C3_XS_calculateMRO);
 535 XS(XS_Class_C3_XS_calculateMRO)
 536 {
 537     dVAR; dXSARGS;
 538
 539     SV* classname;
 540     HV* class_stash;
 541     HV* cache = NULL;
 542     AV* res;
 543     I32 res_items;
 544     I32 ret_items;
 545     SV** res_ptr;
 546
 547     if(items < 1 || items > 2)
 548         croak("Usage: calculateMRO(classname[, cache])");
 549
 550     classname = ST(0);
 551     if(items == 2) cache = (HV*)SvRV(ST(1));
 552
 553     class_stash = gv_stashsv(classname, 0);
 554     if(!class_stash)
 555         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 556
 557     res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 558
 559     res_items = ret_items = AvFILLp(res) + 1;
 560     res_ptr = AvARRAY(res);
 561
 562     SP -= items;
 563
 564     while(res_items--) {
 565         SV* res_item = *res_ptr++;
 566         XPUSHs(sv_2mortal(newSVsv(res_item)));
 567     }
 568     SvREFCNT_dec(res);
 569
 570     PUTBACK;
 571
 572     return;
 573 }
 574
 575 XS(XS_Class_C3_XS_plsubgen);
 576 XS(XS_Class_C3_XS_plsubgen)
 577 {
 578     dVAR; dXSARGS;
 579
 580     SP -= items;
 581     XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
 582     PUTBACK;
 583     return;
 584 }
 585
 586 XS(XS_Class_C3_XS_calc_mdt);
 587 XS(XS_Class_C3_XS_calc_mdt)
 588 {
 589     dVAR; dXSARGS;
 590
 591     SV* classname;
 592     HV* cache;
 593     HV* class_stash;
 594     AV* class_mro;
 595     HV* our_c3mro; /* $Class::C3::MRO{classname} */
 596     SV* has_ovf = NULL;
 597     HV* methods;
 598     I32 mroitems;
 599
 600     /* temps */
 601     HV* hv;
 602     HE* he;
 603     SV** svp;
 604
 605     if(items < 1 || items > 2)
 606         croak("Usage: calculate_method_dispatch_table(classname[, cache])");
 607
 608     classname = ST(0);
 609     class_stash = gv_stashsv(classname, 0);
 610     if(!class_stash)
 611         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 612
 613     if(items == 2) cache = (HV*)SvRV(ST(1));
 614
 615     class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 616
 617     our_c3mro = newHV();
 618     if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) {
 619         croak("failed to store value in hash");
 620     }
 621
 622     hv = get_hv("Class::C3::MRO", 1);
 623     if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) {
 624         croak("failed to store value in hash");
 625     }
 626
 627     methods = newHV();
 628
 629     /* skip first entry */
 630     mroitems = AvFILLp(class_mro);
 631     svp = AvARRAY(class_mro) + 1;
 632     while(mroitems--) {
 633         SV* mro_class = *svp++;
 634         HV* mro_stash = gv_stashsv(mro_class, 0);
 635
 636         if(!mro_stash) continue;
 637
 638         if(!has_ovf) {
 639             SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
 640             if(ovfp) has_ovf = *ovfp;
 641         }
 642
 643         hv_iterinit(mro_stash);
 644         while((he = hv_iternext(mro_stash))) {
 645             CV* code;
 646             SV* mskey;
 647             SV* msval;
 648             HE* ourent;
 649             HV* meth_hash;
 650             SV* orig;
 651
 652             mskey = hv_iterkeysv(he);
 653             if(hv_exists_ent(methods, mskey, 0)) continue;
 654
 655             msval = hv_iterval(mro_stash, he);
 656             if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
 657                 continue;
 658
 659             if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
 660                 SV* val = HeVAL(ourent);
 661                 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
 662                     continue;
 663             }
 664
 665             meth_hash = newHV();
 666             orig = newSVsv(mro_class);
 667             sv_catpvn(orig, "::", 2);
 668             sv_catsv(orig, mskey);
 669             if( !hv_store(meth_hash, "orig", 4, orig, 0)
 670              || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0)
 671              || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) {
 672                 croak("failed to store value in hash");
 673             }
 674         }
 675     }
 676
 677     if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) {
 678         croak("failed to store value in hash");
 679     }
 680     if(has_ovf) {
 681         if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) {
 682             croak("failed to store value in hash");
 683         }
 684     }
 685     XSRETURN_EMPTY;
 686 }
 687
 688 MODULE = Class::C3::XS  PACKAGE = Class::C3::XS
 689
 690 PROTOTYPES: DISABLED
 691
 692 BOOT:
 693     newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
 694     newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
 695     newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
 696     newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
 697