6 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
8 static const struct mro_alg c3_alg =
9 {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
12 =for apidoc mro_get_linear_isa_c3
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).
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
29 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
36 struct mro_meta* meta;
40 stashhek = HvNAME_HEK(stash);
42 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
45 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
48 meta = HvMROMETA(stash);
50 /* return cache if valid */
51 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
55 /* not in cache, make a new one */
57 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
58 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
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)
66 if(isa && AvFILLp(isa) >= 0) {
69 HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
70 AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
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.
77 I32 items = AvFILLp(isa) + 1;
78 SV** isa_ptr = AvARRAY(isa);
80 SV* const isa_item = *isa_ptr++;
81 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
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));
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)));
96 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
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);
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.
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);
114 SV** seq_ptr = AvARRAY(seq) + 1;
116 SV* const seqitem = *seq_ptr++;
117 /* LVALUE fetch will create a new undefined SV if necessary
119 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
121 SV* const val = HeVAL(he);
122 /* This will increment undef to 1, which is what we
123 want for a newly created entry. */
130 /* Initialize retval to build the return value in */
132 av_push(retval, newSVhek(stashhek)); /* us first */
134 /* This loop won't terminate until we either finish building
135 the MRO, or get an exception. */
141 /* "foreach $seq (@seqs)" */
142 SV** const avptr = AvARRAY(seqs);
143 for(s = 0; s <= AvFILLp(seqs); s++) {
145 AV * const seq = MUTABLE_AV(avptr[s]);
147 if(!seq) continue; /* skip empty seqs */
148 svp = av_fetch(seq, heads[s], 0);
149 seqhead = *svp; /* seqhead = head of this seq */
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 */
159 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
160 && (val = HeVAL(tail_entry))
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 */
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 */
175 const int new_head = ++heads[s];
176 if(new_head > AvFILLp(seq)) {
177 SvREFCNT_dec(avptr[s]);
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);
188 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
189 val = HeVAL(tail_entry);
195 /* if we found no candidates, we are done building the MRO.
196 !cand means no seqs have any entries left to check */
202 /* If we had candidates, but nobody won, then the @ISA
203 hierarchy is not C3-incompatible */
205 /* we have to do some cleanup before we croak */
207 SvREFCNT_dec(retval);
210 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
211 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
215 else { /* @ISA was undefined or empty */
216 /* build a retval containing only ourselves */
218 av_push(retval, newSVhek(stashhek));
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);
225 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
226 MUTABLE_SV(retval)));
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.
237 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
239 for (i = startingblock; i >= 0; i--) {
240 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
245 MODULE = mro PACKAGE = mro PREFIX = mro
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;
257 const char *fq_subname;
259 STRLEN stashname_len;
267 struct mro_meta* selfmeta;
273 if(sv_isobject(self))
274 selfstash = SvSTASH(SvRV(self));
276 selfstash = gv_stashsv(self, GV_ADD);
280 hvname = HvNAME_get(selfstash);
282 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
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);
291 STRLEN fq_subname_len;
293 /* we may be in a higher stacklevel, so dig down deeper */
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);
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);
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) {
318 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
321 cxix = __dopoptosub_at(ccstack, cxix - 1);
325 /* we found a real sub here */
326 sv = sv_2mortal(newSV(0));
328 gv_efullname3(sv, cvgv, NULL);
330 fq_subname = SvPVX(sv);
331 fq_subname_len = SvCUR(sv);
333 subname = strrchr(fq_subname, ':');
335 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
338 subname_len = fq_subname_len - (subname - fq_subname);
339 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
340 cxix = __dopoptosub_at(ccstack, cxix - 1);
348 /* If we made it to here, we found our context */
350 /* Initialize the next::method cache for this stash
352 selfmeta = HvMROMETA(selfstash);
353 if(!(nmcache = selfmeta->mro_nextmethod)) {
354 nmcache = selfmeta->mro_nextmethod = newHV();
356 else { /* Use the cached coderef if it exists */
357 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
359 SV* const val = HeVAL(cache_entry);
360 if(val == &PL_sv_undef) {
362 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
365 mXPUSHs(newRV_inc(val));
370 /* beyond here is just for cache misses, so perf isn't as critical */
372 stashname_len = subname - fq_subname - 2;
373 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
375 /* has ourselves at the top of the list */
376 linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
378 linear_svp = AvARRAY(linear_av);
379 entries = AvFILLp(linear_av) + 1;
381 /* Walk down our MRO, skipping everything up
382 to the contextually enclosing class */
384 SV * const linear_sv = *linear_svp++;
386 if(sv_eq(linear_sv, stashname))
390 /* Now search the remainder of the MRO for the
391 same method name as the contextually enclosing
395 SV * const linear_sv = *linear_svp++;
401 curstash = gv_stashsv(linear_sv, FALSE);
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);
412 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
418 if (SvTYPE(candidate) != SVt_PVGV)
419 gv_init(candidate, curstash, subname, subname_len, TRUE);
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)));
433 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
435 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
439 Perl_mro_register(aTHX_ &c3_alg);