3 * Copyright (c) 2007 Brandon L Black
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first?
12 * You'll be last either way, Master Peregrin."
18 These functions are related to the method resolution order of perl classes
28 Perl_mro_meta_init(pTHX_ HV* stash)
30 struct mro_meta* newmeta;
34 assert(!(HvAUX(stash)->xhv_mro_meta));
35 Newxz(newmeta, 1, struct mro_meta);
36 HvAUX(stash)->xhv_mro_meta = newmeta;
37 newmeta->cache_gen = 1;
43 #if defined(USE_ITHREADS)
45 /* for sv_dup on new threads */
47 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
49 struct mro_meta* newmeta;
53 Newx(newmeta, 1, struct mro_meta);
54 Copy(smeta, newmeta, 1, struct mro_meta);
56 if (newmeta->mro_linear_dfs)
57 newmeta->mro_linear_dfs
58 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
59 if (newmeta->mro_linear_c3)
60 newmeta->mro_linear_c3
61 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
62 if (newmeta->mro_nextmethod)
63 newmeta->mro_nextmethod
64 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
69 #endif /* USE_ITHREADS */
72 =for apidoc mro_get_linear_isa_dfs
74 Returns the Depth-First Search linearization of @ISA
75 the given stash. The return value is a read-only AV*.
76 C<level> should be 0 (it is used internally in this
77 function's recursion).
79 You are responsible for C<SvREFCNT_inc()> on the
80 return value if you plan to store it anywhere
81 semi-permanently (otherwise it might be deleted
82 out from under you the next time the cache is
88 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
94 const char* stashname;
95 struct mro_meta* meta;
100 stashname = HvNAME_get(stash);
102 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
105 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
108 meta = HvMROMETA(stash);
110 /* return cache if valid */
111 if((retval = meta->mro_linear_dfs)) {
115 /* not in cache, make a new one */
117 retval = (AV*)sv_2mortal((SV *)newAV());
118 av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
121 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
122 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
124 if(av && AvFILLp(av) >= 0) {
126 /* "stored" is used to keep track of all of the classnames
127 we have added to the MRO so far, so we can do a quick
128 exists check and avoid adding duplicate classnames to
131 HV* const stored = (HV*)sv_2mortal((SV*)newHV());
132 SV **svp = AvARRAY(av);
133 I32 items = AvFILLp(av) + 1;
137 SV* const sv = *svp++;
138 HV* const basestash = gv_stashsv(sv, 0);
143 /* if no stash exists for this @ISA member,
144 simply add it to the MRO and move on */
149 /* otherwise, recurse into ourselves for the MRO
150 of this @ISA member, and append their MRO to ours.
151 The recursive call could throw an exception, which
152 has memory management implications here, hence the use of
154 const AV *const subrv
155 = mro_get_linear_isa_dfs(basestash, level + 1);
157 subrv_p = AvARRAY(subrv);
158 subrv_items = AvFILLp(subrv) + 1;
160 while(subrv_items--) {
161 SV *const subsv = *subrv_p++;
162 if(!hv_exists_ent(stored, subsv, 0)) {
163 hv_store_ent(stored, subsv, &PL_sv_undef, 0);
164 av_push(retval, newSVsv(subsv));
170 /* now that we're past the exception dangers, grab our own reference to
171 the AV we're about to use for the result. The reference owned by the
172 mortals' stack will be released soon, so everything will balance. */
173 SvREFCNT_inc_simple_void_NN(retval);
176 /* we don't want anyone modifying the cache entry but us,
177 and we do so by replacing it completely */
178 SvREADONLY_on(retval);
180 meta->mro_linear_dfs = retval;
185 =for apidoc mro_get_linear_isa_c3
187 Returns the C3 linearization of @ISA
188 the given stash. The return value is a read-only AV*.
189 C<level> should be 0 (it is used internally in this
190 function's recursion).
192 You are responsible for C<SvREFCNT_inc()> on the
193 return value if you plan to store it anywhere
194 semi-permanently (otherwise it might be deleted
195 out from under you the next time the cache is
202 S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
208 const char* stashname;
209 STRLEN stashname_len;
210 struct mro_meta* meta;
213 assert(HvAUX(stash));
215 stashname = HvNAME_get(stash);
216 stashname_len = HvNAMELEN_get(stash);
218 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
221 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
224 meta = HvMROMETA(stash);
226 /* return cache if valid */
227 if((retval = meta->mro_linear_c3)) {
231 /* not in cache, make a new one */
233 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
234 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
236 /* For a better idea how the rest of this works, see the much clearer
237 pure perl version in Algorithm::C3 0.01:
238 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
239 (later versions go about it differently than this code for speed reasons)
242 if(isa && AvFILLp(isa) >= 0) {
245 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
246 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
249 /* This builds @seqs, which is an array of arrays.
250 The members of @seqs are the MROs of
251 the members of @ISA, followed by @ISA itself.
253 I32 items = AvFILLp(isa) + 1;
254 SV** isa_ptr = AvARRAY(isa);
256 SV* const isa_item = *isa_ptr++;
257 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
258 if(!isa_item_stash) {
259 /* if no stash, make a temporary fake MRO
260 containing just itself */
261 AV* const isa_lin = newAV();
262 av_push(isa_lin, newSVsv(isa_item));
263 av_push(seqs, (SV*)isa_lin);
267 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
268 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
271 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
273 /* This builds "heads", which as an array of integer array
274 indices, one per seq, which point at the virtual "head"
275 of the seq (initially zero) */
276 Newxz(heads, AvFILLp(seqs)+1, I32);
278 /* This builds %tails, which has one key for every class
279 mentioned in the tail of any sequence in @seqs (tail meaning
280 everything after the first class, the "head"). The value
281 is how many times this key appears in the tails of @seqs.
283 seqs_ptr = AvARRAY(seqs);
284 seqs_items = AvFILLp(seqs) + 1;
285 while(seqs_items--) {
286 AV* const seq = (AV*)*seqs_ptr++;
287 I32 seq_items = AvFILLp(seq);
289 SV** seq_ptr = AvARRAY(seq) + 1;
291 SV* const seqitem = *seq_ptr++;
292 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
294 hv_store_ent(tails, seqitem, newSViv(1), 0);
297 SV* const val = HeVAL(he);
304 /* Initialize retval to build the return value in */
306 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
308 /* This loop won't terminate until we either finish building
309 the MRO, or get an exception. */
315 /* "foreach $seq (@seqs)" */
316 SV** const avptr = AvARRAY(seqs);
317 for(s = 0; s <= AvFILLp(seqs); s++) {
319 AV * const seq = (AV*)(avptr[s]);
321 if(!seq) continue; /* skip empty seqs */
322 svp = av_fetch(seq, heads[s], 0);
323 seqhead = *svp; /* seqhead = head of this seq */
327 /* if we haven't found a winner for this round yet,
328 and this seqhead is not in tails (or the count
329 for it in tails has dropped to zero), then this
330 seqhead is our new winner, and is added to the
331 final MRO immediately */
333 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
334 && (val = HeVAL(tail_entry))
337 winner = newSVsv(cand);
338 av_push(retval, winner);
339 /* note however that even when we find a winner,
340 we continue looping over @seqs to do housekeeping */
342 if(!sv_cmp(seqhead, winner)) {
343 /* Once we have a winner (including the iteration
344 where we first found him), inc the head ptr
345 for any seq which had the winner as a head,
346 NULL out any seq which is now empty,
347 and adjust tails for consistency */
349 const int new_head = ++heads[s];
350 if(new_head > AvFILLp(seq)) {
351 SvREFCNT_dec(avptr[s]);
357 /* Because we know this new seqhead used to be
358 a tail, we can assume it is in tails and has
359 a positive value, which we need to dec */
360 svp = av_fetch(seq, new_head, 0);
362 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
363 val = HeVAL(tail_entry);
369 /* if we found no candidates, we are done building the MRO.
370 !cand means no seqs have any entries left to check */
376 /* If we had candidates, but nobody won, then the @ISA
377 hierarchy is not C3-incompatible */
379 /* we have to do some cleanup before we croak */
381 SvREFCNT_dec(retval);
384 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
385 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
389 else { /* @ISA was undefined or empty */
390 /* build a retval containing only ourselves */
392 av_push(retval, newSVpvn(stashname, stashname_len));
395 /* we don't want anyone modifying the cache entry but us,
396 and we do so by replacing it completely */
397 SvREADONLY_on(retval);
399 meta->mro_linear_c3 = retval;
404 =for apidoc mro_get_linear_isa
406 Returns either C<mro_get_linear_isa_c3> or
407 C<mro_get_linear_isa_dfs> for the given stash,
408 dependant upon which MRO is in effect
409 for that stash. The return value is a
412 You are responsible for C<SvREFCNT_inc()> on the
413 return value if you plan to store it anywhere
414 semi-permanently (otherwise it might be deleted
415 out from under you the next time the cache is
421 Perl_mro_get_linear_isa(pTHX_ HV *stash)
423 struct mro_meta* meta;
427 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
429 meta = HvMROMETA(stash);
430 if(meta->mro_which == MRO_DFS) {
431 return mro_get_linear_isa_dfs(stash, 0);
432 } else if(meta->mro_which == MRO_C3) {
433 return mro_get_linear_isa_c3(stash, 0);
435 Perl_croak(aTHX_ "panic: invalid MRO!");
437 return NULL; /* NOT REACHED */
441 =for apidoc mro_isa_changed_in
443 Takes the necessary steps (cache invalidations, mostly)
444 when the @ISA of the given package has changed. Invoked
445 by the C<setisa> magic, should not need to invoke directly.
450 Perl_mro_isa_changed_in(pTHX_ HV* stash)
459 struct mro_meta * meta;
461 const char * const stashname = HvNAME_get(stash);
462 const STRLEN stashname_len = HvNAMELEN_get(stash);
465 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
467 /* wipe out the cached linearizations for this stash */
468 meta = HvMROMETA(stash);
469 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
470 SvREFCNT_dec((SV*)meta->mro_linear_c3);
471 meta->mro_linear_dfs = NULL;
472 meta->mro_linear_c3 = NULL;
474 /* Inc the package generation, since our @ISA changed */
477 /* Wipe the global method cache if this package
478 is UNIVERSAL or one of its parents */
480 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
481 isarev = svp ? (HV*)*svp : NULL;
483 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
484 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
488 else { /* Wipe the local method cache otherwise */
490 is_universal = FALSE;
493 /* wipe next::method cache too */
494 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
496 /* Iterate the isarev (classes that are our children),
497 wiping out their linearization and method caches */
500 while((iter = hv_iternext(isarev))) {
501 SV* const revkey = hv_iterkeysv(iter);
502 HV* revstash = gv_stashsv(revkey, 0);
503 struct mro_meta* revmeta;
505 if(!revstash) continue;
506 revmeta = HvMROMETA(revstash);
507 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
508 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
509 revmeta->mro_linear_dfs = NULL;
510 revmeta->mro_linear_c3 = NULL;
512 revmeta->cache_gen++;
513 if(revmeta->mro_nextmethod)
514 hv_clear(revmeta->mro_nextmethod);
518 /* Now iterate our MRO (parents), and do a few things:
519 1) instantiate with the "fake" flag if they don't exist
520 2) flag them as universal if we are universal
521 3) Add everything from our isarev to their isarev
524 /* We're starting at the 2nd element, skipping ourselves here */
525 linear_mro = mro_get_linear_isa(stash);
526 svp = AvARRAY(linear_mro) + 1;
527 items = AvFILLp(linear_mro);
530 SV* const sv = *svp++;
533 HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
535 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
537 mroisarev = (HV*)HeVAL(he);
539 /* This hash only ever contains PL_sv_yes. Storing it over itself is
540 almost as cheap as calling hv_exists, so on aggregate we expect to
541 save time by not making two calls to the common HV code for the
542 case where it doesn't exist. */
544 hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
548 while((iter = hv_iternext(isarev))) {
550 char* const revkey = hv_iterkey(iter, &revkeylen);
551 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
558 =for apidoc mro_method_changed_in
560 Invalidates method caching on any child classes
561 of the given stash, so that they might notice
562 the changes in this one.
564 Ideally, all instances of C<PL_sub_generation++> in
565 perl source outside of C<mro.c> should be
566 replaced by calls to this.
568 Perl automatically handles most of the common
569 ways a method might be redefined. However, there
570 are a few ways you could change a method in a stash
571 without the cache code noticing, in which case you
572 need to call this method afterwards:
574 1) Directly manipulating the stash HV entries from
577 2) Assigning a reference to a readonly scalar
578 constant into a stash entry in order to create
579 a constant subroutine (like constant.pm
582 This same method is available from pure perl
583 via, C<mro::method_changed_in(classname)>.
588 Perl_mro_method_changed_in(pTHX_ HV *stash)
590 const char * const stashname = HvNAME_get(stash);
591 const STRLEN stashname_len = HvNAMELEN_get(stash);
593 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
594 HV * const isarev = svp ? (HV*)*svp : NULL;
597 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
599 /* Inc the package generation, since a local method changed */
600 HvMROMETA(stash)->pkg_gen++;
602 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
603 invalidate all method caches globally */
604 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
605 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
610 /* else, invalidate the method caches of all child classes,
616 while((iter = hv_iternext(isarev))) {
617 SV* const revkey = hv_iterkeysv(iter);
618 HV* const revstash = gv_stashsv(revkey, 0);
619 struct mro_meta* mrometa;
621 if(!revstash) continue;
622 mrometa = HvMROMETA(revstash);
623 mrometa->cache_gen++;
624 if(mrometa->mro_nextmethod)
625 hv_clear(mrometa->mro_nextmethod);
630 /* These two are static helpers for next::method and friends,
631 and re-implement a bunch of the code from pp_caller() in
632 a more efficient manner for this particular usage.
636 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
638 for (i = startingblock; i >= 0; i--) {
639 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
646 XS(XS_mro_get_linear_isa);
649 XS(XS_mro_get_isarev);
650 XS(XS_mro_is_universal);
651 XS(XS_mro_invalidate_method_caches);
652 XS(XS_mro_method_changed_in);
653 XS(XS_mro_get_pkg_gen);
657 Perl_boot_core_mro(pTHX)
660 static const char file[] = __FILE__;
662 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
663 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
664 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
665 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
666 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
667 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
668 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
669 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
670 newXS("mro::_nextcan", XS_mro_nextcan, file);
673 XS(XS_mro_get_linear_isa) {
682 if(items < 1 || items > 2)
683 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
686 class_stash = gv_stashsv(classname, 0);
689 /* No stash exists yet, give them just the classname */
690 AV* isalin = newAV();
691 av_push(isalin, newSVsv(classname));
692 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
696 const char* const which = SvPV_nolen(ST(1));
697 if(strEQ(which, "dfs"))
698 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
699 else if(strEQ(which, "c3"))
700 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
702 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
705 RETVAL = mro_get_linear_isa(class_stash);
708 ST(0) = newRV_inc((SV*)RETVAL);
721 struct mro_meta* meta;
726 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
729 whichstr = SvPV_nolen(ST(1));
730 class_stash = gv_stashsv(classname, GV_ADD);
731 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
732 meta = HvMROMETA(class_stash);
734 if(strEQ(whichstr, "dfs"))
736 else if(strEQ(whichstr, "c3"))
739 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
741 if(meta->mro_which != which) {
742 meta->mro_which = which;
743 /* Only affects local method cache, not
744 even child classes */
746 if(meta->mro_nextmethod)
747 hv_clear(meta->mro_nextmethod);
764 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
767 class_stash = gv_stashsv(classname, 0);
769 if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
770 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
772 ST(0) = sv_2mortal(newSVpvn("c3", 2));
777 XS(XS_mro_get_isarev)
789 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
796 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
797 isarev = he ? (HV*)HeVAL(he) : NULL;
803 while((iter = hv_iternext(isarev)))
804 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
806 XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
812 XS(XS_mro_is_universal)
819 STRLEN classname_len;
825 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
829 classname_pv = SvPV_nolen(classname);
830 classname_len = strlen(classname_pv);
832 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
833 isarev = he ? (HV*)HeVAL(he) : NULL;
835 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
836 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
842 XS(XS_mro_invalidate_method_caches)
850 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
857 XS(XS_mro_method_changed_in)
867 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
871 class_stash = gv_stashsv(classname, 0);
872 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
874 mro_method_changed_in(class_stash);
879 XS(XS_mro_get_pkg_gen)
889 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
893 class_stash = gv_stashsv(classname, 0);
897 XPUSHs(sv_2mortal(newSViv(
898 class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
910 const I32 throw_nomethod = SvIVX(ST(1));
911 register I32 cxix = cxstack_ix;
912 register const PERL_CONTEXT *ccstack = cxstack;
913 const PERL_SI *top_si = PL_curstackinfo;
916 const char *fq_subname;
918 STRLEN stashname_len;
926 struct mro_meta* selfmeta;
934 if(sv_isobject(self))
935 selfstash = SvSTASH(SvRV(self));
937 selfstash = gv_stashsv(self, 0);
941 hvname = HvNAME_get(selfstash);
943 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
945 /* This block finds the contextually-enclosing fully-qualified subname,
946 much like looking at (caller($i))[3] until you find a real sub that
947 isn't ANON, etc (also skips over pureperl next::method, etc) */
948 for(i = 0; i < 2; i++) {
949 cxix = __dopoptosub_at(ccstack, cxix);
952 STRLEN fq_subname_len;
954 /* we may be in a higher stacklevel, so dig down deeper */
956 if(top_si->si_type == PERLSI_MAIN)
957 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
958 top_si = top_si->si_prev;
959 ccstack = top_si->si_cxstack;
960 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
963 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
964 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
965 cxix = __dopoptosub_at(ccstack, cxix - 1);
970 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
971 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
972 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
979 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
982 cxix = __dopoptosub_at(ccstack, cxix - 1);
986 /* we found a real sub here */
987 sv = sv_2mortal(newSV(0));
989 gv_efullname3(sv, cvgv, NULL);
991 fq_subname = SvPVX(sv);
992 fq_subname_len = SvCUR(sv);
994 subname = strrchr(fq_subname, ':');
996 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
999 subname_len = fq_subname_len - (subname - fq_subname);
1000 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1001 cxix = __dopoptosub_at(ccstack, cxix - 1);
1009 /* If we made it to here, we found our context */
1011 /* Initialize the next::method cache for this stash
1013 selfmeta = HvMROMETA(selfstash);
1014 if(!(nmcache = selfmeta->mro_nextmethod)) {
1015 nmcache = selfmeta->mro_nextmethod = newHV();
1017 else { /* Use the cached coderef if it exists */
1018 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1020 SV* const val = HeVAL(cache_entry);
1021 if(val == &PL_sv_undef) {
1023 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1026 XPUSHs(sv_2mortal(newRV_inc(val)));
1031 /* beyond here is just for cache misses, so perf isn't as critical */
1033 stashname_len = subname - fq_subname - 2;
1034 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
1036 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1038 linear_svp = AvARRAY(linear_av);
1039 entries = AvFILLp(linear_av) + 1;
1041 /* Walk down our MRO, skipping everything up
1042 to the contextually enclosing class */
1044 SV * const linear_sv = *linear_svp++;
1046 if(sv_eq(linear_sv, stashname))
1050 /* Now search the remainder of the MRO for the
1051 same method name as the contextually enclosing
1055 SV * const linear_sv = *linear_svp++;
1061 curstash = gv_stashsv(linear_sv, FALSE);
1064 if (ckWARN(WARN_SYNTAX))
1065 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1066 (void*)linear_sv, hvname);
1072 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1078 if (SvTYPE(candidate) != SVt_PVGV)
1079 gv_init(candidate, curstash, subname, subname_len, TRUE);
1081 /* Notably, we only look for real entries, not method cache
1082 entries, because in C3 the method cache of a parent is not
1083 valid for the child */
1084 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1085 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1086 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1087 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1093 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1095 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1101 * c-indentation-style: bsd
1103 * indent-tabs-mode: t
1106 * ex: set ts=8 sts=4 sw=4 noet: