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;
 275     I32 throw_nomethod;
 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     self = ST(0);
 301     throw_nomethod = SvIVX(ST(1));
 302
 303     SP -= items;
 304
 305     if(sv_isobject(self))
 306         selfstash = SvSTASH(SvRV(self));
 307     else
 308         selfstash = gv_stashsv(self, 0);
 309
 310     assert(selfstash);
 311
 312     hvname = HvNAME(selfstash);
 313     if (!hvname)
 314         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 315
 316     cxix = __dopoptosub_at(cxstack, cxstack_ix);
 317     cxix = __dopoptosub_at(ccstack, cxix - 1);
 318
 319     /* This block finds the contextually-enclosing fully-qualified subname,
 320        much like looking at (caller($i))[3] until you find a real sub that
 321        isn't ANON, etc */
 322     for (;;) {
 323         /* we may be in a higher stacklevel, so dig down deeper */
 324         while (cxix < 0) {
 325             if(top_si->si_type == PERLSI_MAIN)
 326                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 327             top_si = top_si->si_prev;
 328             ccstack = top_si->si_cxstack;
 329             cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 330         }
 331
 332         if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 333           || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 334             cxix = __dopoptosub_at(ccstack, cxix - 1);
 335             continue;
 336         }
 337
 338         {
 339             const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 340             if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 341                 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 342                     cxix = dbcxix;
 343                     continue;
 344                 }
 345             }
 346         }
 347
 348         cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 349
 350         if(!isGV(cvgv)) {
 351             cxix = __dopoptosub_at(ccstack, cxix - 1);
 352             continue;
 353         }
 354
 355         /* we found a real sub here */
 356         sv = sv_2mortal(newSV(0));
 357
 358         gv_efullname3(sv, cvgv, NULL);
 359
 360         fq_subname = SvPVX(sv);
 361         fq_subname_len = SvCUR(sv);
 362
 363         subname = strrchr(fq_subname, ':');
 364         if(!subname)
 365             Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 366
 367         subname++;
 368         subname_len = fq_subname_len - (subname - fq_subname);
 369         if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 370             cxix = __dopoptosub_at(ccstack, cxix - 1);
 371             continue;
 372         }
 373         break;
 374     }
 375
 376     /* If we made it to here, we found our context */
 377
 378     /* cachekey = "objpkg|context::method::name" */
 379     cachekey = sv_2mortal(newSVpv(hvname, 0));
 380     sv_catpvn(cachekey, "|", 1);
 381     sv_catsv(cachekey, sv);
 382
 383     nmcache = get_hv("next::METHOD_CACHE", 1);
 384     if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
 385         SV* val = HeVAL(cache_entry);
 386         if(val == &PL_sv_undef) {
 387             if(throw_nomethod)
 388                 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 389             XSRETURN_EMPTY;
 390         }
 391         XPUSHs(sv_2mortal(newRV_inc(val)));
 392         XSRETURN(1);
 393     }
 394
 395     /* beyond here is just for cache misses, so perf isn't as critical */
 396
 397     stashname_len = subname - fq_subname - 2;
 398     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
 399
 400     linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
 401
 402     linear_svp = AvARRAY(linear_av);
 403     entries = AvFILLp(linear_av) + 1;
 404
 405     while (entries--) {
 406         SV* const linear_sv = *linear_svp++;
 407         assert(linear_sv);
 408         if(sv_eq(linear_sv, stashname))
 409             break;
 410     }
 411
 412     if(entries > 0) {
 413         SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
 414         HV* cc3_mro = get_hv("Class::C3::MRO", 0);
 415
 416         while (entries--) {
 417             SV* const linear_sv = *linear_svp++;
 418             assert(linear_sv);
 419
 420             if(cc3_mro) {
 421                 HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
 422                 if(he_cc3_mro_class) {
 423                     SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
 424                     if(SvROK(cc3_mro_class_sv)) {
 425                         HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
 426                         SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
 427                         if(svp_cc3_mro_class_methods) {
 428                             SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
 429                             if(SvROK(cc3_mro_class_methods_sv)) {
 430                                 HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
 431                                 if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
 432                                     continue;
 433                             }
 434                         }
 435                     }
 436                 }
 437             }
 438
 439             cstash = gv_stashsv(linear_sv, FALSE);
 440
 441             if (!cstash) {
 442                 if (ckWARN(WARN_MISC))
 443                     Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
 444                         (void*)linear_sv, hvname);
 445                 continue;
 446             }
 447
 448             assert(cstash);
 449
 450             gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
 451             if (!gvp) continue;
 452
 453             candidate = *gvp;
 454             assert(candidate);
 455
 456             if (SvTYPE(candidate) != SVt_PVGV)
 457                 gv_init(candidate, cstash, subname, subname_len, TRUE);
 458             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 459                 SvREFCNT_dec(linear_av);
 460                 SvREFCNT_inc((SV*)cand_cv);
 461                 hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
 462                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
 463                 XSRETURN(1);
 464             }
 465         }
 466     }
 467
 468     SvREFCNT_dec(linear_av);
 469     hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
 470     if(throw_nomethod)
 471         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 472     XSRETURN_EMPTY;
 473 }
 474
 475 XS(XS_Class_C3_XS_calculateMRO);
 476 XS(XS_Class_C3_XS_calculateMRO)
 477 {
 478     dVAR; dXSARGS;
 479
 480     SV* classname;
 481     HV* class_stash;
 482     HV* cache = NULL;
 483     AV* res;
 484     I32 res_items;
 485     I32 ret_items;
 486     SV** res_ptr;
 487
 488     if(items < 1 || items > 2)
 489         croak("Usage: calculateMRO(classname[, cache])");
 490
 491     classname = ST(0);
 492     if(items == 2) cache = (HV*)SvRV(ST(1));
 493
 494     class_stash = gv_stashsv(classname, 0);
 495     if(!class_stash)
 496         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 497
 498     res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 499
 500     res_items = ret_items = AvFILLp(res) + 1;
 501     res_ptr = AvARRAY(res);
 502
 503     SP -= items;
 504
 505     while(res_items--) {
 506         SV* res_item = *res_ptr++;
 507         XPUSHs(sv_2mortal(newSVsv(res_item)));
 508     }
 509     SvREFCNT_dec(res);
 510
 511     PUTBACK;
 512
 513     return;
 514 }
 515
 516 XS(XS_Class_C3_XS_plsubgen);
 517 XS(XS_Class_C3_XS_plsubgen)
 518 {
 519     dVAR; dXSARGS;
 520
 521     SP -= items;
 522     XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
 523     PUTBACK;
 524     return;
 525 }
 526
 527 XS(XS_Class_C3_XS_calc_mdt);
 528 XS(XS_Class_C3_XS_calc_mdt)
 529 {
 530     dVAR; dXSARGS;
 531
 532     SV* classname;
 533     HV* cache;
 534     HV* class_stash;
 535     AV* class_mro;
 536     HV* our_c3mro; /* $Class::C3::MRO{classname} */
 537     SV* has_ovf = NULL;
 538     HV* methods;
 539     I32 mroitems;
 540
 541     /* temps */
 542     HV* hv;
 543     HE* he;
 544     SV** svp;
 545
 546     if(items < 1 || items > 2)
 547         croak("Usage: calculate_method_dispatch_table(classname[, cache])");
 548
 549     classname = ST(0);
 550     class_stash = gv_stashsv(classname, 0);
 551     if(!class_stash)
 552         Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
 553
 554     if(items == 2) cache = (HV*)SvRV(ST(1));
 555
 556     class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
 557
 558     our_c3mro = newHV();
 559     hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);
 560
 561     hv = get_hv("Class::C3::MRO", 1);
 562     hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
 563
 564     methods = newHV();
 565
 566     /* skip first entry */
 567     mroitems = AvFILLp(class_mro);
 568     svp = AvARRAY(class_mro) + 1;
 569     while(mroitems--) {
 570         SV* mro_class = *svp++;
 571         HV* mro_stash = gv_stashsv(mro_class, 0);
 572
 573         if(!mro_stash) continue;
 574
 575         if(!has_ovf) {
 576             SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
 577             if(ovfp) has_ovf = *ovfp;
 578         }
 579
 580         hv_iterinit(mro_stash);
 581         while(he = hv_iternext(mro_stash)) {
 582             CV* code;
 583             SV* mskey;
 584             SV* msval;
 585             HE* ourent;
 586             HV* meth_hash;
 587             SV* orig;
 588
 589             mskey = hv_iterkeysv(he);
 590             if(hv_exists_ent(methods, mskey, 0)) continue;
 591
 592             msval = hv_iterval(mro_stash, he);
 593             if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
 594                 continue;
 595
 596             if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
 597                 SV* val = HeVAL(ourent);
 598                 if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
 599                     continue;
 600             }
 601
 602             meth_hash = newHV();
 603             orig = newSVsv(mro_class);
 604             sv_catpvn(orig, "::", 2);
 605             sv_catsv(orig, mskey);
 606             hv_store(meth_hash, "orig", 4, orig, 0);
 607             hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
 608             hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
 609         }
 610     }
 611
 612     hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
 613     if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
 614     XSRETURN_EMPTY;
 615 }
 616
 617 MODULE = Class::C3::XS  PACKAGE = Class::C3::XS
 618
 619 BOOT:
 620     newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
 621     newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
 622     newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
 623     newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
 624