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