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