ext/mro/mro.xs

   1 #include "EXTERN.h"
   2 #include "perl.h"
   3 #include "XSUB.h"
   4
   5 static AV*
   6 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
   7
   8 static const struct mro_alg c3_alg =
   9     {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
  10
  11 /*
  12 =for apidoc mro_get_linear_isa_c3
  13
  14 Returns the C3 linearization of @ISA
  15 the given stash.  The return value is a read-only AV*.
  16 C<level> should be 0 (it is used internally in this
  17 function's recursion).
  18
  19 You are responsible for C<SvREFCNT_inc()> on the
  20 return value if you plan to store it anywhere
  21 semi-permanently (otherwise it might be deleted
  22 out from under you the next time the cache is
  23 invalidated).
  24
  25 =cut
  26 */
  27
  28 static AV*
  29 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
  30 {
  31     AV* retval;
  32     GV** gvp;
  33     GV* gv;
  34     AV* isa;
  35     const HEK* stashhek;
  36     struct mro_meta* meta;
  37
  38     assert(HvAUX(stash));
  39
  40     stashhek = HvNAME_HEK(stash);
  41     if (!stashhek)
  42       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
  43
  44     if (level > 100)
  45         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
  46                    HEK_KEY(stashhek));
  47
  48     meta = HvMROMETA(stash);
  49
  50     /* return cache if valid */
  51     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
  52         return retval;
  53     }
  54
  55     /* not in cache, make a new one */
  56
  57     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
  58     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
  59
  60     /* For a better idea how the rest of this works, see the much clearer
  61        pure perl version in Algorithm::C3 0.01:
  62        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
  63        (later versions go about it differently than this code for speed reasons)
  64     */
  65
  66     if(isa && AvFILLp(isa) >= 0) {
  67         SV** seqs_ptr;
  68         I32 seqs_items;
  69         HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
  70         AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
  71         I32* heads;
  72
  73         /* This builds @seqs, which is an array of arrays.
  74            The members of @seqs are the MROs of
  75            the members of @ISA, followed by @ISA itself.
  76         */
  77         I32 items = AvFILLp(isa) + 1;
  78         SV** isa_ptr = AvARRAY(isa);
  79         while(items--) {
  80             SV* const isa_item = *isa_ptr++;
  81             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
  82             if(!isa_item_stash) {
  83                 /* if no stash, make a temporary fake MRO
  84                    containing just itself */
  85                 AV* const isa_lin = newAV();
  86                 av_push(isa_lin, newSVsv(isa_item));
  87                 av_push(seqs, MUTABLE_SV(isa_lin));
  88             }
  89             else {
  90                 /* recursion */
  91                 AV* const isa_lin
  92                   = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);
  93                 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
  94             }
  95         }
  96         av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
  97
  98         /* This builds "heads", which as an array of integer array
  99            indices, one per seq, which point at the virtual "head"
 100            of the seq (initially zero) */
 101         Newxz(heads, AvFILLp(seqs)+1, I32);
 102
 103         /* This builds %tails, which has one key for every class
 104            mentioned in the tail of any sequence in @seqs (tail meaning
 105            everything after the first class, the "head").  The value
 106            is how many times this key appears in the tails of @seqs.
 107         */
 108         seqs_ptr = AvARRAY(seqs);
 109         seqs_items = AvFILLp(seqs) + 1;
 110         while(seqs_items--) {
 111             AV *const seq = MUTABLE_AV(*seqs_ptr++);
 112             I32 seq_items = AvFILLp(seq);
 113             if(seq_items > 0) {
 114                 SV** seq_ptr = AvARRAY(seq) + 1;
 115                 while(seq_items--) {
 116                     SV* const seqitem = *seq_ptr++;
 117                     /* LVALUE fetch will create a new undefined SV if necessary
 118                      */
 119                     HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
 120                     if(he) {
 121                         SV* const val = HeVAL(he);
 122                         /* This will increment undef to 1, which is what we
 123                            want for a newly created entry.  */
 124                         sv_inc(val);
 125                     }
 126                 }
 127             }
 128         }
 129
 130         /* Initialize retval to build the return value in */
 131         retval = newAV();
 132         av_push(retval, newSVhek(stashhek)); /* us first */
 133
 134         /* This loop won't terminate until we either finish building
 135            the MRO, or get an exception. */
 136         while(1) {
 137             SV* cand = NULL;
 138             SV* winner = NULL;
 139             int s;
 140
 141             /* "foreach $seq (@seqs)" */
 142             SV** const avptr = AvARRAY(seqs);
 143             for(s = 0; s <= AvFILLp(seqs); s++) {
 144                 SV** svp;
 145                 AV * const seq = MUTABLE_AV(avptr[s]);
 146                 SV* seqhead;
 147                 if(!seq) continue; /* skip empty seqs */
 148                 svp = av_fetch(seq, heads[s], 0);
 149                 seqhead = *svp; /* seqhead = head of this seq */
 150                 if(!winner) {
 151                     HE* tail_entry;
 152                     SV* val;
 153                     /* if we haven't found a winner for this round yet,
 154                        and this seqhead is not in tails (or the count
 155                        for it in tails has dropped to zero), then this
 156                        seqhead is our new winner, and is added to the
 157                        final MRO immediately */
 158                     cand = seqhead;
 159                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
 160                        && (val = HeVAL(tail_entry))
 161                        && (SvIVX(val) > 0))
 162                            continue;
 163                     winner = newSVsv(cand);
 164                     av_push(retval, winner);
 165                     /* note however that even when we find a winner,
 166                        we continue looping over @seqs to do housekeeping */
 167                 }
 168                 if(!sv_cmp(seqhead, winner)) {
 169                     /* Once we have a winner (including the iteration
 170                        where we first found him), inc the head ptr
 171                        for any seq which had the winner as a head,
 172                        NULL out any seq which is now empty,
 173                        and adjust tails for consistency */
 174
 175                     const int new_head = ++heads[s];
 176                     if(new_head > AvFILLp(seq)) {
 177                         SvREFCNT_dec(avptr[s]);
 178                         avptr[s] = NULL;
 179                     }
 180                     else {
 181                         HE* tail_entry;
 182                         SV* val;
 183                         /* Because we know this new seqhead used to be
 184                            a tail, we can assume it is in tails and has
 185                            a positive value, which we need to dec */
 186                         svp = av_fetch(seq, new_head, 0);
 187                         seqhead = *svp;
 188                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
 189                         val = HeVAL(tail_entry);
 190                         sv_dec(val);
 191                     }
 192                 }
 193             }
 194
 195             /* if we found no candidates, we are done building the MRO.
 196                !cand means no seqs have any entries left to check */
 197             if(!cand) {
 198                 Safefree(heads);
 199                 break;
 200             }
 201
 202             /* If we had candidates, but nobody won, then the @ISA
 203                hierarchy is not C3-incompatible */
 204             if(!winner) {
 205                 /* we have to do some cleanup before we croak */
 206
 207                 SvREFCNT_dec(retval);
 208                 Safefree(heads);
 209
 210                 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
 211                     "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
 212             }
 213         }
 214     }
 215     else { /* @ISA was undefined or empty */
 216         /* build a retval containing only ourselves */
 217         retval = newAV();
 218         av_push(retval, newSVhek(stashhek));
 219     }
 220
 221     /* we don't want anyone modifying the cache entry but us,
 222        and we do so by replacing it completely */
 223     SvREADONLY_on(retval);
 224
 225     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
 226                                                 MUTABLE_SV(retval)));
 227 }
 228
 229
 230 /* These two are static helpers for next::method and friends,
 231    and re-implement a bunch of the code from pp_caller() in
 232    a more efficient manner for this particular usage.
 233 */
 234
 235 static I32
 236 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 237     I32 i;
 238     for (i = startingblock; i >= 0; i--) {
 239         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 240     }
 241     return i;
 242 }
 243
 244 MODULE = mro            PACKAGE = mro           PREFIX = mro_
 245
 246 void
 247 mro_get_linear_isa(...)
 248   PROTOTYPE: $;$
 249   PREINIT:
 250     AV* RETVAL;
 251     HV* class_stash;
 252     SV* classname;
 253   PPCODE:
 254     if(items < 1 || items > 2)
 255         croak_xs_usage(cv, "classname [, type ]");
 256
 257     classname = ST(0);
 258     class_stash = gv_stashsv(classname, 0);
 259
 260     if(!class_stash) {
 261         /* No stash exists yet, give them just the classname */
 262         AV* isalin = newAV();
 263         av_push(isalin, newSVsv(classname));
 264         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
 265         XSRETURN(1);
 266     }
 267     else if(items > 1) {
 268         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
 269         if (!algo)
 270             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
 271         RETVAL = algo->resolve(aTHX_ class_stash, 0);
 272     }
 273     else {
 274         RETVAL = mro_get_linear_isa(class_stash);
 275     }
 276     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
 277     sv_2mortal(ST(0));
 278     XSRETURN(1);
 279
 280 void
 281 mro_set_mro(...)
 282   PROTOTYPE: $$
 283   PREINIT:
 284     SV* classname;
 285     const struct mro_alg *which;
 286     HV* class_stash;
 287     struct mro_meta* meta;
 288   PPCODE:
 289     if (items != 2)
 290         croak_xs_usage(cv, "classname, type");
 291
 292     classname = ST(0);
 293     class_stash = gv_stashsv(classname, GV_ADD);
 294     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 295     meta = HvMROMETA(class_stash);
 296
 297     Perl_mro_set_mro(aTHX_ meta, ST(1));
 298
 299     XSRETURN_EMPTY;
 300
 301 void
 302 mro_get_mro(...)
 303   PROTOTYPE: $
 304   PREINIT:
 305     SV* classname;
 306     HV* class_stash;
 307   PPCODE:
 308     if (items != 1)
 309         croak_xs_usage(cv, "classname");
 310
 311     classname = ST(0);
 312     class_stash = gv_stashsv(classname, 0);
 313
 314     if (class_stash) {
 315         const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
 316         ST(0) = newSVpvn_flags(meta->name, meta->length,
 317                                SVs_TEMP
 318                                | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
 319     } else {
 320       ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
 321     }
 322     XSRETURN(1);
 323
 324 void
 325 mro_get_isarev(...)
 326   PROTOTYPE: $
 327   PREINIT:
 328     SV* classname;
 329     HE* he;
 330     HV* isarev;
 331     AV* ret_array;
 332   PPCODE:
 333     if (items != 1)
 334         croak_xs_usage(cv, "classname");
 335
 336     classname = ST(0);
 337
 338     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 339     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 340
 341     ret_array = newAV();
 342     if(isarev) {
 343         HE* iter;
 344         hv_iterinit(isarev);
 345         while((iter = hv_iternext(isarev)))
 346             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
 347     }
 348     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
 349
 350     PUTBACK;
 351
 352 void
 353 mro_is_universal(...)
 354   PROTOTYPE: $
 355   PREINIT:
 356     SV* classname;
 357     HV* isarev;
 358     char* classname_pv;
 359     STRLEN classname_len;
 360     HE* he;
 361   PPCODE:
 362     if (items != 1)
 363         croak_xs_usage(cv, "classname");
 364
 365     classname = ST(0);
 366
 367     classname_pv = SvPV(classname,classname_len);
 368
 369     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 370     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 371
 372     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 373         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 374         XSRETURN_YES;
 375     else
 376         XSRETURN_NO;
 377
 378
 379 void
 380 mro_invalidate_method_caches(...)
 381   PROTOTYPE:
 382   PPCODE:
 383     if (items != 0)
 384         croak_xs_usage(cv, "");
 385
 386     PL_sub_generation++;
 387
 388     XSRETURN_EMPTY;
 389
 390 void
 391 mro_get_pkg_gen(...)
 392   PROTOTYPE: $
 393   PREINIT:
 394     SV* classname;
 395     HV* class_stash;
 396   PPCODE:
 397     if(items != 1)
 398         croak_xs_usage(cv, "classname");
 399
 400     classname = ST(0);
 401
 402     class_stash = gv_stashsv(classname, 0);
 403
 404     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
 405
 406     PUTBACK;
 407
 408 void
 409 mro__nextcan(...)
 410   PREINIT:
 411     SV* self = ST(0);
 412     const I32 throw_nomethod = SvIVX(ST(1));
 413     register I32 cxix = cxstack_ix;
 414     register const PERL_CONTEXT *ccstack = cxstack;
 415     const PERL_SI *top_si = PL_curstackinfo;
 416     HV* selfstash;
 417     SV *stashname;
 418     const char *fq_subname;
 419     const char *subname;
 420     STRLEN stashname_len;
 421     STRLEN subname_len;
 422     SV* sv;
 423     GV** gvp;
 424     AV* linear_av;
 425     SV** linear_svp;
 426     const char *hvname;
 427     I32 entries;
 428     struct mro_meta* selfmeta;
 429     HV* nmcache;
 430     I32 i;
 431   PPCODE:
 432     PERL_UNUSED_ARG(cv);
 433
 434     if(sv_isobject(self))
 435         selfstash = SvSTASH(SvRV(self));
 436     else
 437         selfstash = gv_stashsv(self, GV_ADD);
 438
 439     assert(selfstash);
 440
 441     hvname = HvNAME_get(selfstash);
 442     if (!hvname)
 443         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 444
 445     /* This block finds the contextually-enclosing fully-qualified subname,
 446        much like looking at (caller($i))[3] until you find a real sub that
 447        isn't ANON, etc (also skips over pureperl next::method, etc) */
 448     for(i = 0; i < 2; i++) {
 449         cxix = __dopoptosub_at(ccstack, cxix);
 450         for (;;) {
 451             GV* cvgv;
 452             STRLEN fq_subname_len;
 453
 454             /* we may be in a higher stacklevel, so dig down deeper */
 455             while (cxix < 0) {
 456                 if(top_si->si_type == PERLSI_MAIN)
 457                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 458                 top_si = top_si->si_prev;
 459                 ccstack = top_si->si_cxstack;
 460                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 461             }
 462
 463             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 464               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 465                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 466                 continue;
 467             }
 468
 469             {
 470                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 471                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 472                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 473                         cxix = dbcxix;
 474                         continue;
 475                     }
 476                 }
 477             }
 478
 479             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 480
 481             if(!isGV(cvgv)) {
 482                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 483                 continue;
 484             }
 485
 486             /* we found a real sub here */
 487             sv = sv_2mortal(newSV(0));
 488
 489             gv_efullname3(sv, cvgv, NULL);
 490
 491             fq_subname = SvPVX(sv);
 492             fq_subname_len = SvCUR(sv);
 493
 494             subname = strrchr(fq_subname, ':');
 495             if(!subname)
 496                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 497
 498             subname++;
 499             subname_len = fq_subname_len - (subname - fq_subname);
 500             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 501                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 502                 continue;
 503             }
 504             break;
 505         }
 506         cxix--;
 507     }
 508
 509     /* If we made it to here, we found our context */
 510
 511     /* Initialize the next::method cache for this stash
 512        if necessary */
 513     selfmeta = HvMROMETA(selfstash);
 514     if(!(nmcache = selfmeta->mro_nextmethod)) {
 515         nmcache = selfmeta->mro_nextmethod = newHV();
 516     }
 517     else { /* Use the cached coderef if it exists */
 518         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
 519         if (cache_entry) {
 520             SV* const val = HeVAL(cache_entry);
 521             if(val == &PL_sv_undef) {
 522                 if(throw_nomethod)
 523                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 524                 XSRETURN_EMPTY;
 525             }
 526             mXPUSHs(newRV_inc(val));
 527             XSRETURN(1);
 528         }
 529     }
 530
 531     /* beyond here is just for cache misses, so perf isn't as critical */
 532
 533     stashname_len = subname - fq_subname - 2;
 534     stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
 535
 536     /* has ourselves at the top of the list */
 537     linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
 538
 539     linear_svp = AvARRAY(linear_av);
 540     entries = AvFILLp(linear_av) + 1;
 541
 542     /* Walk down our MRO, skipping everything up
 543        to the contextually enclosing class */
 544     while (entries--) {
 545         SV * const linear_sv = *linear_svp++;
 546         assert(linear_sv);
 547         if(sv_eq(linear_sv, stashname))
 548             break;
 549     }
 550
 551     /* Now search the remainder of the MRO for the
 552        same method name as the contextually enclosing
 553        method */
 554     if(entries > 0) {
 555         while (entries--) {
 556             SV * const linear_sv = *linear_svp++;
 557             HV* curstash;
 558             GV* candidate;
 559             CV* cand_cv;
 560
 561             assert(linear_sv);
 562             curstash = gv_stashsv(linear_sv, FALSE);
 563
 564             if (!curstash) {
 565                 if (ckWARN(WARN_SYNTAX))
 566                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 567                         (void*)linear_sv, hvname);
 568                 continue;
 569             }
 570
 571             assert(curstash);
 572
 573             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
 574             if (!gvp) continue;
 575
 576             candidate = *gvp;
 577             assert(candidate);
 578
 579             if (SvTYPE(candidate) != SVt_PVGV)
 580                 gv_init(candidate, curstash, subname, subname_len, TRUE);
 581
 582             /* Notably, we only look for real entries, not method cache
 583                entries, because in C3 the method cache of a parent is not
 584                valid for the child */
 585             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 586                 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
 587                 (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
 588                 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
 589                 XSRETURN(1);
 590             }
 591         }
 592     }
 593
 594     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
 595     if(throw_nomethod)
 596         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 597     XSRETURN_EMPTY;
 598
 599 BOOT:
 600     Perl_mro_register(aTHX_ &c3_alg);