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) {
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);
94 if(items == 0 && AvFILLp(seqs) == -1) {
95 /* Only one parent class. For this case, the C3
96 linearisation is this class followed by the parent's
97 inearisation, so don't bother with the expensive
100 I32 subrv_items = AvFILLp(isa_lin) + 1;
101 SV *const *subrv_p = AvARRAY(isa_lin);
103 /* Hijack the allocated but unused array seqs to be the
104 return value. It's currently mortalised. */
108 av_extend(retval, subrv_items);
109 AvFILLp(retval) = subrv_items;
110 svp = AvARRAY(retval);
112 /* First entry is this class. We happen to make a shared
113 hash key scalar because it's the cheapest and fastest
115 *svp++ = newSVhek(stashhek);
117 while(subrv_items--) {
118 /* These values are unlikely to be shared hash key
119 scalars, so no point in adding code to optimising
120 for a case that is unlikely to be true.
121 (Or prove me wrong and do it.) */
123 SV *const val = *subrv_p++;
124 *svp++ = newSVsv(val);
127 SvREFCNT_inc(retval);
131 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
134 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
135 tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
137 /* This builds "heads", which as an array of integer array
138 indices, one per seq, which point at the virtual "head"
139 of the seq (initially zero) */
140 Newxz(heads, AvFILLp(seqs)+1, I32);
142 /* This builds %tails, which has one key for every class
143 mentioned in the tail of any sequence in @seqs (tail meaning
144 everything after the first class, the "head"). The value
145 is how many times this key appears in the tails of @seqs.
147 seqs_ptr = AvARRAY(seqs);
148 seqs_items = AvFILLp(seqs) + 1;
149 while(seqs_items--) {
150 AV *const seq = MUTABLE_AV(*seqs_ptr++);
151 I32 seq_items = AvFILLp(seq);
153 SV** seq_ptr = AvARRAY(seq) + 1;
155 SV* const seqitem = *seq_ptr++;
156 /* LVALUE fetch will create a new undefined SV if necessary
158 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
160 SV* const val = HeVAL(he);
161 /* For 5.8.0 and later, sv_inc() with increment undef to
162 an IV of 1, which is what we want for a newly created
163 entry. However, for 5.6.x it will become an NV of
164 1.0, which confuses the SvIVX() checks above. */
166 SvIV_set(val, SvIVX(val) + 1);
175 /* Initialize retval to build the return value in */
177 av_push(retval, newSVhek(stashhek)); /* us first */
179 /* This loop won't terminate until we either finish building
180 the MRO, or get an exception. */
186 /* "foreach $seq (@seqs)" */
187 SV** const avptr = AvARRAY(seqs);
188 for(s = 0; s <= AvFILLp(seqs); s++) {
190 AV * const seq = MUTABLE_AV(avptr[s]);
192 if(!seq) continue; /* skip empty seqs */
193 svp = av_fetch(seq, heads[s], 0);
194 seqhead = *svp; /* seqhead = head of this seq */
198 /* if we haven't found a winner for this round yet,
199 and this seqhead is not in tails (or the count
200 for it in tails has dropped to zero), then this
201 seqhead is our new winner, and is added to the
202 final MRO immediately */
204 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
205 && (val = HeVAL(tail_entry))
208 winner = newSVsv(cand);
209 av_push(retval, winner);
210 /* note however that even when we find a winner,
211 we continue looping over @seqs to do housekeeping */
213 if(!sv_cmp(seqhead, winner)) {
214 /* Once we have a winner (including the iteration
215 where we first found him), inc the head ptr
216 for any seq which had the winner as a head,
217 NULL out any seq which is now empty,
218 and adjust tails for consistency */
220 const int new_head = ++heads[s];
221 if(new_head > AvFILLp(seq)) {
222 SvREFCNT_dec(avptr[s]);
228 /* Because we know this new seqhead used to be
229 a tail, we can assume it is in tails and has
230 a positive value, which we need to dec */
231 svp = av_fetch(seq, new_head, 0);
233 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
234 val = HeVAL(tail_entry);
240 /* if we found no candidates, we are done building the MRO.
241 !cand means no seqs have any entries left to check */
247 /* If we had candidates, but nobody won, then the @ISA
248 hierarchy is not C3-incompatible */
253 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
254 "current merge results [\n", HEK_KEY(stashhek));
255 for (i = 0; i <= av_len(retval); i++) {
256 SV **elem = av_fetch(retval, i, 0);
257 sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
259 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
261 /* we have to do some cleanup before we croak */
263 SvREFCNT_dec(retval);
266 Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
270 else { /* @ISA was undefined or empty */
271 /* build a retval containing only ourselves */
273 av_push(retval, newSVhek(stashhek));
277 /* we don't want anyone modifying the cache entry but us,
278 and we do so by replacing it completely */
279 SvREADONLY_on(retval);
281 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
282 MUTABLE_SV(retval)));
286 /* These two are static helpers for next::method and friends,
287 and re-implement a bunch of the code from pp_caller() in
288 a more efficient manner for this particular usage.
292 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
294 for (i = startingblock; i >= 0; i--) {
295 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
300 MODULE = mro PACKAGE = mro PREFIX = mro_
303 mro_get_linear_isa(...)
310 if(items < 1 || items > 2)
311 croak_xs_usage(cv, "classname [, type ]");
314 class_stash = gv_stashsv(classname, 0);
317 /* No stash exists yet, give them just the classname */
318 AV* isalin = newAV();
319 av_push(isalin, newSVsv(classname));
320 ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
324 const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
326 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
327 RETVAL = algo->resolve(aTHX_ class_stash, 0);
330 RETVAL = mro_get_linear_isa(class_stash);
332 ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
342 struct mro_meta* meta;
345 croak_xs_usage(cv, "classname, type");
348 class_stash = gv_stashsv(classname, GV_ADD);
349 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
350 meta = HvMROMETA(class_stash);
352 Perl_mro_set_mro(aTHX_ meta, ST(1));
364 croak_xs_usage(cv, "classname");
367 class_stash = gv_stashsv(classname, 0);
370 const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
371 ST(0) = newSVpvn_flags(meta->name, meta->length,
373 | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
375 ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
389 croak_xs_usage(cv, "classname");
393 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
394 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
400 while((iter = hv_iternext(isarev)))
401 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
403 mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
408 mro_is_universal(...)
414 STRLEN classname_len;
418 croak_xs_usage(cv, "classname");
422 classname_pv = SvPV(classname,classname_len);
424 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
425 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
427 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
428 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
435 mro_invalidate_all_method_caches(...)
439 croak_xs_usage(cv, "");
453 croak_xs_usage(cv, "classname");
457 class_stash = gv_stashsv(classname, 0);
459 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
467 const I32 throw_nomethod = SvIVX(ST(1));
468 register I32 cxix = cxstack_ix;
469 register const PERL_CONTEXT *ccstack = cxstack;
470 const PERL_SI *top_si = PL_curstackinfo;
473 const char *fq_subname;
475 STRLEN stashname_len;
483 struct mro_meta* selfmeta;
489 if(sv_isobject(self))
490 selfstash = SvSTASH(SvRV(self));
492 selfstash = gv_stashsv(self, GV_ADD);
496 hvname = HvNAME_get(selfstash);
498 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
500 /* This block finds the contextually-enclosing fully-qualified subname,
501 much like looking at (caller($i))[3] until you find a real sub that
502 isn't ANON, etc (also skips over pureperl next::method, etc) */
503 for(i = 0; i < 2; i++) {
504 cxix = __dopoptosub_at(ccstack, cxix);
507 STRLEN fq_subname_len;
509 /* we may be in a higher stacklevel, so dig down deeper */
511 if(top_si->si_type == PERLSI_MAIN)
512 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
513 top_si = top_si->si_prev;
514 ccstack = top_si->si_cxstack;
515 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
518 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
519 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
520 cxix = __dopoptosub_at(ccstack, cxix - 1);
525 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
526 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
527 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
534 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
537 cxix = __dopoptosub_at(ccstack, cxix - 1);
541 /* we found a real sub here */
544 gv_efullname3(sv, cvgv, NULL);
547 fq_subname = SvPVX(sv);
548 fq_subname_len = SvCUR(sv);
550 subname = strrchr(fq_subname, ':');
556 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
559 subname_len = fq_subname_len - (subname - fq_subname);
560 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
561 cxix = __dopoptosub_at(ccstack, cxix - 1);
569 /* If we made it to here, we found our context */
571 /* Initialize the next::method cache for this stash
573 selfmeta = HvMROMETA(selfstash);
574 if(!(nmcache = selfmeta->mro_nextmethod)) {
575 nmcache = selfmeta->mro_nextmethod = newHV();
577 else { /* Use the cached coderef if it exists */
578 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
580 SV* const val = HeVAL(cache_entry);
581 if(val == &PL_sv_undef) {
583 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
586 mXPUSHs(newRV_inc(val));
591 /* beyond here is just for cache misses, so perf isn't as critical */
593 stashname_len = subname - fq_subname - 2;
594 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
596 /* has ourselves at the top of the list */
597 linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
599 linear_svp = AvARRAY(linear_av);
600 entries = AvFILLp(linear_av) + 1;
602 /* Walk down our MRO, skipping everything up
603 to the contextually enclosing class */
605 SV * const linear_sv = *linear_svp++;
607 if(sv_eq(linear_sv, stashname))
611 /* Now search the remainder of the MRO for the
612 same method name as the contextually enclosing
616 SV * const linear_sv = *linear_svp++;
622 curstash = gv_stashsv(linear_sv, FALSE);
625 if (ckWARN(WARN_SYNTAX))
626 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
627 (void*)linear_sv, hvname);
633 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
639 if (SvTYPE(candidate) != SVt_PVGV)
640 gv_init(candidate, curstash, subname, subname_len, TRUE);
642 /* Notably, we only look for real entries, not method cache
643 entries, because in C3 the method cache of a parent is not
644 valid for the child */
645 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
646 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
647 (void)hv_store_ent(nmcache, sv, MUTABLE_SV(cand_cv), 0);
648 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
654 (void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0);
656 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
660 Perl_mro_register(aTHX_ &c3_alg);