XS.xs

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