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