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
29 AV *(*resolve)(pTHX_ HV* stash, I32 level);
32 /* First one is the default */
33 static struct mro_alg mros[] = {
34 {"dfs", S_mro_get_linear_isa_dfs},
35 {"c3", S_mro_get_linear_isa_c3}
38 #define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
40 static const struct mro_alg *
41 S_get_mro_from_name(pTHX_ const char *const name) {
42 const struct mro_alg *algo = mros;
43 const struct mro_alg *const end = mros + NUMBER_OF_MROS;
45 if(strEQ(name, algo->name))
53 Perl_mro_meta_init(pTHX_ HV* stash)
55 struct mro_meta* newmeta;
59 assert(!(HvAUX(stash)->xhv_mro_meta));
60 Newxz(newmeta, 1, struct mro_meta);
61 HvAUX(stash)->xhv_mro_meta = newmeta;
62 newmeta->cache_gen = 1;
64 newmeta->mro_which = mros;
69 #if defined(USE_ITHREADS)
71 /* for sv_dup on new threads */
73 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
75 struct mro_meta* newmeta;
79 Newx(newmeta, 1, struct mro_meta);
80 Copy(smeta, newmeta, 1, struct mro_meta);
82 if (newmeta->mro_linear_dfs)
83 newmeta->mro_linear_dfs
84 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
85 if (newmeta->mro_linear_c3)
86 newmeta->mro_linear_c3
87 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
88 if (newmeta->mro_nextmethod)
89 newmeta->mro_nextmethod
90 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
95 #endif /* USE_ITHREADS */
98 =for apidoc mro_get_linear_isa_dfs
100 Returns the Depth-First Search linearization of @ISA
101 the given stash. The return value is a read-only AV*.
102 C<level> should be 0 (it is used internally in this
103 function's recursion).
105 You are responsible for C<SvREFCNT_inc()> on the
106 return value if you plan to store it anywhere
107 semi-permanently (otherwise it might be deleted
108 out from under you the next time the cache is
114 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
121 struct mro_meta* meta;
124 assert(HvAUX(stash));
126 stashhek = HvNAME_HEK(stash);
128 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
131 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
134 meta = HvMROMETA(stash);
136 /* return cache if valid */
137 if((retval = meta->mro_linear_dfs)) {
141 /* not in cache, make a new one */
143 retval = (AV*)sv_2mortal((SV *)newAV());
144 av_push(retval, newSVhek(stashhek)); /* add ourselves at the top */
147 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
148 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
150 if(av && AvFILLp(av) >= 0) {
152 /* "stored" is used to keep track of all of the classnames
153 we have added to the MRO so far, so we can do a quick
154 exists check and avoid adding duplicate classnames to
157 HV* const stored = (HV*)sv_2mortal((SV*)newHV());
158 SV **svp = AvARRAY(av);
159 I32 items = AvFILLp(av) + 1;
163 SV* const sv = *svp++;
164 HV* const basestash = gv_stashsv(sv, 0);
169 /* if no stash exists for this @ISA member,
170 simply add it to the MRO and move on */
175 /* otherwise, recurse into ourselves for the MRO
176 of this @ISA member, and append their MRO to ours.
177 The recursive call could throw an exception, which
178 has memory management implications here, hence the use of
180 const AV *const subrv
181 = mro_get_linear_isa_dfs(basestash, level + 1);
183 subrv_p = AvARRAY(subrv);
184 subrv_items = AvFILLp(subrv) + 1;
186 while(subrv_items--) {
187 SV *const subsv = *subrv_p++;
188 if(!hv_exists_ent(stored, subsv, 0)) {
189 (void)hv_store_ent(stored, subsv, &PL_sv_undef, 0);
190 av_push(retval, newSVsv(subsv));
196 /* now that we're past the exception dangers, grab our own reference to
197 the AV we're about to use for the result. The reference owned by the
198 mortals' stack will be released soon, so everything will balance. */
199 SvREFCNT_inc_simple_void_NN(retval);
202 /* we don't want anyone modifying the cache entry but us,
203 and we do so by replacing it completely */
204 SvREADONLY_on(retval);
206 meta->mro_linear_dfs = retval;
211 =for apidoc mro_get_linear_isa_c3
213 Returns the C3 linearization of @ISA
214 the given stash. The return value is a read-only AV*.
215 C<level> should be 0 (it is used internally in this
216 function's recursion).
218 You are responsible for C<SvREFCNT_inc()> on the
219 return value if you plan to store it anywhere
220 semi-permanently (otherwise it might be deleted
221 out from under you the next time the cache is
228 S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
235 struct mro_meta* meta;
238 assert(HvAUX(stash));
240 stashhek = HvNAME_HEK(stash);
242 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
245 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
248 meta = HvMROMETA(stash);
250 /* return cache if valid */
251 if((retval = meta->mro_linear_c3)) {
255 /* not in cache, make a new one */
257 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
258 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
260 /* For a better idea how the rest of this works, see the much clearer
261 pure perl version in Algorithm::C3 0.01:
262 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
263 (later versions go about it differently than this code for speed reasons)
266 if(isa && AvFILLp(isa) >= 0) {
269 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
270 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
273 /* This builds @seqs, which is an array of arrays.
274 The members of @seqs are the MROs of
275 the members of @ISA, followed by @ISA itself.
277 I32 items = AvFILLp(isa) + 1;
278 SV** isa_ptr = AvARRAY(isa);
280 SV* const isa_item = *isa_ptr++;
281 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
282 if(!isa_item_stash) {
283 /* if no stash, make a temporary fake MRO
284 containing just itself */
285 AV* const isa_lin = newAV();
286 av_push(isa_lin, newSVsv(isa_item));
287 av_push(seqs, (SV*)isa_lin);
291 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
292 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
295 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
297 /* This builds "heads", which as an array of integer array
298 indices, one per seq, which point at the virtual "head"
299 of the seq (initially zero) */
300 Newxz(heads, AvFILLp(seqs)+1, I32);
302 /* This builds %tails, which has one key for every class
303 mentioned in the tail of any sequence in @seqs (tail meaning
304 everything after the first class, the "head"). The value
305 is how many times this key appears in the tails of @seqs.
307 seqs_ptr = AvARRAY(seqs);
308 seqs_items = AvFILLp(seqs) + 1;
309 while(seqs_items--) {
310 AV* const seq = (AV*)*seqs_ptr++;
311 I32 seq_items = AvFILLp(seq);
313 SV** seq_ptr = AvARRAY(seq) + 1;
315 SV* const seqitem = *seq_ptr++;
316 /* LVALUE fetch will create a new undefined SV if necessary
318 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
320 SV* const val = HeVAL(he);
321 /* This will increment undef to 1, which is what we
322 want for a newly created entry. */
329 /* Initialize retval to build the return value in */
331 av_push(retval, newSVhek(stashhek)); /* us first */
333 /* This loop won't terminate until we either finish building
334 the MRO, or get an exception. */
340 /* "foreach $seq (@seqs)" */
341 SV** const avptr = AvARRAY(seqs);
342 for(s = 0; s <= AvFILLp(seqs); s++) {
344 AV * const seq = (AV*)(avptr[s]);
346 if(!seq) continue; /* skip empty seqs */
347 svp = av_fetch(seq, heads[s], 0);
348 seqhead = *svp; /* seqhead = head of this seq */
352 /* if we haven't found a winner for this round yet,
353 and this seqhead is not in tails (or the count
354 for it in tails has dropped to zero), then this
355 seqhead is our new winner, and is added to the
356 final MRO immediately */
358 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
359 && (val = HeVAL(tail_entry))
362 winner = newSVsv(cand);
363 av_push(retval, winner);
364 /* note however that even when we find a winner,
365 we continue looping over @seqs to do housekeeping */
367 if(!sv_cmp(seqhead, winner)) {
368 /* Once we have a winner (including the iteration
369 where we first found him), inc the head ptr
370 for any seq which had the winner as a head,
371 NULL out any seq which is now empty,
372 and adjust tails for consistency */
374 const int new_head = ++heads[s];
375 if(new_head > AvFILLp(seq)) {
376 SvREFCNT_dec(avptr[s]);
382 /* Because we know this new seqhead used to be
383 a tail, we can assume it is in tails and has
384 a positive value, which we need to dec */
385 svp = av_fetch(seq, new_head, 0);
387 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
388 val = HeVAL(tail_entry);
394 /* if we found no candidates, we are done building the MRO.
395 !cand means no seqs have any entries left to check */
401 /* If we had candidates, but nobody won, then the @ISA
402 hierarchy is not C3-incompatible */
404 /* we have to do some cleanup before we croak */
406 SvREFCNT_dec(retval);
409 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
410 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
414 else { /* @ISA was undefined or empty */
415 /* build a retval containing only ourselves */
417 av_push(retval, newSVhek(stashhek));
420 /* we don't want anyone modifying the cache entry but us,
421 and we do so by replacing it completely */
422 SvREADONLY_on(retval);
424 meta->mro_linear_c3 = retval;
429 =for apidoc mro_get_linear_isa
431 Returns either C<mro_get_linear_isa_c3> or
432 C<mro_get_linear_isa_dfs> for the given stash,
433 dependant upon which MRO is in effect
434 for that stash. The return value is a
437 You are responsible for C<SvREFCNT_inc()> on the
438 return value if you plan to store it anywhere
439 semi-permanently (otherwise it might be deleted
440 out from under you the next time the cache is
446 Perl_mro_get_linear_isa(pTHX_ HV *stash)
448 struct mro_meta* meta;
452 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
454 meta = HvMROMETA(stash);
455 if (!meta->mro_which)
456 Perl_croak(aTHX_ "panic: invalid MRO!");
457 return meta->mro_which->resolve(aTHX_ stash, 0);
461 =for apidoc mro_isa_changed_in
463 Takes the necessary steps (cache invalidations, mostly)
464 when the @ISA of the given package has changed. Invoked
465 by the C<setisa> magic, should not need to invoke directly.
470 Perl_mro_isa_changed_in(pTHX_ HV* stash)
479 struct mro_meta * meta;
481 const char * const stashname = HvNAME_get(stash);
482 const STRLEN stashname_len = HvNAMELEN_get(stash);
485 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
487 /* wipe out the cached linearizations for this stash */
488 meta = HvMROMETA(stash);
489 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
490 SvREFCNT_dec((SV*)meta->mro_linear_c3);
491 meta->mro_linear_dfs = NULL;
492 meta->mro_linear_c3 = NULL;
494 /* Inc the package generation, since our @ISA changed */
497 /* Wipe the global method cache if this package
498 is UNIVERSAL or one of its parents */
500 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
501 isarev = svp ? (HV*)*svp : NULL;
503 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
504 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
508 else { /* Wipe the local method cache otherwise */
510 is_universal = FALSE;
513 /* wipe next::method cache too */
514 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
516 /* Iterate the isarev (classes that are our children),
517 wiping out their linearization and method caches */
520 while((iter = hv_iternext(isarev))) {
522 const char* const revkey = hv_iterkey(iter, &len);
523 HV* revstash = gv_stashpvn(revkey, len, 0);
524 struct mro_meta* revmeta;
526 if(!revstash) continue;
527 revmeta = HvMROMETA(revstash);
528 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
529 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
530 revmeta->mro_linear_dfs = NULL;
531 revmeta->mro_linear_c3 = NULL;
533 revmeta->cache_gen++;
534 if(revmeta->mro_nextmethod)
535 hv_clear(revmeta->mro_nextmethod);
539 /* Now iterate our MRO (parents), and do a few things:
540 1) instantiate with the "fake" flag if they don't exist
541 2) flag them as universal if we are universal
542 3) Add everything from our isarev to their isarev
545 /* We're starting at the 2nd element, skipping ourselves here */
546 linear_mro = mro_get_linear_isa(stash);
547 svp = AvARRAY(linear_mro) + 1;
548 items = AvFILLp(linear_mro);
551 SV* const sv = *svp++;
554 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
556 /* That fetch should not fail. But if it had to create a new SV for
557 us, then we can detect it, because it will not be the correct type.
558 Probably faster and cleaner for us to free that scalar [very little
559 code actually executed to free it] and create a new HV than to
560 copy&paste [SIN!] the code from newHV() to allow us to upgrade the
561 new SV from SVt_NULL. */
563 mroisarev = (HV*)HeVAL(he);
565 if(SvTYPE(mroisarev) != SVt_PVHV) {
566 SvREFCNT_dec(mroisarev);
568 HeVAL(he) = (SV *)mroisarev;
571 /* This hash only ever contains PL_sv_yes. Storing it over itself is
572 almost as cheap as calling hv_exists, so on aggregate we expect to
573 save time by not making two calls to the common HV code for the
574 case where it doesn't exist. */
576 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
580 while((iter = hv_iternext(isarev))) {
582 char* const revkey = hv_iterkey(iter, &revkeylen);
583 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
590 =for apidoc mro_method_changed_in
592 Invalidates method caching on any child classes
593 of the given stash, so that they might notice
594 the changes in this one.
596 Ideally, all instances of C<PL_sub_generation++> in
597 perl source outside of C<mro.c> should be
598 replaced by calls to this.
600 Perl automatically handles most of the common
601 ways a method might be redefined. However, there
602 are a few ways you could change a method in a stash
603 without the cache code noticing, in which case you
604 need to call this method afterwards:
606 1) Directly manipulating the stash HV entries from
609 2) Assigning a reference to a readonly scalar
610 constant into a stash entry in order to create
611 a constant subroutine (like constant.pm
614 This same method is available from pure perl
615 via, C<mro::method_changed_in(classname)>.
620 Perl_mro_method_changed_in(pTHX_ HV *stash)
622 const char * const stashname = HvNAME_get(stash);
623 const STRLEN stashname_len = HvNAMELEN_get(stash);
625 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
626 HV * const isarev = svp ? (HV*)*svp : NULL;
629 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
631 /* Inc the package generation, since a local method changed */
632 HvMROMETA(stash)->pkg_gen++;
634 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
635 invalidate all method caches globally */
636 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
637 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
642 /* else, invalidate the method caches of all child classes,
648 while((iter = hv_iternext(isarev))) {
650 const char* const revkey = hv_iterkey(iter, &len);
651 HV* const revstash = gv_stashpvn(revkey, len, 0);
652 struct mro_meta* mrometa;
654 if(!revstash) continue;
655 mrometa = HvMROMETA(revstash);
656 mrometa->cache_gen++;
657 if(mrometa->mro_nextmethod)
658 hv_clear(mrometa->mro_nextmethod);
663 /* These two are static helpers for next::method and friends,
664 and re-implement a bunch of the code from pp_caller() in
665 a more efficient manner for this particular usage.
669 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
671 for (i = startingblock; i >= 0; i--) {
672 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
679 XS(XS_mro_get_linear_isa);
682 XS(XS_mro_get_isarev);
683 XS(XS_mro_is_universal);
684 XS(XS_mro_invalidate_method_caches);
685 XS(XS_mro_method_changed_in);
686 XS(XS_mro_get_pkg_gen);
690 Perl_boot_core_mro(pTHX)
693 static const char file[] = __FILE__;
695 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
696 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
697 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
698 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
699 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
700 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
701 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
702 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
703 newXS("mro::_nextcan", XS_mro_nextcan, file);
706 XS(XS_mro_get_linear_isa) {
715 if(items < 1 || items > 2)
716 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
719 class_stash = gv_stashsv(classname, 0);
722 /* No stash exists yet, give them just the classname */
723 AV* isalin = newAV();
724 av_push(isalin, newSVsv(classname));
725 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
729 const char* const which = SvPV_nolen(ST(1));
730 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
732 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
733 RETVAL = algo->resolve(aTHX_ class_stash, 0);
736 RETVAL = mro_get_linear_isa(class_stash);
739 ST(0) = newRV_inc((SV*)RETVAL);
749 const char* whichstr;
750 const struct mro_alg *which;
752 struct mro_meta* meta;
757 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
760 whichstr = SvPV_nolen(ST(1));
761 class_stash = gv_stashsv(classname, GV_ADD);
762 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
763 meta = HvMROMETA(class_stash);
765 which = S_get_mro_from_name(aTHX_ whichstr);
767 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
769 if(meta->mro_which != which) {
770 meta->mro_which = which;
771 /* Only affects local method cache, not
772 even child classes */
774 if(meta->mro_nextmethod)
775 hv_clear(meta->mro_nextmethod);
792 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
795 class_stash = gv_stashsv(classname, 0);
797 ST(0) = sv_2mortal(newSVpv(class_stash
798 ? HvMROMETA(class_stash)->mro_which->name
803 XS(XS_mro_get_isarev)
815 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
822 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
823 isarev = he ? (HV*)HeVAL(he) : NULL;
829 while((iter = hv_iternext(isarev)))
830 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
832 XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
838 XS(XS_mro_is_universal)
845 STRLEN classname_len;
851 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
855 classname_pv = SvPV(classname,classname_len);
857 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
858 isarev = he ? (HV*)HeVAL(he) : NULL;
860 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
861 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
867 XS(XS_mro_invalidate_method_caches)
875 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
882 XS(XS_mro_method_changed_in)
892 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
896 class_stash = gv_stashsv(classname, 0);
897 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
899 mro_method_changed_in(class_stash);
904 XS(XS_mro_get_pkg_gen)
914 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
918 class_stash = gv_stashsv(classname, 0);
922 XPUSHs(sv_2mortal(newSViv(
923 class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
935 const I32 throw_nomethod = SvIVX(ST(1));
936 register I32 cxix = cxstack_ix;
937 register const PERL_CONTEXT *ccstack = cxstack;
938 const PERL_SI *top_si = PL_curstackinfo;
941 const char *fq_subname;
943 STRLEN stashname_len;
951 struct mro_meta* selfmeta;
959 if(sv_isobject(self))
960 selfstash = SvSTASH(SvRV(self));
962 selfstash = gv_stashsv(self, 0);
966 hvname = HvNAME_get(selfstash);
968 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
970 /* This block finds the contextually-enclosing fully-qualified subname,
971 much like looking at (caller($i))[3] until you find a real sub that
972 isn't ANON, etc (also skips over pureperl next::method, etc) */
973 for(i = 0; i < 2; i++) {
974 cxix = __dopoptosub_at(ccstack, cxix);
977 STRLEN fq_subname_len;
979 /* we may be in a higher stacklevel, so dig down deeper */
981 if(top_si->si_type == PERLSI_MAIN)
982 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
983 top_si = top_si->si_prev;
984 ccstack = top_si->si_cxstack;
985 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
988 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
989 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
990 cxix = __dopoptosub_at(ccstack, cxix - 1);
995 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
996 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
997 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1004 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1007 cxix = __dopoptosub_at(ccstack, cxix - 1);
1011 /* we found a real sub here */
1012 sv = sv_2mortal(newSV(0));
1014 gv_efullname3(sv, cvgv, NULL);
1016 fq_subname = SvPVX(sv);
1017 fq_subname_len = SvCUR(sv);
1019 subname = strrchr(fq_subname, ':');
1021 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1024 subname_len = fq_subname_len - (subname - fq_subname);
1025 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1026 cxix = __dopoptosub_at(ccstack, cxix - 1);
1034 /* If we made it to here, we found our context */
1036 /* Initialize the next::method cache for this stash
1038 selfmeta = HvMROMETA(selfstash);
1039 if(!(nmcache = selfmeta->mro_nextmethod)) {
1040 nmcache = selfmeta->mro_nextmethod = newHV();
1042 else { /* Use the cached coderef if it exists */
1043 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1045 SV* const val = HeVAL(cache_entry);
1046 if(val == &PL_sv_undef) {
1048 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1051 XPUSHs(sv_2mortal(newRV_inc(val)));
1056 /* beyond here is just for cache misses, so perf isn't as critical */
1058 stashname_len = subname - fq_subname - 2;
1059 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
1061 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1063 linear_svp = AvARRAY(linear_av);
1064 entries = AvFILLp(linear_av) + 1;
1066 /* Walk down our MRO, skipping everything up
1067 to the contextually enclosing class */
1069 SV * const linear_sv = *linear_svp++;
1071 if(sv_eq(linear_sv, stashname))
1075 /* Now search the remainder of the MRO for the
1076 same method name as the contextually enclosing
1080 SV * const linear_sv = *linear_svp++;
1086 curstash = gv_stashsv(linear_sv, FALSE);
1089 if (ckWARN(WARN_SYNTAX))
1090 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1091 (void*)linear_sv, hvname);
1097 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1103 if (SvTYPE(candidate) != SVt_PVGV)
1104 gv_init(candidate, curstash, subname, subname_len, TRUE);
1106 /* Notably, we only look for real entries, not method cache
1107 entries, because in C3 the method cache of a parent is not
1108 valid for the child */
1109 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1110 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1111 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1112 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1118 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1120 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1126 * c-indentation-style: bsd
1128 * indent-tabs-mode: t
1131 * ex: set ts=8 sts=4 sw=4 noet: