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_nextcan(...)
 249   PREINIT:
 250     SV* self = ST(0);
 251     const I32 throw_nomethod = SvIVX(ST(1));
 252     register I32 cxix = cxstack_ix;
 253     register const PERL_CONTEXT *ccstack = cxstack;
 254     const PERL_SI *top_si = PL_curstackinfo;
 255     HV* selfstash;
 256     SV *stashname;
 257     const char *fq_subname;
 258     const char *subname;
 259     STRLEN stashname_len;
 260     STRLEN subname_len;
 261     SV* sv;
 262     GV** gvp;
 263     AV* linear_av;
 264     SV** linear_svp;
 265     const char *hvname;
 266     I32 entries;
 267     struct mro_meta* selfmeta;
 268     HV* nmcache;
 269     I32 i;
 270   PPCODE:
 271     PERL_UNUSED_ARG(cv);
 272
 273     if(sv_isobject(self))
 274         selfstash = SvSTASH(SvRV(self));
 275     else
 276         selfstash = gv_stashsv(self, GV_ADD);
 277
 278     assert(selfstash);
 279
 280     hvname = HvNAME_get(selfstash);
 281     if (!hvname)
 282         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
 283
 284     /* This block finds the contextually-enclosing fully-qualified subname,
 285        much like looking at (caller($i))[3] until you find a real sub that
 286        isn't ANON, etc (also skips over pureperl next::method, etc) */
 287     for(i = 0; i < 2; i++) {
 288         cxix = __dopoptosub_at(ccstack, cxix);
 289         for (;;) {
 290             GV* cvgv;
 291             STRLEN fq_subname_len;
 292
 293             /* we may be in a higher stacklevel, so dig down deeper */
 294             while (cxix < 0) {
 295                 if(top_si->si_type == PERLSI_MAIN)
 296                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
 297                 top_si = top_si->si_prev;
 298                 ccstack = top_si->si_cxstack;
 299                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
 300             }
 301
 302             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
 303               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
 304                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 305                 continue;
 306             }
 307
 308             {
 309                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
 310                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
 311                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
 312                         cxix = dbcxix;
 313                         continue;
 314                     }
 315                 }
 316             }
 317
 318             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
 319
 320             if(!isGV(cvgv)) {
 321                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 322                 continue;
 323             }
 324
 325             /* we found a real sub here */
 326             sv = sv_2mortal(newSV(0));
 327
 328             gv_efullname3(sv, cvgv, NULL);
 329
 330             fq_subname = SvPVX(sv);
 331             fq_subname_len = SvCUR(sv);
 332
 333             subname = strrchr(fq_subname, ':');
 334             if(!subname)
 335                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
 336
 337             subname++;
 338             subname_len = fq_subname_len - (subname - fq_subname);
 339             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
 340                 cxix = __dopoptosub_at(ccstack, cxix - 1);
 341                 continue;
 342             }
 343             break;
 344         }
 345         cxix--;
 346     }
 347
 348     /* If we made it to here, we found our context */
 349
 350     /* Initialize the next::method cache for this stash
 351        if necessary */
 352     selfmeta = HvMROMETA(selfstash);
 353     if(!(nmcache = selfmeta->mro_nextmethod)) {
 354         nmcache = selfmeta->mro_nextmethod = newHV();
 355     }
 356     else { /* Use the cached coderef if it exists */
 357         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
 358         if (cache_entry) {
 359             SV* const val = HeVAL(cache_entry);
 360             if(val == &PL_sv_undef) {
 361                 if(throw_nomethod)
 362                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 363                 XSRETURN_EMPTY;
 364             }
 365             mXPUSHs(newRV_inc(val));
 366             XSRETURN(1);
 367         }
 368     }
 369
 370     /* beyond here is just for cache misses, so perf isn't as critical */
 371
 372     stashname_len = subname - fq_subname - 2;
 373     stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
 374
 375     /* has ourselves at the top of the list */
 376     linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
 377
 378     linear_svp = AvARRAY(linear_av);
 379     entries = AvFILLp(linear_av) + 1;
 380
 381     /* Walk down our MRO, skipping everything up
 382        to the contextually enclosing class */
 383     while (entries--) {
 384         SV * const linear_sv = *linear_svp++;
 385         assert(linear_sv);
 386         if(sv_eq(linear_sv, stashname))
 387             break;
 388     }
 389
 390     /* Now search the remainder of the MRO for the
 391        same method name as the contextually enclosing
 392        method */
 393     if(entries > 0) {
 394         while (entries--) {
 395             SV * const linear_sv = *linear_svp++;
 396             HV* curstash;
 397             GV* candidate;
 398             CV* cand_cv;
 399
 400             assert(linear_sv);
 401             curstash = gv_stashsv(linear_sv, FALSE);
 402
 403             if (!curstash) {
 404                 if (ckWARN(WARN_SYNTAX))
 405                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
 406                         (void*)linear_sv, hvname);
 407                 continue;
 408             }
 409
 410             assert(curstash);
 411
 412             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
 413             if (!gvp) continue;
 414
 415             candidate = *gvp;
 416             assert(candidate);
 417
 418             if (SvTYPE(candidate) != SVt_PVGV)
 419                 gv_init(candidate, curstash, subname, subname_len, TRUE);
 420
 421             /* Notably, we only look for real entries, not method cache
 422                entries, because in C3 the method cache of a parent is not
 423                valid for the child */
 424             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
 425                 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
 426                 (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
 427                 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
 428                 XSRETURN(1);
 429             }
 430         }
 431     }
 432
 433     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
 434     if(throw_nomethod)
 435         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
 436     XSRETURN_EMPTY;
 437
 438 BOOT:
 439     Perl_mro_register(aTHX_ &c3_alg);