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                 SV *errmsg;
 206                 I32 i;
 207
 208                 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
 209                                   "current merge results [\n", HEK_KEY(stashhek));
 210                 for (i = 0; i <= av_len(retval); i++) {
 211                     SV **elem = av_fetch(retval, i, 0);
 212                     sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
 213                 }
 214                 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
 215
 216                 /* we have to do some cleanup before we croak */
 217
 218                 SvREFCNT_dec(retval);
 219                 Safefree(heads);
 220
 221                 Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
 222             }
 223         }
 224     }
 225     else { /* @ISA was undefined or empty */
 226         /* build a retval containing only ourselves */
 227         retval = newAV();
 228         av_push(retval, newSVhek(stashhek));
 229     }
 230
 231     /* we don't want anyone modifying the cache entry but us,
 232        and we do so by replacing it completely */
 233     SvREADONLY_on(retval);
 234
 235     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
 236                                                 MUTABLE_SV(retval)));
 237 }
 238
 239
 240 /* These two are static helpers for next::method and friends,
 241    and re-implement a bunch of the code from pp_caller() in
 242    a more efficient manner for this particular usage.
 243 */
 244
 245 static I32
 246 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
 247     I32 i;
 248     for (i = startingblock; i >= 0; i--) {
 249         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
 250     }
 251     return i;
 252 }
 253
 254 MODULE = mro            PACKAGE = mro           PREFIX = mro_
 255
 256 void
 257 mro_get_linear_isa(...)
 258   PROTOTYPE: $;$
 259   PREINIT:
 260     AV* RETVAL;
 261     HV* class_stash;
 262     SV* classname;
 263   PPCODE:
 264     if(items < 1 || items > 2)
 265         croak_xs_usage(cv, "classname [, type ]");
 266
 267     classname = ST(0);
 268     class_stash = gv_stashsv(classname, 0);
 269
 270     if(!class_stash) {
 271         /* No stash exists yet, give them just the classname */
 272         AV* isalin = newAV();
 273         av_push(isalin, newSVsv(classname));
 274         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
 275         XSRETURN(1);
 276     }
 277     else if(items > 1) {
 278         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
 279         if (!algo)
 280             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
 281         RETVAL = algo->resolve(aTHX_ class_stash, 0);
 282     }
 283     else {
 284         RETVAL = mro_get_linear_isa(class_stash);
 285     }
 286     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
 287     sv_2mortal(ST(0));
 288     XSRETURN(1);
 289
 290 void
 291 mro_set_mro(...)
 292   PROTOTYPE: $$
 293   PREINIT:
 294     SV* classname;
 295     HV* class_stash;
 296     struct mro_meta* meta;
 297   PPCODE:
 298     if (items != 2)
 299         croak_xs_usage(cv, "classname, type");
 300
 301     classname = ST(0);
 302     class_stash = gv_stashsv(classname, GV_ADD);
 303     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
 304     meta = HvMROMETA(class_stash);
 305
 306     Perl_mro_set_mro(aTHX_ meta, ST(1));
 307
 308     XSRETURN_EMPTY;
 309
 310 void
 311 mro_get_mro(...)
 312   PROTOTYPE: $
 313   PREINIT:
 314     SV* classname;
 315     HV* class_stash;
 316   PPCODE:
 317     if (items != 1)
 318         croak_xs_usage(cv, "classname");
 319
 320     classname = ST(0);
 321     class_stash = gv_stashsv(classname, 0);
 322
 323     if (class_stash) {
 324         const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
 325         ST(0) = newSVpvn_flags(meta->name, meta->length,
 326                                SVs_TEMP
 327                                | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
 328     } else {
 329       ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
 330     }
 331     XSRETURN(1);
 332
 333 void
 334 mro_get_isarev(...)
 335   PROTOTYPE: $
 336   PREINIT:
 337     SV* classname;
 338     HE* he;
 339     HV* isarev;
 340     AV* ret_array;
 341   PPCODE:
 342     if (items != 1)
 343         croak_xs_usage(cv, "classname");
 344
 345     classname = ST(0);
 346
 347     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 348     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 349
 350     ret_array = newAV();
 351     if(isarev) {
 352         HE* iter;
 353         hv_iterinit(isarev);
 354         while((iter = hv_iternext(isarev)))
 355             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
 356     }
 357     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
 358
 359     PUTBACK;
 360
 361 void
 362 mro_is_universal(...)
 363   PROTOTYPE: $
 364   PREINIT:
 365     SV* classname;
 366     HV* isarev;
 367     char* classname_pv;
 368     STRLEN classname_len;
 369     HE* he;
 370   PPCODE:
 371     if (items != 1)
 372         croak_xs_usage(cv, "classname");
 373
 374     classname = ST(0);
 375
 376     classname_pv = SvPV(classname,classname_len);
 377
 378     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
 379     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
 380
 381     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
 382         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
 383         XSRETURN_YES;
 384     else
 385         XSRETURN_NO;
 386
 387
 388 void
 389 mro_invalidate_all_method_caches(...)
 390   PROTOTYPE:
 391   PPCODE:
 392     if (items != 0)
 393         croak_xs_usage(cv, "");
 394
 395     PL_sub_generation++;
 396
 397     XSRETURN_EMPTY;
 398
 399 void
 400 mro_get_pkg_gen(...)
 401   PROTOTYPE: $
 402   PREINIT:
 403     SV* classname;
 404     HV* class_stash;
 405   PPCODE:
 406     if(items != 1)
 407         croak_xs_usage(cv, "classname");
 408
 409     classname = ST(0);
 410
 411     class_stash = gv_stashsv(classname, 0);
 412
 413     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
 414
 415     PUTBACK;
 416
 417 void
 418 mro__nextcan(...)
 419   PREINIT:
 420     SV* self = ST(0);
 421     const I32 throw_nomethod = SvIVX(ST(1));
 422     register I32 cxix = cxstack_ix;
 423     register const PERL_CONTEXT *ccstack = cxstack;
 424     const PERL_SI *top_si = PL_curstackinfo;
 425     HV* selfstash;
 426     SV *stashname;
 427     const char *fq_subname;
 428     const char *subname;
 429     STRLEN stashname_len;
 430     STRLEN subname_len;
 431     SV* sv;
 432     GV** gvp;
 433     AV* linear_av;
 434     SV** linear_svp;
 435     const char *hvname;
 436     I32 entries;
 437     struct mro_meta* selfmeta;
 438     HV* nmcache;
 439     I32 i;
 440   PPCODE:
 441     PERL_UNUSED_ARG(cv);
 442
 443     if(sv_isobject(self))
 444         selfstash = SvSTASH(SvRV(self));
 445     else
 446         selfstash = gv_stashsv(self, GV_ADD);
 447
 448     assert(selfstash);
 449
 450     hvname = HvNAME_get(selfstash);
 451     if (!hvname)
 452         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 453
 454     /* This block finds the contextually-enclosing fully-qualified subname,
 455        much like looking at (caller($i))[3] until you find a real sub that
 456        isn't ANON, etc (also skips over pureperl next::method, etc) */
 457     for(i = 0; i < 2; i++) {
 458         cxix = __dopoptosub_at(ccstack, cxix);
 459         for (;;) {
 460             GV* cvgv;
 461             STRLEN fq_subname_len;
 462
 463             /* we may be in a higher stacklevel, so dig down deeper */
 464             while (cxix < 0) {
 465                 if(top_si->si_type == PERLSI_MAIN)
 466                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 467                 top_si = top_si->si_prev;
 468                 ccstack = top_si->si_cxstack;
 469                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 470             }
 471
 472             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 473               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 474                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 475                 continue;
 476             }
 477
 478             {
 479                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 480                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 481                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 482                         cxix = dbcxix;
 483                         continue;
 484                     }
 485                 }
 486             }
 487
 488             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 489
 490             if(!isGV(cvgv)) {
 491                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 492                 continue;
 493             }
 494
 495             /* we found a real sub here */
 496             sv = sv_2mortal(newSV(0));
 497
 498             gv_efullname3(sv, cvgv, NULL);
 499
 500             fq_subname = SvPVX(sv);
 501             fq_subname_len = SvCUR(sv);
 502
 503             subname = strrchr(fq_subname, ':');
 504             if(!subname)
 505                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 506
 507             subname++;
 508             subname_len = fq_subname_len - (subname - fq_subname);
 509             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 510                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 511                 continue;
 512             }
 513             break;
 514         }
 515         cxix--;
 516     }
 517
 518     /* If we made it to here, we found our context */
 519
 520     /* Initialize the next::method cache for this stash
 521        if necessary */
 522     selfmeta = HvMROMETA(selfstash);
 523     if(!(nmcache = selfmeta->mro_nextmethod)) {
 524         nmcache = selfmeta->mro_nextmethod = newHV();
 525     }
 526     else { /* Use the cached coderef if it exists */
 527         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
 528         if (cache_entry) {
 529             SV* const val = HeVAL(cache_entry);
 530             if(val == &PL_sv_undef) {
 531                 if(throw_nomethod)
 532                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 533                 XSRETURN_EMPTY;
 534             }
 535             mXPUSHs(newRV_inc(val));
 536             XSRETURN(1);
 537         }
 538     }
 539
 540     /* beyond here is just for cache misses, so perf isn't as critical */
 541
 542     stashname_len = subname - fq_subname - 2;
 543     stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
 544
 545     /* has ourselves at the top of the list */
 546     linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
 547
 548     linear_svp = AvARRAY(linear_av);
 549     entries = AvFILLp(linear_av) + 1;
 550
 551     /* Walk down our MRO, skipping everything up
 552        to the contextually enclosing class */
 553     while (entries--) {
 554         SV * const linear_sv = *linear_svp++;
 555         assert(linear_sv);
 556         if(sv_eq(linear_sv, stashname))
 557             break;
 558     }
 559
 560     /* Now search the remainder of the MRO for the
 561        same method name as the contextually enclosing
 562        method */
 563     if(entries > 0) {
 564         while (entries--) {
 565             SV * const linear_sv = *linear_svp++;
 566             HV* curstash;
 567             GV* candidate;
 568             CV* cand_cv;
 569
 570             assert(linear_sv);
 571             curstash = gv_stashsv(linear_sv, FALSE);
 572
 573             if (!curstash) {
 574                 if (ckWARN(WARN_SYNTAX))
 575                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 576                         (void*)linear_sv, hvname);
 577                 continue;
 578             }
 579
 580             assert(curstash);
 581
 582             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
 583             if (!gvp) continue;
 584
 585             candidate = *gvp;
 586             assert(candidate);
 587
 588             if (SvTYPE(candidate) != SVt_PVGV)
 589                 gv_init(candidate, curstash, subname, subname_len, TRUE);
 590
 591             /* Notably, we only look for real entries, not method cache
 592                entries, because in C3 the method cache of a parent is not
 593                valid for the child */
 594             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 595                 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
 596                 (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
 597                 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
 598                 XSRETURN(1);
 599             }
 600         }
 601     }
 602
 603     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
 604     if(throw_nomethod)
 605         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 606     XSRETURN_EMPTY;
 607
 608 BOOT:
 609     Perl_mro_register(aTHX_ &c3_alg);