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