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;
57 PERL_ARGS_ASSERT_MRO_META_INIT;
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;
77 PERL_ARGS_ASSERT_MRO_META_DUP;
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;
123 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
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;
237 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
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;
450 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
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);
484 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
487 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
489 /* wipe out the cached linearizations for this stash */
490 meta = HvMROMETA(stash);
491 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
492 SvREFCNT_dec((SV*)meta->mro_linear_c3);
493 meta->mro_linear_dfs = NULL;
494 meta->mro_linear_c3 = NULL;
496 /* Inc the package generation, since our @ISA changed */
499 /* Wipe the global method cache if this package
500 is UNIVERSAL or one of its parents */
502 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
503 isarev = svp ? (HV*)*svp : NULL;
505 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
506 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
510 else { /* Wipe the local method cache otherwise */
512 is_universal = FALSE;
515 /* wipe next::method cache too */
516 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
518 /* Iterate the isarev (classes that are our children),
519 wiping out their linearization and method caches */
522 while((iter = hv_iternext(isarev))) {
524 const char* const revkey = hv_iterkey(iter, &len);
525 HV* revstash = gv_stashpvn(revkey, len, 0);
526 struct mro_meta* revmeta;
528 if(!revstash) continue;
529 revmeta = HvMROMETA(revstash);
530 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
531 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
532 revmeta->mro_linear_dfs = NULL;
533 revmeta->mro_linear_c3 = NULL;
535 revmeta->cache_gen++;
536 if(revmeta->mro_nextmethod)
537 hv_clear(revmeta->mro_nextmethod);
541 /* Now iterate our MRO (parents), and do a few things:
542 1) instantiate with the "fake" flag if they don't exist
543 2) flag them as universal if we are universal
544 3) Add everything from our isarev to their isarev
547 /* We're starting at the 2nd element, skipping ourselves here */
548 linear_mro = mro_get_linear_isa(stash);
549 svp = AvARRAY(linear_mro) + 1;
550 items = AvFILLp(linear_mro);
553 SV* const sv = *svp++;
556 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
558 /* That fetch should not fail. But if it had to create a new SV for
559 us, then will need to upgrade it to an HV (which sv_upgrade() can
562 mroisarev = (HV*)HeVAL(he);
564 SvUPGRADE((SV*)mroisarev, SVt_PVHV);
566 /* This hash only ever contains PL_sv_yes. Storing it over itself is
567 almost as cheap as calling hv_exists, so on aggregate we expect to
568 save time by not making two calls to the common HV code for the
569 case where it doesn't exist. */
571 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
575 while((iter = hv_iternext(isarev))) {
577 char* const revkey = hv_iterkey(iter, &revkeylen);
578 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
585 =for apidoc mro_method_changed_in
587 Invalidates method caching on any child classes
588 of the given stash, so that they might notice
589 the changes in this one.
591 Ideally, all instances of C<PL_sub_generation++> in
592 perl source outside of C<mro.c> should be
593 replaced by calls to this.
595 Perl automatically handles most of the common
596 ways a method might be redefined. However, there
597 are a few ways you could change a method in a stash
598 without the cache code noticing, in which case you
599 need to call this method afterwards:
601 1) Directly manipulating the stash HV entries from
604 2) Assigning a reference to a readonly scalar
605 constant into a stash entry in order to create
606 a constant subroutine (like constant.pm
609 This same method is available from pure perl
610 via, C<mro::method_changed_in(classname)>.
615 Perl_mro_method_changed_in(pTHX_ HV *stash)
617 const char * const stashname = HvNAME_get(stash);
618 const STRLEN stashname_len = HvNAMELEN_get(stash);
620 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
621 HV * const isarev = svp ? (HV*)*svp : NULL;
623 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
626 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
628 /* Inc the package generation, since a local method changed */
629 HvMROMETA(stash)->pkg_gen++;
631 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
632 invalidate all method caches globally */
633 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
634 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
639 /* else, invalidate the method caches of all child classes,
645 while((iter = hv_iternext(isarev))) {
647 const char* const revkey = hv_iterkey(iter, &len);
648 HV* const revstash = gv_stashpvn(revkey, len, 0);
649 struct mro_meta* mrometa;
651 if(!revstash) continue;
652 mrometa = HvMROMETA(revstash);
653 mrometa->cache_gen++;
654 if(mrometa->mro_nextmethod)
655 hv_clear(mrometa->mro_nextmethod);
660 /* These two are static helpers for next::method and friends,
661 and re-implement a bunch of the code from pp_caller() in
662 a more efficient manner for this particular usage.
666 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
668 for (i = startingblock; i >= 0; i--) {
669 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
676 XS(XS_mro_get_linear_isa);
679 XS(XS_mro_get_isarev);
680 XS(XS_mro_is_universal);
681 XS(XS_mro_invalidate_method_caches);
682 XS(XS_mro_method_changed_in);
683 XS(XS_mro_get_pkg_gen);
687 Perl_boot_core_mro(pTHX)
690 static const char file[] = __FILE__;
692 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
693 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
694 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
695 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
696 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
697 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
698 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
699 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
700 newXS("mro::_nextcan", XS_mro_nextcan, file);
703 XS(XS_mro_get_linear_isa) {
710 if(items < 1 || items > 2)
711 croak_xs_usage(cv, "classname [, type ]");
714 class_stash = gv_stashsv(classname, 0);
717 /* No stash exists yet, give them just the classname */
718 AV* isalin = newAV();
719 av_push(isalin, newSVsv(classname));
720 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
724 const char* const which = SvPV_nolen(ST(1));
725 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
727 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
728 RETVAL = algo->resolve(aTHX_ class_stash, 0);
731 RETVAL = mro_get_linear_isa(class_stash);
734 ST(0) = newRV_inc((SV*)RETVAL);
744 const char* whichstr;
745 const struct mro_alg *which;
747 struct mro_meta* meta;
750 croak_xs_usage(cv, "classname, type");
753 whichstr = SvPV_nolen(ST(1));
754 class_stash = gv_stashsv(classname, GV_ADD);
755 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
756 meta = HvMROMETA(class_stash);
758 which = S_get_mro_from_name(aTHX_ whichstr);
760 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
762 if(meta->mro_which != which) {
763 meta->mro_which = which;
764 /* Only affects local method cache, not
765 even child classes */
767 if(meta->mro_nextmethod)
768 hv_clear(meta->mro_nextmethod);
783 croak_xs_usage(cv, "classname");
786 class_stash = gv_stashsv(classname, 0);
788 ST(0) = sv_2mortal(newSVpv(class_stash
789 ? HvMROMETA(class_stash)->mro_which->name
794 XS(XS_mro_get_isarev)
804 croak_xs_usage(cv, "classname");
811 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
812 isarev = he ? (HV*)HeVAL(he) : NULL;
818 while((iter = hv_iternext(isarev)))
819 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
821 mXPUSHs(newRV_noinc((SV*)ret_array));
827 XS(XS_mro_is_universal)
834 STRLEN classname_len;
838 croak_xs_usage(cv, "classname");
842 classname_pv = SvPV(classname,classname_len);
844 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
845 isarev = he ? (HV*)HeVAL(he) : NULL;
847 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
848 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
854 XS(XS_mro_invalidate_method_caches)
860 croak_xs_usage(cv, "");
867 XS(XS_mro_method_changed_in)
875 croak_xs_usage(cv, "classname");
879 class_stash = gv_stashsv(classname, 0);
880 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
882 mro_method_changed_in(class_stash);
887 XS(XS_mro_get_pkg_gen)
895 croak_xs_usage(cv, "classname");
899 class_stash = gv_stashsv(classname, 0);
903 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
914 const I32 throw_nomethod = SvIVX(ST(1));
915 register I32 cxix = cxstack_ix;
916 register const PERL_CONTEXT *ccstack = cxstack;
917 const PERL_SI *top_si = PL_curstackinfo;
920 const char *fq_subname;
922 STRLEN stashname_len;
930 struct mro_meta* selfmeta;
938 if(sv_isobject(self))
939 selfstash = SvSTASH(SvRV(self));
941 selfstash = gv_stashsv(self, GV_ADD);
945 hvname = HvNAME_get(selfstash);
947 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
949 /* This block finds the contextually-enclosing fully-qualified subname,
950 much like looking at (caller($i))[3] until you find a real sub that
951 isn't ANON, etc (also skips over pureperl next::method, etc) */
952 for(i = 0; i < 2; i++) {
953 cxix = __dopoptosub_at(ccstack, cxix);
956 STRLEN fq_subname_len;
958 /* we may be in a higher stacklevel, so dig down deeper */
960 if(top_si->si_type == PERLSI_MAIN)
961 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
962 top_si = top_si->si_prev;
963 ccstack = top_si->si_cxstack;
964 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
967 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
968 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
969 cxix = __dopoptosub_at(ccstack, cxix - 1);
974 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
975 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
976 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
983 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
986 cxix = __dopoptosub_at(ccstack, cxix - 1);
990 /* we found a real sub here */
991 sv = sv_2mortal(newSV(0));
993 gv_efullname3(sv, cvgv, NULL);
995 fq_subname = SvPVX(sv);
996 fq_subname_len = SvCUR(sv);
998 subname = strrchr(fq_subname, ':');
1000 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1003 subname_len = fq_subname_len - (subname - fq_subname);
1004 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1005 cxix = __dopoptosub_at(ccstack, cxix - 1);
1013 /* If we made it to here, we found our context */
1015 /* Initialize the next::method cache for this stash
1017 selfmeta = HvMROMETA(selfstash);
1018 if(!(nmcache = selfmeta->mro_nextmethod)) {
1019 nmcache = selfmeta->mro_nextmethod = newHV();
1021 else { /* Use the cached coderef if it exists */
1022 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1024 SV* const val = HeVAL(cache_entry);
1025 if(val == &PL_sv_undef) {
1027 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1030 mXPUSHs(newRV_inc(val));
1035 /* beyond here is just for cache misses, so perf isn't as critical */
1037 stashname_len = subname - fq_subname - 2;
1038 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1040 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1042 linear_svp = AvARRAY(linear_av);
1043 entries = AvFILLp(linear_av) + 1;
1045 /* Walk down our MRO, skipping everything up
1046 to the contextually enclosing class */
1048 SV * const linear_sv = *linear_svp++;
1050 if(sv_eq(linear_sv, stashname))
1054 /* Now search the remainder of the MRO for the
1055 same method name as the contextually enclosing
1059 SV * const linear_sv = *linear_svp++;
1065 curstash = gv_stashsv(linear_sv, FALSE);
1068 if (ckWARN(WARN_SYNTAX))
1069 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1070 (void*)linear_sv, hvname);
1076 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1082 if (SvTYPE(candidate) != SVt_PVGV)
1083 gv_init(candidate, curstash, subname, subname_len, TRUE);
1085 /* Notably, we only look for real entries, not method cache
1086 entries, because in C3 the method cache of a parent is not
1087 valid for the child */
1088 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1089 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1090 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1091 mXPUSHs(newRV_inc((SV*)cand_cv));
1097 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1099 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1105 * c-indentation-style: bsd
1107 * indent-tabs-mode: t
1110 * ex: set ts=8 sts=4 sw=4 noet: