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
27 Perl_mro_meta_init(pTHX_ HV* stash)
29 struct mro_meta* newmeta;
33 assert(!(HvAUX(stash)->xhv_mro_meta));
34 Newxz(newmeta, 1, struct mro_meta);
35 HvAUX(stash)->xhv_mro_meta = newmeta;
36 newmeta->cache_gen = 1;
42 #if defined(USE_ITHREADS)
44 /* for sv_dup on new threads */
46 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
48 struct mro_meta* newmeta;
52 Newx(newmeta, 1, struct mro_meta);
53 Copy(smeta, newmeta, 1, struct mro_meta);
55 if (newmeta->mro_linear_dfs)
56 newmeta->mro_linear_dfs
57 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
58 if (newmeta->mro_linear_c3)
59 newmeta->mro_linear_c3
60 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
61 if (newmeta->mro_nextmethod)
62 newmeta->mro_nextmethod
63 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
68 #endif /* USE_ITHREADS */
71 =for apidoc mro_get_linear_isa_dfs
73 Returns the Depth-First Search linearization of @ISA
74 the given stash. The return value is a read-only AV*.
75 C<level> should be 0 (it is used internally in this
76 function's recursion).
78 You are responsible for C<SvREFCNT_inc()> on the
79 return value if you plan to store it anywhere
80 semi-permanently (otherwise it might be deleted
81 out from under you the next time the cache is
87 Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
93 const char* stashname;
94 struct mro_meta* meta;
99 stashname = HvNAME_get(stash);
101 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
104 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
107 meta = HvMROMETA(stash);
109 /* return cache if valid */
110 if((retval = meta->mro_linear_dfs)) {
114 /* not in cache, make a new one */
116 retval = (AV*)sv_2mortal((SV *)newAV());
117 av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
120 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
121 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
123 if(av && AvFILLp(av) >= 0) {
125 /* "stored" is used to keep track of all of the classnames
126 we have added to the MRO so far, so we can do a quick
127 exists check and avoid adding duplicate classnames to
130 HV* const stored = (HV*)sv_2mortal((SV*)newHV());
131 SV **svp = AvARRAY(av);
132 I32 items = AvFILLp(av) + 1;
136 SV* const sv = *svp++;
137 HV* const basestash = gv_stashsv(sv, 0);
142 /* if no stash exists for this @ISA member,
143 simply add it to the MRO and move on */
148 /* otherwise, recurse into ourselves for the MRO
149 of this @ISA member, and append their MRO to ours */
150 const AV *const subrv
151 = mro_get_linear_isa_dfs(basestash, level + 1);
153 subrv_p = AvARRAY(subrv);
154 subrv_items = AvFILLp(subrv) + 1;
156 while(subrv_items--) {
157 SV *const subsv = *subrv_p++;
158 if(!hv_exists_ent(stored, subsv, 0)) {
159 hv_store_ent(stored, subsv, &PL_sv_undef, 0);
160 av_push(retval, newSVsv(subsv));
166 /* now that we're past the exception dangers, grab our own reference to
167 the AV we're about to use for the result. The reference owned by the
168 mortals' stack will be released soon, so everything will balance. */
169 SvREFCNT_inc_simple_void_NN(retval);
172 /* we don't want anyone modifying the cache entry but us,
173 and we do so by replacing it completely */
174 SvREADONLY_on(retval);
176 meta->mro_linear_dfs = retval;
181 =for apidoc mro_get_linear_isa_c3
183 Returns the C3 linearization of @ISA
184 the given stash. The return value is a read-only AV*.
185 C<level> should be 0 (it is used internally in this
186 function's recursion).
188 You are responsible for C<SvREFCNT_inc()> on the
189 return value if you plan to store it anywhere
190 semi-permanently (otherwise it might be deleted
191 out from under you the next time the cache is
198 Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
204 const char* stashname;
205 STRLEN stashname_len;
206 struct mro_meta* meta;
209 assert(HvAUX(stash));
211 stashname = HvNAME_get(stash);
212 stashname_len = HvNAMELEN_get(stash);
214 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
217 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
220 meta = HvMROMETA(stash);
222 /* return cache if valid */
223 if((retval = meta->mro_linear_c3)) {
227 /* not in cache, make a new one */
229 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
230 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
232 /* For a better idea how the rest of this works, see the much clearer
233 pure perl version in Algorithm::C3 0.01:
234 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
235 (later versions go about it differently than this code for speed reasons)
238 if(isa && AvFILLp(isa) >= 0) {
241 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
242 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
245 /* This builds @seqs, which is an array of arrays.
246 The members of @seqs are the MROs of
247 the members of @ISA, followed by @ISA itself.
249 I32 items = AvFILLp(isa) + 1;
250 SV** isa_ptr = AvARRAY(isa);
252 SV* const isa_item = *isa_ptr++;
253 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
254 if(!isa_item_stash) {
255 /* if no stash, make a temporary fake MRO
256 containing just itself */
257 AV* const isa_lin = newAV();
258 av_push(isa_lin, newSVsv(isa_item));
259 av_push(seqs, (SV*)isa_lin);
263 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
264 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
267 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
269 /* This builds "heads", which as an array of integer array
270 indices, one per seq, which point at the virtual "head"
271 of the seq (initially zero) */
272 Newxz(heads, AvFILLp(seqs)+1, I32);
274 /* This builds %tails, which has one key for every class
275 mentioned in the tail of any sequence in @seqs (tail meaning
276 everything after the first class, the "head"). The value
277 is how many times this key appears in the tails of @seqs.
279 seqs_ptr = AvARRAY(seqs);
280 seqs_items = AvFILLp(seqs) + 1;
281 while(seqs_items--) {
282 AV* const seq = (AV*)*seqs_ptr++;
283 I32 seq_items = AvFILLp(seq);
285 SV** seq_ptr = AvARRAY(seq) + 1;
287 SV* const seqitem = *seq_ptr++;
288 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
290 hv_store_ent(tails, seqitem, newSViv(1), 0);
293 SV* const val = HeVAL(he);
300 /* Initialize retval to build the return value in */
302 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
304 /* This loop won't terminate until we either finish building
305 the MRO, or get an exception. */
311 /* "foreach $seq (@seqs)" */
312 SV** const avptr = AvARRAY(seqs);
313 for(s = 0; s <= AvFILLp(seqs); s++) {
315 AV * const seq = (AV*)(avptr[s]);
317 if(!seq) continue; /* skip empty seqs */
318 svp = av_fetch(seq, heads[s], 0);
319 seqhead = *svp; /* seqhead = head of this seq */
323 /* if we haven't found a winner for this round yet,
324 and this seqhead is not in tails (or the count
325 for it in tails has dropped to zero), then this
326 seqhead is our new winner, and is added to the
327 final MRO immediately */
329 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
330 && (val = HeVAL(tail_entry))
333 winner = newSVsv(cand);
334 av_push(retval, winner);
335 /* note however that even when we find a winner,
336 we continue looping over @seqs to do housekeeping */
338 if(!sv_cmp(seqhead, winner)) {
339 /* Once we have a winner (including the iteration
340 where we first found him), inc the head ptr
341 for any seq which had the winner as a head,
342 NULL out any seq which is now empty,
343 and adjust tails for consistency */
345 const int new_head = ++heads[s];
346 if(new_head > AvFILLp(seq)) {
347 SvREFCNT_dec(avptr[s]);
353 /* Because we know this new seqhead used to be
354 a tail, we can assume it is in tails and has
355 a positive value, which we need to dec */
356 svp = av_fetch(seq, new_head, 0);
358 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
359 val = HeVAL(tail_entry);
365 /* if we found no candidates, we are done building the MRO.
366 !cand means no seqs have any entries left to check */
372 /* If we had candidates, but nobody won, then the @ISA
373 hierarchy is not C3-incompatible */
375 /* we have to do some cleanup before we croak */
377 SvREFCNT_dec(retval);
380 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
381 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
385 else { /* @ISA was undefined or empty */
386 /* build a retval containing only ourselves */
388 av_push(retval, newSVpvn(stashname, stashname_len));
391 /* we don't want anyone modifying the cache entry but us,
392 and we do so by replacing it completely */
393 SvREADONLY_on(retval);
395 meta->mro_linear_c3 = retval;
400 =for apidoc mro_get_linear_isa
402 Returns either C<mro_get_linear_isa_c3> or
403 C<mro_get_linear_isa_dfs> for the given stash,
404 dependant upon which MRO is in effect
405 for that stash. The return value is a
408 You are responsible for C<SvREFCNT_inc()> on the
409 return value if you plan to store it anywhere
410 semi-permanently (otherwise it might be deleted
411 out from under you the next time the cache is
417 Perl_mro_get_linear_isa(pTHX_ HV *stash)
419 struct mro_meta* meta;
423 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
425 meta = HvMROMETA(stash);
426 if(meta->mro_which == MRO_DFS) {
427 return mro_get_linear_isa_dfs(stash, 0);
428 } else if(meta->mro_which == MRO_C3) {
429 return mro_get_linear_isa_c3(stash, 0);
431 Perl_croak(aTHX_ "panic: invalid MRO!");
433 return NULL; /* NOT REACHED */
437 =for apidoc mro_isa_changed_in
439 Takes the necessary steps (cache invalidations, mostly)
440 when the @ISA of the given package has changed. Invoked
441 by the C<setisa> magic, should not need to invoke directly.
446 Perl_mro_isa_changed_in(pTHX_ HV* stash)
455 struct mro_meta * meta;
457 const char * const stashname = HvNAME_get(stash);
458 const STRLEN stashname_len = HvNAMELEN_get(stash);
461 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
463 /* wipe out the cached linearizations for this stash */
464 meta = HvMROMETA(stash);
465 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
466 SvREFCNT_dec((SV*)meta->mro_linear_c3);
467 meta->mro_linear_dfs = NULL;
468 meta->mro_linear_c3 = NULL;
470 /* Inc the package generation, since our @ISA changed */
473 /* Wipe the global method cache if this package
474 is UNIVERSAL or one of its parents */
476 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
477 isarev = svp ? (HV*)*svp : NULL;
479 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
480 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
484 else { /* Wipe the local method cache otherwise */
486 is_universal = FALSE;
489 /* wipe next::method cache too */
490 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
492 /* Iterate the isarev (classes that are our children),
493 wiping out their linearization and method caches */
496 while((iter = hv_iternext(isarev))) {
497 SV* const revkey = hv_iterkeysv(iter);
498 HV* revstash = gv_stashsv(revkey, 0);
499 struct mro_meta* revmeta;
501 if(!revstash) continue;
502 revmeta = HvMROMETA(revstash);
503 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
504 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
505 revmeta->mro_linear_dfs = NULL;
506 revmeta->mro_linear_c3 = NULL;
508 revmeta->cache_gen++;
509 if(revmeta->mro_nextmethod)
510 hv_clear(revmeta->mro_nextmethod);
514 /* Now iterate our MRO (parents), and do a few things:
515 1) instantiate with the "fake" flag if they don't exist
516 2) flag them as universal if we are universal
517 3) Add everything from our isarev to their isarev
520 /* We're starting at the 2nd element, skipping ourselves here */
521 linear_mro = mro_get_linear_isa(stash);
522 svp = AvARRAY(linear_mro) + 1;
523 items = AvFILLp(linear_mro);
526 SV* const sv = *svp++;
529 HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
531 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
533 mroisarev = (HV*)HeVAL(he);
535 /* This hash only ever contains PL_sv_yes. Storing it over itself is
536 almost as cheap as calling hv_exists, so on aggregate we expect to
537 save time by not making two calls to the common HV code for the
538 case where it doesn't exist. */
540 hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
544 while((iter = hv_iternext(isarev))) {
546 char* const revkey = hv_iterkey(iter, &revkeylen);
547 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
554 =for apidoc mro_method_changed_in
556 Invalidates method caching on any child classes
557 of the given stash, so that they might notice
558 the changes in this one.
560 Ideally, all instances of C<PL_sub_generation++> in
561 perl source outside of C<mro.c> should be
562 replaced by calls to this.
564 Perl automatically handles most of the common
565 ways a method might be redefined. However, there
566 are a few ways you could change a method in a stash
567 without the cache code noticing, in which case you
568 need to call this method afterwards:
570 1) Directly manipulating the stash HV entries from
573 2) Assigning a reference to a readonly scalar
574 constant into a stash entry in order to create
575 a constant subroutine (like constant.pm
578 This same method is available from pure perl
579 via, C<mro::method_changed_in(classname)>.
584 Perl_mro_method_changed_in(pTHX_ HV *stash)
586 const char * const stashname = HvNAME_get(stash);
587 const STRLEN stashname_len = HvNAMELEN_get(stash);
589 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
590 HV * const isarev = svp ? (HV*)*svp : NULL;
593 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
595 /* Inc the package generation, since a local method changed */
596 HvMROMETA(stash)->pkg_gen++;
598 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
599 invalidate all method caches globally */
600 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
601 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
606 /* else, invalidate the method caches of all child classes,
612 while((iter = hv_iternext(isarev))) {
613 SV* const revkey = hv_iterkeysv(iter);
614 HV* const revstash = gv_stashsv(revkey, 0);
615 struct mro_meta* mrometa;
617 if(!revstash) continue;
618 mrometa = HvMROMETA(revstash);
619 mrometa->cache_gen++;
620 if(mrometa->mro_nextmethod)
621 hv_clear(mrometa->mro_nextmethod);
626 /* These two are static helpers for next::method and friends,
627 and re-implement a bunch of the code from pp_caller() in
628 a more efficient manner for this particular usage.
632 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
634 for (i = startingblock; i >= 0; i--) {
635 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
642 XS(XS_mro_get_linear_isa);
645 XS(XS_mro_get_isarev);
646 XS(XS_mro_is_universal);
647 XS(XS_mro_invalidate_method_caches);
648 XS(XS_mro_method_changed_in);
649 XS(XS_mro_get_pkg_gen);
653 Perl_boot_core_mro(pTHX)
656 static const char file[] = __FILE__;
658 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
659 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
660 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
661 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
662 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
663 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
664 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
665 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
666 newXS("mro::_nextcan", XS_mro_nextcan, file);
669 XS(XS_mro_get_linear_isa) {
678 if(items < 1 || items > 2)
679 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
682 class_stash = gv_stashsv(classname, 0);
685 /* No stash exists yet, give them just the classname */
686 AV* isalin = newAV();
687 av_push(isalin, newSVsv(classname));
688 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
692 const char* const which = SvPV_nolen(ST(1));
693 if(strEQ(which, "dfs"))
694 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
695 else if(strEQ(which, "c3"))
696 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
698 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
701 RETVAL = mro_get_linear_isa(class_stash);
704 ST(0) = newRV_inc((SV*)RETVAL);
717 struct mro_meta* meta;
722 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
725 whichstr = SvPV_nolen(ST(1));
726 class_stash = gv_stashsv(classname, GV_ADD);
727 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
728 meta = HvMROMETA(class_stash);
730 if(strEQ(whichstr, "dfs"))
732 else if(strEQ(whichstr, "c3"))
735 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
737 if(meta->mro_which != which) {
738 meta->mro_which = which;
739 /* Only affects local method cache, not
740 even child classes */
742 if(meta->mro_nextmethod)
743 hv_clear(meta->mro_nextmethod);
760 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
763 class_stash = gv_stashsv(classname, 0);
765 if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
766 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
768 ST(0) = sv_2mortal(newSVpvn("c3", 2));
773 XS(XS_mro_get_isarev)
781 STRLEN classname_len;
787 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
794 classname_pv = SvPV_nolen(classname);
795 classname_len = strlen(classname_pv);
796 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
797 isarev = svp ? (HV*)*svp : 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 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
833 isarev = svp ? (HV*)*svp : 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: