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));
93 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->isa, param));
98 #endif /* USE_ITHREADS */
101 Perl_get_isa_hash(pTHX_ HV *const stash)
104 struct mro_meta *const meta = HvMROMETA(stash);
106 PERL_ARGS_ASSERT_GET_ISA_HASH;
109 mro_get_linear_isa_dfs(stash, 0);
115 =for apidoc mro_get_linear_isa_dfs
117 Returns the Depth-First Search linearization of @ISA
118 the given stash. The return value is a read-only AV*.
119 C<level> should be 0 (it is used internally in this
120 function's recursion).
122 You are responsible for C<SvREFCNT_inc()> on the
123 return value if you plan to store it anywhere
124 semi-permanently (otherwise it might be deleted
125 out from under you the next time the cache is
131 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
138 struct mro_meta* meta;
142 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
143 assert(HvAUX(stash));
145 stashhek = HvNAME_HEK(stash);
147 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
150 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
153 meta = HvMROMETA(stash);
155 /* return cache if valid */
156 if((retval = meta->mro_linear_dfs)) {
160 /* not in cache, make a new one */
162 retval = (AV*)sv_2mortal((SV *)newAV());
163 /* We use this later in this function, but don't need a reference to it
164 beyond the end of this function, so reference count is fine. */
165 our_name = newSVhek(stashhek);
166 av_push(retval, our_name); /* add ourselves at the top */
169 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
170 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
172 /* "stored" is used to keep track of all of the classnames we have added to
173 the MRO so far, so we can do a quick exists check and avoid adding
174 duplicate classnames to the MRO as we go.
175 It's then retained to be re-used as a fast lookup for ->isa(), by adding
176 our own name and "UNIVERSAL" to it. */
178 stored = (HV*)sv_2mortal((SV*)newHV());
180 if(av && AvFILLp(av) >= 0) {
182 SV **svp = AvARRAY(av);
183 I32 items = AvFILLp(av) + 1;
187 SV* const sv = *svp++;
188 HV* const basestash = gv_stashsv(sv, 0);
193 /* if no stash exists for this @ISA member,
194 simply add it to the MRO and move on */
199 /* otherwise, recurse into ourselves for the MRO
200 of this @ISA member, and append their MRO to ours.
201 The recursive call could throw an exception, which
202 has memory management implications here, hence the use of
204 const AV *const subrv
205 = mro_get_linear_isa_dfs(basestash, level + 1);
207 subrv_p = AvARRAY(subrv);
208 subrv_items = AvFILLp(subrv) + 1;
210 while(subrv_items--) {
211 SV *const subsv = *subrv_p++;
212 /* LVALUE fetch will create a new undefined SV if necessary
214 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
216 if(HeVAL(he) != &PL_sv_undef) {
217 /* It was newly created. Steal it for our new SV, and
218 replace it in the hash with the "real" thing. */
219 SV *const val = HeVAL(he);
220 HEK *const key = HeKEY_hek(he);
222 HeVAL(he) = &PL_sv_undef;
223 /* Save copying by making a shared hash key scalar. We
224 inline this here rather than calling Perl_newSVpvn_share
225 because we already have the scalar, and we already have
227 assert(SvTYPE(val) == SVt_NULL);
228 sv_upgrade(val, SVt_PV);
229 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
230 SvCUR_set(val, HEK_LEN(key));
237 av_push(retval, val);
243 /* now that we're past the exception dangers, grab our own reference to
244 the AV we're about to use for the result. The reference owned by the
245 mortals' stack will be released soon, so everything will balance. */
246 SvREFCNT_inc_simple_void_NN(retval);
248 SvREFCNT_inc_simple_void_NN(stored);
251 hv_store_ent(stored, our_name, &PL_sv_undef, 0);
252 hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
254 /* we don't want anyone modifying the cache entry but us,
255 and we do so by replacing it completely */
256 SvREADONLY_on(retval);
257 SvREADONLY_on(stored);
259 meta->mro_linear_dfs = retval;
265 =for apidoc mro_get_linear_isa_c3
267 Returns the C3 linearization of @ISA
268 the given stash. The return value is a read-only AV*.
269 C<level> should be 0 (it is used internally in this
270 function's recursion).
272 You are responsible for C<SvREFCNT_inc()> on the
273 return value if you plan to store it anywhere
274 semi-permanently (otherwise it might be deleted
275 out from under you the next time the cache is
282 S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
289 struct mro_meta* meta;
291 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
292 assert(HvAUX(stash));
294 stashhek = HvNAME_HEK(stash);
296 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
299 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
302 meta = HvMROMETA(stash);
304 /* return cache if valid */
305 if((retval = meta->mro_linear_c3)) {
309 /* not in cache, make a new one */
311 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
312 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
314 /* For a better idea how the rest of this works, see the much clearer
315 pure perl version in Algorithm::C3 0.01:
316 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
317 (later versions go about it differently than this code for speed reasons)
320 if(isa && AvFILLp(isa) >= 0) {
323 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
324 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
327 /* This builds @seqs, which is an array of arrays.
328 The members of @seqs are the MROs of
329 the members of @ISA, followed by @ISA itself.
331 I32 items = AvFILLp(isa) + 1;
332 SV** isa_ptr = AvARRAY(isa);
334 SV* const isa_item = *isa_ptr++;
335 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
336 if(!isa_item_stash) {
337 /* if no stash, make a temporary fake MRO
338 containing just itself */
339 AV* const isa_lin = newAV();
340 av_push(isa_lin, newSVsv(isa_item));
341 av_push(seqs, (SV*)isa_lin);
345 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
346 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
349 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
351 /* This builds "heads", which as an array of integer array
352 indices, one per seq, which point at the virtual "head"
353 of the seq (initially zero) */
354 Newxz(heads, AvFILLp(seqs)+1, I32);
356 /* This builds %tails, which has one key for every class
357 mentioned in the tail of any sequence in @seqs (tail meaning
358 everything after the first class, the "head"). The value
359 is how many times this key appears in the tails of @seqs.
361 seqs_ptr = AvARRAY(seqs);
362 seqs_items = AvFILLp(seqs) + 1;
363 while(seqs_items--) {
364 AV* const seq = (AV*)*seqs_ptr++;
365 I32 seq_items = AvFILLp(seq);
367 SV** seq_ptr = AvARRAY(seq) + 1;
369 SV* const seqitem = *seq_ptr++;
370 /* LVALUE fetch will create a new undefined SV if necessary
372 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
374 SV* const val = HeVAL(he);
375 /* This will increment undef to 1, which is what we
376 want for a newly created entry. */
383 /* Initialize retval to build the return value in */
385 av_push(retval, newSVhek(stashhek)); /* us first */
387 /* This loop won't terminate until we either finish building
388 the MRO, or get an exception. */
394 /* "foreach $seq (@seqs)" */
395 SV** const avptr = AvARRAY(seqs);
396 for(s = 0; s <= AvFILLp(seqs); s++) {
398 AV * const seq = (AV*)(avptr[s]);
400 if(!seq) continue; /* skip empty seqs */
401 svp = av_fetch(seq, heads[s], 0);
402 seqhead = *svp; /* seqhead = head of this seq */
406 /* if we haven't found a winner for this round yet,
407 and this seqhead is not in tails (or the count
408 for it in tails has dropped to zero), then this
409 seqhead is our new winner, and is added to the
410 final MRO immediately */
412 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
413 && (val = HeVAL(tail_entry))
416 winner = newSVsv(cand);
417 av_push(retval, winner);
418 /* note however that even when we find a winner,
419 we continue looping over @seqs to do housekeeping */
421 if(!sv_cmp(seqhead, winner)) {
422 /* Once we have a winner (including the iteration
423 where we first found him), inc the head ptr
424 for any seq which had the winner as a head,
425 NULL out any seq which is now empty,
426 and adjust tails for consistency */
428 const int new_head = ++heads[s];
429 if(new_head > AvFILLp(seq)) {
430 SvREFCNT_dec(avptr[s]);
436 /* Because we know this new seqhead used to be
437 a tail, we can assume it is in tails and has
438 a positive value, which we need to dec */
439 svp = av_fetch(seq, new_head, 0);
441 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
442 val = HeVAL(tail_entry);
448 /* if we found no candidates, we are done building the MRO.
449 !cand means no seqs have any entries left to check */
455 /* If we had candidates, but nobody won, then the @ISA
456 hierarchy is not C3-incompatible */
458 /* we have to do some cleanup before we croak */
460 SvREFCNT_dec(retval);
463 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
464 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
468 else { /* @ISA was undefined or empty */
469 /* build a retval containing only ourselves */
471 av_push(retval, newSVhek(stashhek));
474 /* we don't want anyone modifying the cache entry but us,
475 and we do so by replacing it completely */
476 SvREADONLY_on(retval);
478 meta->mro_linear_c3 = retval;
483 =for apidoc mro_get_linear_isa
485 Returns either C<mro_get_linear_isa_c3> or
486 C<mro_get_linear_isa_dfs> for the given stash,
487 dependant upon which MRO is in effect
488 for that stash. The return value is a
491 You are responsible for C<SvREFCNT_inc()> on the
492 return value if you plan to store it anywhere
493 semi-permanently (otherwise it might be deleted
494 out from under you the next time the cache is
500 Perl_mro_get_linear_isa(pTHX_ HV *stash)
502 struct mro_meta* meta;
504 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
506 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
508 meta = HvMROMETA(stash);
509 if (!meta->mro_which)
510 Perl_croak(aTHX_ "panic: invalid MRO!");
511 return meta->mro_which->resolve(aTHX_ stash, 0);
515 =for apidoc mro_isa_changed_in
517 Takes the necessary steps (cache invalidations, mostly)
518 when the @ISA of the given package has changed. Invoked
519 by the C<setisa> magic, should not need to invoke directly.
524 Perl_mro_isa_changed_in(pTHX_ HV* stash)
533 struct mro_meta * meta;
535 const char * const stashname = HvNAME_get(stash);
536 const STRLEN stashname_len = HvNAMELEN_get(stash);
538 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
541 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
543 /* wipe out the cached linearizations for this stash */
544 meta = HvMROMETA(stash);
545 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
546 SvREFCNT_dec((SV*)meta->mro_linear_c3);
547 meta->mro_linear_dfs = NULL;
548 meta->mro_linear_c3 = NULL;
550 /* Inc the package generation, since our @ISA changed */
553 /* Wipe the global method cache if this package
554 is UNIVERSAL or one of its parents */
556 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
557 isarev = svp ? (HV*)*svp : NULL;
559 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
560 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
564 else { /* Wipe the local method cache otherwise */
566 is_universal = FALSE;
569 /* wipe next::method cache too */
570 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
572 /* Iterate the isarev (classes that are our children),
573 wiping out their linearization and method caches */
576 while((iter = hv_iternext(isarev))) {
578 const char* const revkey = hv_iterkey(iter, &len);
579 HV* revstash = gv_stashpvn(revkey, len, 0);
580 struct mro_meta* revmeta;
582 if(!revstash) continue;
583 revmeta = HvMROMETA(revstash);
584 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
585 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
586 revmeta->mro_linear_dfs = NULL;
587 revmeta->mro_linear_c3 = NULL;
589 revmeta->cache_gen++;
590 if(revmeta->mro_nextmethod)
591 hv_clear(revmeta->mro_nextmethod);
595 /* Now iterate our MRO (parents), and do a few things:
596 1) instantiate with the "fake" flag if they don't exist
597 2) flag them as universal if we are universal
598 3) Add everything from our isarev to their isarev
601 /* We're starting at the 2nd element, skipping ourselves here */
602 linear_mro = mro_get_linear_isa(stash);
603 svp = AvARRAY(linear_mro) + 1;
604 items = AvFILLp(linear_mro);
607 SV* const sv = *svp++;
610 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
612 /* That fetch should not fail. But if it had to create a new SV for
613 us, then will need to upgrade it to an HV (which sv_upgrade() can
616 mroisarev = (HV*)HeVAL(he);
618 SvUPGRADE((SV*)mroisarev, SVt_PVHV);
620 /* This hash only ever contains PL_sv_yes. Storing it over itself is
621 almost as cheap as calling hv_exists, so on aggregate we expect to
622 save time by not making two calls to the common HV code for the
623 case where it doesn't exist. */
625 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
629 while((iter = hv_iternext(isarev))) {
631 char* const revkey = hv_iterkey(iter, &revkeylen);
632 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
639 =for apidoc mro_method_changed_in
641 Invalidates method caching on any child classes
642 of the given stash, so that they might notice
643 the changes in this one.
645 Ideally, all instances of C<PL_sub_generation++> in
646 perl source outside of C<mro.c> should be
647 replaced by calls to this.
649 Perl automatically handles most of the common
650 ways a method might be redefined. However, there
651 are a few ways you could change a method in a stash
652 without the cache code noticing, in which case you
653 need to call this method afterwards:
655 1) Directly manipulating the stash HV entries from
658 2) Assigning a reference to a readonly scalar
659 constant into a stash entry in order to create
660 a constant subroutine (like constant.pm
663 This same method is available from pure perl
664 via, C<mro::method_changed_in(classname)>.
669 Perl_mro_method_changed_in(pTHX_ HV *stash)
671 const char * const stashname = HvNAME_get(stash);
672 const STRLEN stashname_len = HvNAMELEN_get(stash);
674 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
675 HV * const isarev = svp ? (HV*)*svp : NULL;
677 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
680 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
682 /* Inc the package generation, since a local method changed */
683 HvMROMETA(stash)->pkg_gen++;
685 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
686 invalidate all method caches globally */
687 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
688 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
693 /* else, invalidate the method caches of all child classes,
699 while((iter = hv_iternext(isarev))) {
701 const char* const revkey = hv_iterkey(iter, &len);
702 HV* const revstash = gv_stashpvn(revkey, len, 0);
703 struct mro_meta* mrometa;
705 if(!revstash) continue;
706 mrometa = HvMROMETA(revstash);
707 mrometa->cache_gen++;
708 if(mrometa->mro_nextmethod)
709 hv_clear(mrometa->mro_nextmethod);
714 /* These two are static helpers for next::method and friends,
715 and re-implement a bunch of the code from pp_caller() in
716 a more efficient manner for this particular usage.
720 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
722 for (i = startingblock; i >= 0; i--) {
723 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
730 XS(XS_mro_get_linear_isa);
733 XS(XS_mro_get_isarev);
734 XS(XS_mro_is_universal);
735 XS(XS_mro_invalidate_method_caches);
736 XS(XS_mro_method_changed_in);
737 XS(XS_mro_get_pkg_gen);
741 Perl_boot_core_mro(pTHX)
744 static const char file[] = __FILE__;
746 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
747 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
748 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
749 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
750 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
751 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
752 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
753 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
754 newXS("mro::_nextcan", XS_mro_nextcan, file);
757 XS(XS_mro_get_linear_isa) {
764 if(items < 1 || items > 2)
765 croak_xs_usage(cv, "classname [, type ]");
768 class_stash = gv_stashsv(classname, 0);
771 /* No stash exists yet, give them just the classname */
772 AV* isalin = newAV();
773 av_push(isalin, newSVsv(classname));
774 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
778 const char* const which = SvPV_nolen(ST(1));
779 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
781 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
782 RETVAL = algo->resolve(aTHX_ class_stash, 0);
785 RETVAL = mro_get_linear_isa(class_stash);
788 ST(0) = newRV_inc((SV*)RETVAL);
798 const char* whichstr;
799 const struct mro_alg *which;
801 struct mro_meta* meta;
804 croak_xs_usage(cv, "classname, type");
807 whichstr = SvPV_nolen(ST(1));
808 class_stash = gv_stashsv(classname, GV_ADD);
809 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
810 meta = HvMROMETA(class_stash);
812 which = S_get_mro_from_name(aTHX_ whichstr);
814 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
816 if(meta->mro_which != which) {
817 meta->mro_which = which;
818 /* Only affects local method cache, not
819 even child classes */
821 if(meta->mro_nextmethod)
822 hv_clear(meta->mro_nextmethod);
837 croak_xs_usage(cv, "classname");
840 class_stash = gv_stashsv(classname, 0);
842 ST(0) = sv_2mortal(newSVpv(class_stash
843 ? HvMROMETA(class_stash)->mro_which->name
848 XS(XS_mro_get_isarev)
858 croak_xs_usage(cv, "classname");
865 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
866 isarev = he ? (HV*)HeVAL(he) : NULL;
872 while((iter = hv_iternext(isarev)))
873 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
875 mXPUSHs(newRV_noinc((SV*)ret_array));
881 XS(XS_mro_is_universal)
888 STRLEN classname_len;
892 croak_xs_usage(cv, "classname");
896 classname_pv = SvPV(classname,classname_len);
898 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
899 isarev = he ? (HV*)HeVAL(he) : NULL;
901 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
902 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
908 XS(XS_mro_invalidate_method_caches)
914 croak_xs_usage(cv, "");
921 XS(XS_mro_method_changed_in)
929 croak_xs_usage(cv, "classname");
933 class_stash = gv_stashsv(classname, 0);
934 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
936 mro_method_changed_in(class_stash);
941 XS(XS_mro_get_pkg_gen)
949 croak_xs_usage(cv, "classname");
953 class_stash = gv_stashsv(classname, 0);
957 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
968 const I32 throw_nomethod = SvIVX(ST(1));
969 register I32 cxix = cxstack_ix;
970 register const PERL_CONTEXT *ccstack = cxstack;
971 const PERL_SI *top_si = PL_curstackinfo;
974 const char *fq_subname;
976 STRLEN stashname_len;
984 struct mro_meta* selfmeta;
992 if(sv_isobject(self))
993 selfstash = SvSTASH(SvRV(self));
995 selfstash = gv_stashsv(self, GV_ADD);
999 hvname = HvNAME_get(selfstash);
1001 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
1003 /* This block finds the contextually-enclosing fully-qualified subname,
1004 much like looking at (caller($i))[3] until you find a real sub that
1005 isn't ANON, etc (also skips over pureperl next::method, etc) */
1006 for(i = 0; i < 2; i++) {
1007 cxix = __dopoptosub_at(ccstack, cxix);
1010 STRLEN fq_subname_len;
1012 /* we may be in a higher stacklevel, so dig down deeper */
1014 if(top_si->si_type == PERLSI_MAIN)
1015 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
1016 top_si = top_si->si_prev;
1017 ccstack = top_si->si_cxstack;
1018 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
1021 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
1022 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
1023 cxix = __dopoptosub_at(ccstack, cxix - 1);
1028 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
1029 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
1030 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1037 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1040 cxix = __dopoptosub_at(ccstack, cxix - 1);
1044 /* we found a real sub here */
1045 sv = sv_2mortal(newSV(0));
1047 gv_efullname3(sv, cvgv, NULL);
1049 fq_subname = SvPVX(sv);
1050 fq_subname_len = SvCUR(sv);
1052 subname = strrchr(fq_subname, ':');
1054 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1057 subname_len = fq_subname_len - (subname - fq_subname);
1058 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1059 cxix = __dopoptosub_at(ccstack, cxix - 1);
1067 /* If we made it to here, we found our context */
1069 /* Initialize the next::method cache for this stash
1071 selfmeta = HvMROMETA(selfstash);
1072 if(!(nmcache = selfmeta->mro_nextmethod)) {
1073 nmcache = selfmeta->mro_nextmethod = newHV();
1075 else { /* Use the cached coderef if it exists */
1076 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1078 SV* const val = HeVAL(cache_entry);
1079 if(val == &PL_sv_undef) {
1081 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1084 mXPUSHs(newRV_inc(val));
1089 /* beyond here is just for cache misses, so perf isn't as critical */
1091 stashname_len = subname - fq_subname - 2;
1092 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1094 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1096 linear_svp = AvARRAY(linear_av);
1097 entries = AvFILLp(linear_av) + 1;
1099 /* Walk down our MRO, skipping everything up
1100 to the contextually enclosing class */
1102 SV * const linear_sv = *linear_svp++;
1104 if(sv_eq(linear_sv, stashname))
1108 /* Now search the remainder of the MRO for the
1109 same method name as the contextually enclosing
1113 SV * const linear_sv = *linear_svp++;
1119 curstash = gv_stashsv(linear_sv, FALSE);
1122 if (ckWARN(WARN_SYNTAX))
1123 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1124 (void*)linear_sv, hvname);
1130 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1136 if (SvTYPE(candidate) != SVt_PVGV)
1137 gv_init(candidate, curstash, subname, subname_len, TRUE);
1139 /* Notably, we only look for real entries, not method cache
1140 entries, because in C3 the method cache of a parent is not
1141 valid for the child */
1142 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1143 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1144 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1145 mXPUSHs(newRV_inc((SV*)cand_cv));
1151 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1153 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1159 * c-indentation-style: bsd
1161 * indent-tabs-mode: t
1164 * ex: set ts=8 sts=4 sw=4 noet: