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 SvREFCNT_dec(meta->isa);
554 /* Inc the package generation, since our @ISA changed */
557 /* Wipe the global method cache if this package
558 is UNIVERSAL or one of its parents */
560 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
561 isarev = svp ? (HV*)*svp : NULL;
563 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
564 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
568 else { /* Wipe the local method cache otherwise */
570 is_universal = FALSE;
573 /* wipe next::method cache too */
574 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
576 /* Iterate the isarev (classes that are our children),
577 wiping out their linearization and method caches */
580 while((iter = hv_iternext(isarev))) {
582 const char* const revkey = hv_iterkey(iter, &len);
583 HV* revstash = gv_stashpvn(revkey, len, 0);
584 struct mro_meta* revmeta;
586 if(!revstash) continue;
587 revmeta = HvMROMETA(revstash);
588 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
589 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
590 revmeta->mro_linear_dfs = NULL;
591 revmeta->mro_linear_c3 = NULL;
593 revmeta->cache_gen++;
594 if(revmeta->mro_nextmethod)
595 hv_clear(revmeta->mro_nextmethod);
599 /* Now iterate our MRO (parents), and do a few things:
600 1) instantiate with the "fake" flag if they don't exist
601 2) flag them as universal if we are universal
602 3) Add everything from our isarev to their isarev
605 /* We're starting at the 2nd element, skipping ourselves here */
606 linear_mro = mro_get_linear_isa(stash);
607 svp = AvARRAY(linear_mro) + 1;
608 items = AvFILLp(linear_mro);
611 SV* const sv = *svp++;
614 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
616 /* That fetch should not fail. But if it had to create a new SV for
617 us, then will need to upgrade it to an HV (which sv_upgrade() can
620 mroisarev = (HV*)HeVAL(he);
622 SvUPGRADE((SV*)mroisarev, SVt_PVHV);
624 /* This hash only ever contains PL_sv_yes. Storing it over itself is
625 almost as cheap as calling hv_exists, so on aggregate we expect to
626 save time by not making two calls to the common HV code for the
627 case where it doesn't exist. */
629 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
633 while((iter = hv_iternext(isarev))) {
635 char* const revkey = hv_iterkey(iter, &revkeylen);
636 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
643 =for apidoc mro_method_changed_in
645 Invalidates method caching on any child classes
646 of the given stash, so that they might notice
647 the changes in this one.
649 Ideally, all instances of C<PL_sub_generation++> in
650 perl source outside of C<mro.c> should be
651 replaced by calls to this.
653 Perl automatically handles most of the common
654 ways a method might be redefined. However, there
655 are a few ways you could change a method in a stash
656 without the cache code noticing, in which case you
657 need to call this method afterwards:
659 1) Directly manipulating the stash HV entries from
662 2) Assigning a reference to a readonly scalar
663 constant into a stash entry in order to create
664 a constant subroutine (like constant.pm
667 This same method is available from pure perl
668 via, C<mro::method_changed_in(classname)>.
673 Perl_mro_method_changed_in(pTHX_ HV *stash)
675 const char * const stashname = HvNAME_get(stash);
676 const STRLEN stashname_len = HvNAMELEN_get(stash);
678 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
679 HV * const isarev = svp ? (HV*)*svp : NULL;
681 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
684 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
686 /* Inc the package generation, since a local method changed */
687 HvMROMETA(stash)->pkg_gen++;
689 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
690 invalidate all method caches globally */
691 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
692 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
697 /* else, invalidate the method caches of all child classes,
703 while((iter = hv_iternext(isarev))) {
705 const char* const revkey = hv_iterkey(iter, &len);
706 HV* const revstash = gv_stashpvn(revkey, len, 0);
707 struct mro_meta* mrometa;
709 if(!revstash) continue;
710 mrometa = HvMROMETA(revstash);
711 mrometa->cache_gen++;
712 if(mrometa->mro_nextmethod)
713 hv_clear(mrometa->mro_nextmethod);
718 /* These two are static helpers for next::method and friends,
719 and re-implement a bunch of the code from pp_caller() in
720 a more efficient manner for this particular usage.
724 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
726 for (i = startingblock; i >= 0; i--) {
727 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
734 XS(XS_mro_get_linear_isa);
737 XS(XS_mro_get_isarev);
738 XS(XS_mro_is_universal);
739 XS(XS_mro_invalidate_method_caches);
740 XS(XS_mro_method_changed_in);
741 XS(XS_mro_get_pkg_gen);
745 Perl_boot_core_mro(pTHX)
748 static const char file[] = __FILE__;
750 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
751 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
752 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
753 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
754 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
755 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
756 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
757 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
758 newXS("mro::_nextcan", XS_mro_nextcan, file);
761 XS(XS_mro_get_linear_isa) {
768 if(items < 1 || items > 2)
769 croak_xs_usage(cv, "classname [, type ]");
772 class_stash = gv_stashsv(classname, 0);
775 /* No stash exists yet, give them just the classname */
776 AV* isalin = newAV();
777 av_push(isalin, newSVsv(classname));
778 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
782 const char* const which = SvPV_nolen(ST(1));
783 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
785 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
786 RETVAL = algo->resolve(aTHX_ class_stash, 0);
789 RETVAL = mro_get_linear_isa(class_stash);
792 ST(0) = newRV_inc((SV*)RETVAL);
802 const char* whichstr;
803 const struct mro_alg *which;
805 struct mro_meta* meta;
808 croak_xs_usage(cv, "classname, type");
811 whichstr = SvPV_nolen(ST(1));
812 class_stash = gv_stashsv(classname, GV_ADD);
813 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
814 meta = HvMROMETA(class_stash);
816 which = S_get_mro_from_name(aTHX_ whichstr);
818 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
820 if(meta->mro_which != which) {
821 meta->mro_which = which;
822 /* Only affects local method cache, not
823 even child classes */
825 if(meta->mro_nextmethod)
826 hv_clear(meta->mro_nextmethod);
841 croak_xs_usage(cv, "classname");
844 class_stash = gv_stashsv(classname, 0);
846 ST(0) = sv_2mortal(newSVpv(class_stash
847 ? HvMROMETA(class_stash)->mro_which->name
852 XS(XS_mro_get_isarev)
862 croak_xs_usage(cv, "classname");
869 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
870 isarev = he ? (HV*)HeVAL(he) : NULL;
876 while((iter = hv_iternext(isarev)))
877 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
879 mXPUSHs(newRV_noinc((SV*)ret_array));
885 XS(XS_mro_is_universal)
892 STRLEN classname_len;
896 croak_xs_usage(cv, "classname");
900 classname_pv = SvPV(classname,classname_len);
902 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
903 isarev = he ? (HV*)HeVAL(he) : NULL;
905 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
906 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
912 XS(XS_mro_invalidate_method_caches)
918 croak_xs_usage(cv, "");
925 XS(XS_mro_method_changed_in)
933 croak_xs_usage(cv, "classname");
937 class_stash = gv_stashsv(classname, 0);
938 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
940 mro_method_changed_in(class_stash);
945 XS(XS_mro_get_pkg_gen)
953 croak_xs_usage(cv, "classname");
957 class_stash = gv_stashsv(classname, 0);
961 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
972 const I32 throw_nomethod = SvIVX(ST(1));
973 register I32 cxix = cxstack_ix;
974 register const PERL_CONTEXT *ccstack = cxstack;
975 const PERL_SI *top_si = PL_curstackinfo;
978 const char *fq_subname;
980 STRLEN stashname_len;
988 struct mro_meta* selfmeta;
996 if(sv_isobject(self))
997 selfstash = SvSTASH(SvRV(self));
999 selfstash = gv_stashsv(self, GV_ADD);
1003 hvname = HvNAME_get(selfstash);
1005 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
1007 /* This block finds the contextually-enclosing fully-qualified subname,
1008 much like looking at (caller($i))[3] until you find a real sub that
1009 isn't ANON, etc (also skips over pureperl next::method, etc) */
1010 for(i = 0; i < 2; i++) {
1011 cxix = __dopoptosub_at(ccstack, cxix);
1014 STRLEN fq_subname_len;
1016 /* we may be in a higher stacklevel, so dig down deeper */
1018 if(top_si->si_type == PERLSI_MAIN)
1019 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
1020 top_si = top_si->si_prev;
1021 ccstack = top_si->si_cxstack;
1022 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
1025 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
1026 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
1027 cxix = __dopoptosub_at(ccstack, cxix - 1);
1032 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
1033 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
1034 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1041 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1044 cxix = __dopoptosub_at(ccstack, cxix - 1);
1048 /* we found a real sub here */
1049 sv = sv_2mortal(newSV(0));
1051 gv_efullname3(sv, cvgv, NULL);
1053 fq_subname = SvPVX(sv);
1054 fq_subname_len = SvCUR(sv);
1056 subname = strrchr(fq_subname, ':');
1058 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1061 subname_len = fq_subname_len - (subname - fq_subname);
1062 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1063 cxix = __dopoptosub_at(ccstack, cxix - 1);
1071 /* If we made it to here, we found our context */
1073 /* Initialize the next::method cache for this stash
1075 selfmeta = HvMROMETA(selfstash);
1076 if(!(nmcache = selfmeta->mro_nextmethod)) {
1077 nmcache = selfmeta->mro_nextmethod = newHV();
1079 else { /* Use the cached coderef if it exists */
1080 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1082 SV* const val = HeVAL(cache_entry);
1083 if(val == &PL_sv_undef) {
1085 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1088 mXPUSHs(newRV_inc(val));
1093 /* beyond here is just for cache misses, so perf isn't as critical */
1095 stashname_len = subname - fq_subname - 2;
1096 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1098 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1100 linear_svp = AvARRAY(linear_av);
1101 entries = AvFILLp(linear_av) + 1;
1103 /* Walk down our MRO, skipping everything up
1104 to the contextually enclosing class */
1106 SV * const linear_sv = *linear_svp++;
1108 if(sv_eq(linear_sv, stashname))
1112 /* Now search the remainder of the MRO for the
1113 same method name as the contextually enclosing
1117 SV * const linear_sv = *linear_svp++;
1123 curstash = gv_stashsv(linear_sv, FALSE);
1126 if (ckWARN(WARN_SYNTAX))
1127 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1128 (void*)linear_sv, hvname);
1134 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1140 if (SvTYPE(candidate) != SVt_PVGV)
1141 gv_init(candidate, curstash, subname, subname_len, TRUE);
1143 /* Notably, we only look for real entries, not method cache
1144 entries, because in C3 the method cache of a parent is not
1145 valid for the child */
1146 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1147 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1148 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1149 mXPUSHs(newRV_inc((SV*)cand_cv));
1155 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1157 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1163 * c-indentation-style: bsd
1165 * indent-tabs-mode: t
1168 * ex: set ts=8 sts=4 sw=4 noet: