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 will need to upgrade it to an HV (which sv_upgrade() can
560 mroisarev = (HV*)HeVAL(he);
562 SvUPGRADE((SV*)mroisarev, SVt_PVHV);
564 /* This hash only ever contains PL_sv_yes. Storing it over itself is
565 almost as cheap as calling hv_exists, so on aggregate we expect to
566 save time by not making two calls to the common HV code for the
567 case where it doesn't exist. */
569 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
573 while((iter = hv_iternext(isarev))) {
575 char* const revkey = hv_iterkey(iter, &revkeylen);
576 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
583 =for apidoc mro_method_changed_in
585 Invalidates method caching on any child classes
586 of the given stash, so that they might notice
587 the changes in this one.
589 Ideally, all instances of C<PL_sub_generation++> in
590 perl source outside of C<mro.c> should be
591 replaced by calls to this.
593 Perl automatically handles most of the common
594 ways a method might be redefined. However, there
595 are a few ways you could change a method in a stash
596 without the cache code noticing, in which case you
597 need to call this method afterwards:
599 1) Directly manipulating the stash HV entries from
602 2) Assigning a reference to a readonly scalar
603 constant into a stash entry in order to create
604 a constant subroutine (like constant.pm
607 This same method is available from pure perl
608 via, C<mro::method_changed_in(classname)>.
613 Perl_mro_method_changed_in(pTHX_ HV *stash)
615 const char * const stashname = HvNAME_get(stash);
616 const STRLEN stashname_len = HvNAMELEN_get(stash);
618 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
619 HV * const isarev = svp ? (HV*)*svp : NULL;
622 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
624 /* Inc the package generation, since a local method changed */
625 HvMROMETA(stash)->pkg_gen++;
627 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
628 invalidate all method caches globally */
629 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
630 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
635 /* else, invalidate the method caches of all child classes,
641 while((iter = hv_iternext(isarev))) {
643 const char* const revkey = hv_iterkey(iter, &len);
644 HV* const revstash = gv_stashpvn(revkey, len, 0);
645 struct mro_meta* mrometa;
647 if(!revstash) continue;
648 mrometa = HvMROMETA(revstash);
649 mrometa->cache_gen++;
650 if(mrometa->mro_nextmethod)
651 hv_clear(mrometa->mro_nextmethod);
656 /* These two are static helpers for next::method and friends,
657 and re-implement a bunch of the code from pp_caller() in
658 a more efficient manner for this particular usage.
662 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
664 for (i = startingblock; i >= 0; i--) {
665 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
672 XS(XS_mro_get_linear_isa);
675 XS(XS_mro_get_isarev);
676 XS(XS_mro_is_universal);
677 XS(XS_mro_invalidate_method_caches);
678 XS(XS_mro_method_changed_in);
679 XS(XS_mro_get_pkg_gen);
683 Perl_boot_core_mro(pTHX)
686 static const char file[] = __FILE__;
688 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
689 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
690 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
691 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
692 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
693 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
694 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
695 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
696 newXS("mro::_nextcan", XS_mro_nextcan, file);
699 XS(XS_mro_get_linear_isa) {
708 if(items < 1 || items > 2)
709 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
712 class_stash = gv_stashsv(classname, 0);
715 /* No stash exists yet, give them just the classname */
716 AV* isalin = newAV();
717 av_push(isalin, newSVsv(classname));
718 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
722 const char* const which = SvPV_nolen(ST(1));
723 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
725 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
726 RETVAL = algo->resolve(aTHX_ class_stash, 0);
729 RETVAL = mro_get_linear_isa(class_stash);
732 ST(0) = newRV_inc((SV*)RETVAL);
742 const char* whichstr;
743 const struct mro_alg *which;
745 struct mro_meta* meta;
750 Perl_croak(aTHX_ "Usage: mro::set_mro(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);
785 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
788 class_stash = gv_stashsv(classname, 0);
790 ST(0) = sv_2mortal(newSVpv(class_stash
791 ? HvMROMETA(class_stash)->mro_which->name
796 XS(XS_mro_get_isarev)
808 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
815 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
816 isarev = he ? (HV*)HeVAL(he) : NULL;
822 while((iter = hv_iternext(isarev)))
823 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
825 mXPUSHs(newRV_noinc((SV*)ret_array));
831 XS(XS_mro_is_universal)
838 STRLEN classname_len;
844 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
848 classname_pv = SvPV(classname,classname_len);
850 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
851 isarev = he ? (HV*)HeVAL(he) : NULL;
853 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
854 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
860 XS(XS_mro_invalidate_method_caches)
868 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
875 XS(XS_mro_method_changed_in)
885 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
889 class_stash = gv_stashsv(classname, 0);
890 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
892 mro_method_changed_in(class_stash);
897 XS(XS_mro_get_pkg_gen)
907 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
911 class_stash = gv_stashsv(classname, 0);
915 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
926 const I32 throw_nomethod = SvIVX(ST(1));
927 register I32 cxix = cxstack_ix;
928 register const PERL_CONTEXT *ccstack = cxstack;
929 const PERL_SI *top_si = PL_curstackinfo;
932 const char *fq_subname;
934 STRLEN stashname_len;
942 struct mro_meta* selfmeta;
950 if(sv_isobject(self))
951 selfstash = SvSTASH(SvRV(self));
953 selfstash = gv_stashsv(self, 0);
957 hvname = HvNAME_get(selfstash);
959 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
961 /* This block finds the contextually-enclosing fully-qualified subname,
962 much like looking at (caller($i))[3] until you find a real sub that
963 isn't ANON, etc (also skips over pureperl next::method, etc) */
964 for(i = 0; i < 2; i++) {
965 cxix = __dopoptosub_at(ccstack, cxix);
968 STRLEN fq_subname_len;
970 /* we may be in a higher stacklevel, so dig down deeper */
972 if(top_si->si_type == PERLSI_MAIN)
973 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
974 top_si = top_si->si_prev;
975 ccstack = top_si->si_cxstack;
976 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
979 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
980 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
981 cxix = __dopoptosub_at(ccstack, cxix - 1);
986 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
987 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
988 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
995 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
998 cxix = __dopoptosub_at(ccstack, cxix - 1);
1002 /* we found a real sub here */
1003 sv = sv_2mortal(newSV(0));
1005 gv_efullname3(sv, cvgv, NULL);
1007 fq_subname = SvPVX(sv);
1008 fq_subname_len = SvCUR(sv);
1010 subname = strrchr(fq_subname, ':');
1012 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1015 subname_len = fq_subname_len - (subname - fq_subname);
1016 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1017 cxix = __dopoptosub_at(ccstack, cxix - 1);
1025 /* If we made it to here, we found our context */
1027 /* Initialize the next::method cache for this stash
1029 selfmeta = HvMROMETA(selfstash);
1030 if(!(nmcache = selfmeta->mro_nextmethod)) {
1031 nmcache = selfmeta->mro_nextmethod = newHV();
1033 else { /* Use the cached coderef if it exists */
1034 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1036 SV* const val = HeVAL(cache_entry);
1037 if(val == &PL_sv_undef) {
1039 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1042 mXPUSHs(newRV_inc(val));
1047 /* beyond here is just for cache misses, so perf isn't as critical */
1049 stashname_len = subname - fq_subname - 2;
1050 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1052 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1054 linear_svp = AvARRAY(linear_av);
1055 entries = AvFILLp(linear_av) + 1;
1057 /* Walk down our MRO, skipping everything up
1058 to the contextually enclosing class */
1060 SV * const linear_sv = *linear_svp++;
1062 if(sv_eq(linear_sv, stashname))
1066 /* Now search the remainder of the MRO for the
1067 same method name as the contextually enclosing
1071 SV * const linear_sv = *linear_svp++;
1077 curstash = gv_stashsv(linear_sv, FALSE);
1080 if (ckWARN(WARN_SYNTAX))
1081 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1082 (void*)linear_sv, hvname);
1088 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1094 if (SvTYPE(candidate) != SVt_PVGV)
1095 gv_init(candidate, curstash, subname, subname_len, TRUE);
1097 /* Notably, we only look for real entries, not method cache
1098 entries, because in C3 the method cache of a parent is not
1099 valid for the child */
1100 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1101 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1102 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1103 mXPUSHs(newRV_inc((SV*)cand_cv));
1109 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1111 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1117 * c-indentation-style: bsd
1119 * indent-tabs-mode: t
1122 * ex: set ts=8 sts=4 sw=4 noet: