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)
120 const char* stashname;
121 struct mro_meta* meta;
124 assert(HvAUX(stash));
126 stashname = HvNAME_get(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, newSVpv(stashname, 0)); /* 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)
234 const char* stashname;
235 STRLEN stashname_len;
236 struct mro_meta* meta;
239 assert(HvAUX(stash));
241 stashname = HvNAME_get(stash);
242 stashname_len = HvNAMELEN_get(stash);
244 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
247 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
250 meta = HvMROMETA(stash);
252 /* return cache if valid */
253 if((retval = meta->mro_linear_c3)) {
257 /* not in cache, make a new one */
259 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
260 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
262 /* For a better idea how the rest of this works, see the much clearer
263 pure perl version in Algorithm::C3 0.01:
264 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
265 (later versions go about it differently than this code for speed reasons)
268 if(isa && AvFILLp(isa) >= 0) {
271 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
272 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
275 /* This builds @seqs, which is an array of arrays.
276 The members of @seqs are the MROs of
277 the members of @ISA, followed by @ISA itself.
279 I32 items = AvFILLp(isa) + 1;
280 SV** isa_ptr = AvARRAY(isa);
282 SV* const isa_item = *isa_ptr++;
283 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
284 if(!isa_item_stash) {
285 /* if no stash, make a temporary fake MRO
286 containing just itself */
287 AV* const isa_lin = newAV();
288 av_push(isa_lin, newSVsv(isa_item));
289 av_push(seqs, (SV*)isa_lin);
293 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
294 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
297 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
299 /* This builds "heads", which as an array of integer array
300 indices, one per seq, which point at the virtual "head"
301 of the seq (initially zero) */
302 Newxz(heads, AvFILLp(seqs)+1, I32);
304 /* This builds %tails, which has one key for every class
305 mentioned in the tail of any sequence in @seqs (tail meaning
306 everything after the first class, the "head"). The value
307 is how many times this key appears in the tails of @seqs.
309 seqs_ptr = AvARRAY(seqs);
310 seqs_items = AvFILLp(seqs) + 1;
311 while(seqs_items--) {
312 AV* const seq = (AV*)*seqs_ptr++;
313 I32 seq_items = AvFILLp(seq);
315 SV** seq_ptr = AvARRAY(seq) + 1;
317 SV* const seqitem = *seq_ptr++;
318 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
320 (void)hv_store_ent(tails, seqitem, newSViv(1), 0);
323 SV* const val = HeVAL(he);
330 /* Initialize retval to build the return value in */
332 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
334 /* This loop won't terminate until we either finish building
335 the MRO, or get an exception. */
341 /* "foreach $seq (@seqs)" */
342 SV** const avptr = AvARRAY(seqs);
343 for(s = 0; s <= AvFILLp(seqs); s++) {
345 AV * const seq = (AV*)(avptr[s]);
347 if(!seq) continue; /* skip empty seqs */
348 svp = av_fetch(seq, heads[s], 0);
349 seqhead = *svp; /* seqhead = head of this seq */
353 /* if we haven't found a winner for this round yet,
354 and this seqhead is not in tails (or the count
355 for it in tails has dropped to zero), then this
356 seqhead is our new winner, and is added to the
357 final MRO immediately */
359 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
360 && (val = HeVAL(tail_entry))
363 winner = newSVsv(cand);
364 av_push(retval, winner);
365 /* note however that even when we find a winner,
366 we continue looping over @seqs to do housekeeping */
368 if(!sv_cmp(seqhead, winner)) {
369 /* Once we have a winner (including the iteration
370 where we first found him), inc the head ptr
371 for any seq which had the winner as a head,
372 NULL out any seq which is now empty,
373 and adjust tails for consistency */
375 const int new_head = ++heads[s];
376 if(new_head > AvFILLp(seq)) {
377 SvREFCNT_dec(avptr[s]);
383 /* Because we know this new seqhead used to be
384 a tail, we can assume it is in tails and has
385 a positive value, which we need to dec */
386 svp = av_fetch(seq, new_head, 0);
388 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
389 val = HeVAL(tail_entry);
395 /* if we found no candidates, we are done building the MRO.
396 !cand means no seqs have any entries left to check */
402 /* If we had candidates, but nobody won, then the @ISA
403 hierarchy is not C3-incompatible */
405 /* we have to do some cleanup before we croak */
407 SvREFCNT_dec(retval);
410 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
411 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
415 else { /* @ISA was undefined or empty */
416 /* build a retval containing only ourselves */
418 av_push(retval, newSVpvn(stashname, stashname_len));
421 /* we don't want anyone modifying the cache entry but us,
422 and we do so by replacing it completely */
423 SvREADONLY_on(retval);
425 meta->mro_linear_c3 = retval;
430 =for apidoc mro_get_linear_isa
432 Returns either C<mro_get_linear_isa_c3> or
433 C<mro_get_linear_isa_dfs> for the given stash,
434 dependant upon which MRO is in effect
435 for that stash. The return value is a
438 You are responsible for C<SvREFCNT_inc()> on the
439 return value if you plan to store it anywhere
440 semi-permanently (otherwise it might be deleted
441 out from under you the next time the cache is
447 Perl_mro_get_linear_isa(pTHX_ HV *stash)
449 struct mro_meta* meta;
453 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
455 meta = HvMROMETA(stash);
456 if (!meta->mro_which)
457 Perl_croak(aTHX_ "panic: invalid MRO!");
458 return meta->mro_which->resolve(aTHX_ stash, 0);
462 =for apidoc mro_isa_changed_in
464 Takes the necessary steps (cache invalidations, mostly)
465 when the @ISA of the given package has changed. Invoked
466 by the C<setisa> magic, should not need to invoke directly.
471 Perl_mro_isa_changed_in(pTHX_ HV* stash)
480 struct mro_meta * meta;
482 const char * const stashname = HvNAME_get(stash);
483 const STRLEN stashname_len = HvNAMELEN_get(stash);
486 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
488 /* wipe out the cached linearizations for this stash */
489 meta = HvMROMETA(stash);
490 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
491 SvREFCNT_dec((SV*)meta->mro_linear_c3);
492 meta->mro_linear_dfs = NULL;
493 meta->mro_linear_c3 = NULL;
495 /* Inc the package generation, since our @ISA changed */
498 /* Wipe the global method cache if this package
499 is UNIVERSAL or one of its parents */
501 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
502 isarev = svp ? (HV*)*svp : NULL;
504 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
505 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
509 else { /* Wipe the local method cache otherwise */
511 is_universal = FALSE;
514 /* wipe next::method cache too */
515 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
517 /* Iterate the isarev (classes that are our children),
518 wiping out their linearization and method caches */
521 while((iter = hv_iternext(isarev))) {
522 SV* const revkey = hv_iterkeysv(iter);
523 HV* revstash = gv_stashsv(revkey, 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, 0, 0);
556 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
558 mroisarev = (HV*)HeVAL(he);
560 /* This hash only ever contains PL_sv_yes. Storing it over itself is
561 almost as cheap as calling hv_exists, so on aggregate we expect to
562 save time by not making two calls to the common HV code for the
563 case where it doesn't exist. */
565 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
569 while((iter = hv_iternext(isarev))) {
571 char* const revkey = hv_iterkey(iter, &revkeylen);
572 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
579 =for apidoc mro_method_changed_in
581 Invalidates method caching on any child classes
582 of the given stash, so that they might notice
583 the changes in this one.
585 Ideally, all instances of C<PL_sub_generation++> in
586 perl source outside of C<mro.c> should be
587 replaced by calls to this.
589 Perl automatically handles most of the common
590 ways a method might be redefined. However, there
591 are a few ways you could change a method in a stash
592 without the cache code noticing, in which case you
593 need to call this method afterwards:
595 1) Directly manipulating the stash HV entries from
598 2) Assigning a reference to a readonly scalar
599 constant into a stash entry in order to create
600 a constant subroutine (like constant.pm
603 This same method is available from pure perl
604 via, C<mro::method_changed_in(classname)>.
609 Perl_mro_method_changed_in(pTHX_ HV *stash)
611 const char * const stashname = HvNAME_get(stash);
612 const STRLEN stashname_len = HvNAMELEN_get(stash);
614 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
615 HV * const isarev = svp ? (HV*)*svp : NULL;
618 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
620 /* Inc the package generation, since a local method changed */
621 HvMROMETA(stash)->pkg_gen++;
623 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
624 invalidate all method caches globally */
625 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
626 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
631 /* else, invalidate the method caches of all child classes,
637 while((iter = hv_iternext(isarev))) {
638 SV* const revkey = hv_iterkeysv(iter);
639 HV* const revstash = gv_stashsv(revkey, 0);
640 struct mro_meta* mrometa;
642 if(!revstash) continue;
643 mrometa = HvMROMETA(revstash);
644 mrometa->cache_gen++;
645 if(mrometa->mro_nextmethod)
646 hv_clear(mrometa->mro_nextmethod);
651 /* These two are static helpers for next::method and friends,
652 and re-implement a bunch of the code from pp_caller() in
653 a more efficient manner for this particular usage.
657 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
659 for (i = startingblock; i >= 0; i--) {
660 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
667 XS(XS_mro_get_linear_isa);
670 XS(XS_mro_get_isarev);
671 XS(XS_mro_is_universal);
672 XS(XS_mro_invalidate_method_caches);
673 XS(XS_mro_method_changed_in);
674 XS(XS_mro_get_pkg_gen);
678 Perl_boot_core_mro(pTHX)
681 static const char file[] = __FILE__;
683 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
684 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
685 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
686 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
687 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
688 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
689 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
690 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
691 newXS("mro::_nextcan", XS_mro_nextcan, file);
694 XS(XS_mro_get_linear_isa) {
703 if(items < 1 || items > 2)
704 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
707 class_stash = gv_stashsv(classname, 0);
710 /* No stash exists yet, give them just the classname */
711 AV* isalin = newAV();
712 av_push(isalin, newSVsv(classname));
713 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
717 const char* const which = SvPV_nolen(ST(1));
718 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
720 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
721 RETVAL = algo->resolve(aTHX_ class_stash, 0);
724 RETVAL = mro_get_linear_isa(class_stash);
727 ST(0) = newRV_inc((SV*)RETVAL);
737 const char* whichstr;
738 const struct mro_alg *which;
740 struct mro_meta* meta;
745 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
748 whichstr = SvPV_nolen(ST(1));
749 class_stash = gv_stashsv(classname, GV_ADD);
750 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
751 meta = HvMROMETA(class_stash);
753 which = S_get_mro_from_name(aTHX_ whichstr);
755 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
757 if(meta->mro_which != which) {
758 meta->mro_which = which;
759 /* Only affects local method cache, not
760 even child classes */
762 if(meta->mro_nextmethod)
763 hv_clear(meta->mro_nextmethod);
780 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
783 class_stash = gv_stashsv(classname, 0);
785 ST(0) = sv_2mortal(newSVpv(class_stash
786 ? HvMROMETA(class_stash)->mro_which->name
791 XS(XS_mro_get_isarev)
803 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
810 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
811 isarev = he ? (HV*)HeVAL(he) : NULL;
817 while((iter = hv_iternext(isarev)))
818 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
820 XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
826 XS(XS_mro_is_universal)
833 STRLEN classname_len;
839 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
843 classname_pv = SvPV_nolen(classname);
844 classname_len = strlen(classname_pv);
846 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
847 isarev = he ? (HV*)HeVAL(he) : NULL;
849 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
850 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
856 XS(XS_mro_invalidate_method_caches)
864 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
871 XS(XS_mro_method_changed_in)
881 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
885 class_stash = gv_stashsv(classname, 0);
886 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
888 mro_method_changed_in(class_stash);
893 XS(XS_mro_get_pkg_gen)
903 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
907 class_stash = gv_stashsv(classname, 0);
911 XPUSHs(sv_2mortal(newSViv(
912 class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
924 const I32 throw_nomethod = SvIVX(ST(1));
925 register I32 cxix = cxstack_ix;
926 register const PERL_CONTEXT *ccstack = cxstack;
927 const PERL_SI *top_si = PL_curstackinfo;
930 const char *fq_subname;
932 STRLEN stashname_len;
940 struct mro_meta* selfmeta;
948 if(sv_isobject(self))
949 selfstash = SvSTASH(SvRV(self));
951 selfstash = gv_stashsv(self, 0);
955 hvname = HvNAME_get(selfstash);
957 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
959 /* This block finds the contextually-enclosing fully-qualified subname,
960 much like looking at (caller($i))[3] until you find a real sub that
961 isn't ANON, etc (also skips over pureperl next::method, etc) */
962 for(i = 0; i < 2; i++) {
963 cxix = __dopoptosub_at(ccstack, cxix);
966 STRLEN fq_subname_len;
968 /* we may be in a higher stacklevel, so dig down deeper */
970 if(top_si->si_type == PERLSI_MAIN)
971 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
972 top_si = top_si->si_prev;
973 ccstack = top_si->si_cxstack;
974 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
977 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
978 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
979 cxix = __dopoptosub_at(ccstack, cxix - 1);
984 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
985 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
986 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
993 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
996 cxix = __dopoptosub_at(ccstack, cxix - 1);
1000 /* we found a real sub here */
1001 sv = sv_2mortal(newSV(0));
1003 gv_efullname3(sv, cvgv, NULL);
1005 fq_subname = SvPVX(sv);
1006 fq_subname_len = SvCUR(sv);
1008 subname = strrchr(fq_subname, ':');
1010 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1013 subname_len = fq_subname_len - (subname - fq_subname);
1014 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1015 cxix = __dopoptosub_at(ccstack, cxix - 1);
1023 /* If we made it to here, we found our context */
1025 /* Initialize the next::method cache for this stash
1027 selfmeta = HvMROMETA(selfstash);
1028 if(!(nmcache = selfmeta->mro_nextmethod)) {
1029 nmcache = selfmeta->mro_nextmethod = newHV();
1031 else { /* Use the cached coderef if it exists */
1032 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1034 SV* const val = HeVAL(cache_entry);
1035 if(val == &PL_sv_undef) {
1037 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1040 XPUSHs(sv_2mortal(newRV_inc(val)));
1045 /* beyond here is just for cache misses, so perf isn't as critical */
1047 stashname_len = subname - fq_subname - 2;
1048 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
1050 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1052 linear_svp = AvARRAY(linear_av);
1053 entries = AvFILLp(linear_av) + 1;
1055 /* Walk down our MRO, skipping everything up
1056 to the contextually enclosing class */
1058 SV * const linear_sv = *linear_svp++;
1060 if(sv_eq(linear_sv, stashname))
1064 /* Now search the remainder of the MRO for the
1065 same method name as the contextually enclosing
1069 SV * const linear_sv = *linear_svp++;
1075 curstash = gv_stashsv(linear_sv, FALSE);
1078 if (ckWARN(WARN_SYNTAX))
1079 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1080 (void*)linear_sv, hvname);
1086 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1092 if (SvTYPE(candidate) != SVt_PVGV)
1093 gv_init(candidate, curstash, subname, subname_len, TRUE);
1095 /* Notably, we only look for real entries, not method cache
1096 entries, because in C3 the method cache of a parent is not
1097 valid for the child */
1098 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1099 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1100 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1101 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1107 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1109 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1115 * c-indentation-style: bsd
1117 * indent-tabs-mode: t
1120 * ex: set ts=8 sts=4 sw=4 noet: