3 * Copyright (c) 2007 Brandon L Black
4 * Copyright (c) 2007, 2008 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first?
13 * You'll be last either way, Master Peregrin."
19 These functions are related to the method resolution order of perl classes
30 AV *(*resolve)(pTHX_ HV* stash, I32 level);
33 /* First one is the default */
34 static struct mro_alg mros[] = {
35 {"dfs", S_mro_get_linear_isa_dfs},
36 {"c3", S_mro_get_linear_isa_c3}
39 #define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
41 static const struct mro_alg *
42 S_get_mro_from_name(pTHX_ const char *const name) {
43 const struct mro_alg *algo = mros;
44 const struct mro_alg *const end = mros + NUMBER_OF_MROS;
46 if(strEQ(name, algo->name))
54 Perl_mro_meta_init(pTHX_ HV* stash)
56 struct mro_meta* newmeta;
58 PERL_ARGS_ASSERT_MRO_META_INIT;
60 assert(!(HvAUX(stash)->xhv_mro_meta));
61 Newxz(newmeta, 1, struct mro_meta);
62 HvAUX(stash)->xhv_mro_meta = newmeta;
63 newmeta->cache_gen = 1;
65 newmeta->mro_which = mros;
70 #if defined(USE_ITHREADS)
72 /* for sv_dup on new threads */
74 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
76 struct mro_meta* newmeta;
78 PERL_ARGS_ASSERT_MRO_META_DUP;
80 Newx(newmeta, 1, struct mro_meta);
81 Copy(smeta, newmeta, 1, struct mro_meta);
83 if (newmeta->mro_linear_dfs)
84 newmeta->mro_linear_dfs
85 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
86 if (newmeta->mro_linear_c3)
87 newmeta->mro_linear_c3
88 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
89 if (newmeta->mro_nextmethod)
90 newmeta->mro_nextmethod
91 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
94 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->isa, param));
99 #endif /* USE_ITHREADS */
102 Perl_get_isa_hash(pTHX_ HV *const stash)
105 struct mro_meta *const meta = HvMROMETA(stash);
107 PERL_ARGS_ASSERT_GET_ISA_HASH;
110 AV *const isa = mro_get_linear_isa(stash);
112 HV *const isa_hash = newHV();
113 /* Linearisation didn't build it for us, so do it here. */
114 SV *const *svp = AvARRAY(isa);
115 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
116 const HEK *const canon_name = HvNAME_HEK(stash);
118 while (svp < svp_end) {
119 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
122 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
123 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
124 HV_FETCH_ISSTORE, &PL_sv_undef,
125 HEK_HASH(canon_name));
126 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
128 SvREADONLY_on(isa_hash);
130 meta->isa = isa_hash;
137 =for apidoc mro_get_linear_isa_dfs
139 Returns the Depth-First Search linearization of @ISA
140 the given stash. The return value is a read-only AV*.
141 C<level> should be 0 (it is used internally in this
142 function's recursion).
144 You are responsible for C<SvREFCNT_inc()> on the
145 return value if you plan to store it anywhere
146 semi-permanently (otherwise it might be deleted
147 out from under you the next time the cache is
153 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
160 struct mro_meta* meta;
164 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
165 assert(HvAUX(stash));
167 stashhek = HvNAME_HEK(stash);
169 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
172 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
175 meta = HvMROMETA(stash);
177 /* return cache if valid */
178 if((retval = meta->mro_linear_dfs)) {
182 /* not in cache, make a new one */
184 retval = (AV*)sv_2mortal((SV *)newAV());
185 /* We use this later in this function, but don't need a reference to it
186 beyond the end of this function, so reference count is fine. */
187 our_name = newSVhek(stashhek);
188 av_push(retval, our_name); /* add ourselves at the top */
191 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
192 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
194 /* "stored" is used to keep track of all of the classnames we have added to
195 the MRO so far, so we can do a quick exists check and avoid adding
196 duplicate classnames to the MRO as we go.
197 It's then retained to be re-used as a fast lookup for ->isa(), by adding
198 our own name and "UNIVERSAL" to it. */
200 stored = (HV*)sv_2mortal((SV*)newHV());
202 if(av && AvFILLp(av) >= 0) {
204 SV **svp = AvARRAY(av);
205 I32 items = AvFILLp(av) + 1;
209 SV* const sv = *svp++;
210 HV* const basestash = gv_stashsv(sv, 0);
215 /* if no stash exists for this @ISA member,
216 simply add it to the MRO and move on */
221 /* otherwise, recurse into ourselves for the MRO
222 of this @ISA member, and append their MRO to ours.
223 The recursive call could throw an exception, which
224 has memory management implications here, hence the use of
226 const AV *const subrv
227 = mro_get_linear_isa_dfs(basestash, level + 1);
229 subrv_p = AvARRAY(subrv);
230 subrv_items = AvFILLp(subrv) + 1;
232 while(subrv_items--) {
233 SV *const subsv = *subrv_p++;
234 /* LVALUE fetch will create a new undefined SV if necessary
236 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
238 if(HeVAL(he) != &PL_sv_undef) {
239 /* It was newly created. Steal it for our new SV, and
240 replace it in the hash with the "real" thing. */
241 SV *const val = HeVAL(he);
242 HEK *const key = HeKEY_hek(he);
244 HeVAL(he) = &PL_sv_undef;
245 /* Save copying by making a shared hash key scalar. We
246 inline this here rather than calling Perl_newSVpvn_share
247 because we already have the scalar, and we already have
249 assert(SvTYPE(val) == SVt_NULL);
250 sv_upgrade(val, SVt_PV);
251 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
252 SvCUR_set(val, HEK_LEN(key));
259 av_push(retval, val);
265 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
266 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
268 SvREFCNT_inc_simple_void_NN(stored);
270 SvREADONLY_on(stored);
274 /* now that we're past the exception dangers, grab our own reference to
275 the AV we're about to use for the result. The reference owned by the
276 mortals' stack will be released soon, so everything will balance. */
277 SvREFCNT_inc_simple_void_NN(retval);
280 /* we don't want anyone modifying the cache entry but us,
281 and we do so by replacing it completely */
282 SvREADONLY_on(retval);
284 meta->mro_linear_dfs = retval;
289 =for apidoc mro_get_linear_isa_c3
291 Returns the C3 linearization of @ISA
292 the given stash. The return value is a read-only AV*.
293 C<level> should be 0 (it is used internally in this
294 function's recursion).
296 You are responsible for C<SvREFCNT_inc()> on the
297 return value if you plan to store it anywhere
298 semi-permanently (otherwise it might be deleted
299 out from under you the next time the cache is
306 S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
313 struct mro_meta* meta;
315 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
316 assert(HvAUX(stash));
318 stashhek = HvNAME_HEK(stash);
320 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
323 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
326 meta = HvMROMETA(stash);
328 /* return cache if valid */
329 if((retval = meta->mro_linear_c3)) {
333 /* not in cache, make a new one */
335 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
336 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
338 /* For a better idea how the rest of this works, see the much clearer
339 pure perl version in Algorithm::C3 0.01:
340 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
341 (later versions go about it differently than this code for speed reasons)
344 if(isa && AvFILLp(isa) >= 0) {
347 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
348 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
351 /* This builds @seqs, which is an array of arrays.
352 The members of @seqs are the MROs of
353 the members of @ISA, followed by @ISA itself.
355 I32 items = AvFILLp(isa) + 1;
356 SV** isa_ptr = AvARRAY(isa);
358 SV* const isa_item = *isa_ptr++;
359 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
360 if(!isa_item_stash) {
361 /* if no stash, make a temporary fake MRO
362 containing just itself */
363 AV* const isa_lin = newAV();
364 av_push(isa_lin, newSVsv(isa_item));
365 av_push(seqs, (SV*)isa_lin);
369 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
370 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
373 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
375 /* This builds "heads", which as an array of integer array
376 indices, one per seq, which point at the virtual "head"
377 of the seq (initially zero) */
378 Newxz(heads, AvFILLp(seqs)+1, I32);
380 /* This builds %tails, which has one key for every class
381 mentioned in the tail of any sequence in @seqs (tail meaning
382 everything after the first class, the "head"). The value
383 is how many times this key appears in the tails of @seqs.
385 seqs_ptr = AvARRAY(seqs);
386 seqs_items = AvFILLp(seqs) + 1;
387 while(seqs_items--) {
388 AV* const seq = (AV*)*seqs_ptr++;
389 I32 seq_items = AvFILLp(seq);
391 SV** seq_ptr = AvARRAY(seq) + 1;
393 SV* const seqitem = *seq_ptr++;
394 /* LVALUE fetch will create a new undefined SV if necessary
396 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
398 SV* const val = HeVAL(he);
399 /* This will increment undef to 1, which is what we
400 want for a newly created entry. */
407 /* Initialize retval to build the return value in */
409 av_push(retval, newSVhek(stashhek)); /* us first */
411 /* This loop won't terminate until we either finish building
412 the MRO, or get an exception. */
418 /* "foreach $seq (@seqs)" */
419 SV** const avptr = AvARRAY(seqs);
420 for(s = 0; s <= AvFILLp(seqs); s++) {
422 AV * const seq = (AV*)(avptr[s]);
424 if(!seq) continue; /* skip empty seqs */
425 svp = av_fetch(seq, heads[s], 0);
426 seqhead = *svp; /* seqhead = head of this seq */
430 /* if we haven't found a winner for this round yet,
431 and this seqhead is not in tails (or the count
432 for it in tails has dropped to zero), then this
433 seqhead is our new winner, and is added to the
434 final MRO immediately */
436 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
437 && (val = HeVAL(tail_entry))
440 winner = newSVsv(cand);
441 av_push(retval, winner);
442 /* note however that even when we find a winner,
443 we continue looping over @seqs to do housekeeping */
445 if(!sv_cmp(seqhead, winner)) {
446 /* Once we have a winner (including the iteration
447 where we first found him), inc the head ptr
448 for any seq which had the winner as a head,
449 NULL out any seq which is now empty,
450 and adjust tails for consistency */
452 const int new_head = ++heads[s];
453 if(new_head > AvFILLp(seq)) {
454 SvREFCNT_dec(avptr[s]);
460 /* Because we know this new seqhead used to be
461 a tail, we can assume it is in tails and has
462 a positive value, which we need to dec */
463 svp = av_fetch(seq, new_head, 0);
465 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
466 val = HeVAL(tail_entry);
472 /* if we found no candidates, we are done building the MRO.
473 !cand means no seqs have any entries left to check */
479 /* If we had candidates, but nobody won, then the @ISA
480 hierarchy is not C3-incompatible */
482 /* we have to do some cleanup before we croak */
484 SvREFCNT_dec(retval);
487 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
488 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
492 else { /* @ISA was undefined or empty */
493 /* build a retval containing only ourselves */
495 av_push(retval, newSVhek(stashhek));
498 /* we don't want anyone modifying the cache entry but us,
499 and we do so by replacing it completely */
500 SvREADONLY_on(retval);
502 meta->mro_linear_c3 = retval;
507 =for apidoc mro_get_linear_isa
509 Returns either C<mro_get_linear_isa_c3> or
510 C<mro_get_linear_isa_dfs> for the given stash,
511 dependant upon which MRO is in effect
512 for that stash. The return value is a
515 You are responsible for C<SvREFCNT_inc()> on the
516 return value if you plan to store it anywhere
517 semi-permanently (otherwise it might be deleted
518 out from under you the next time the cache is
524 Perl_mro_get_linear_isa(pTHX_ HV *stash)
526 struct mro_meta* meta;
528 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
530 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
532 meta = HvMROMETA(stash);
533 if (!meta->mro_which)
534 Perl_croak(aTHX_ "panic: invalid MRO!");
535 return meta->mro_which->resolve(aTHX_ stash, 0);
539 =for apidoc mro_isa_changed_in
541 Takes the necessary steps (cache invalidations, mostly)
542 when the @ISA of the given package has changed. Invoked
543 by the C<setisa> magic, should not need to invoke directly.
548 Perl_mro_isa_changed_in(pTHX_ HV* stash)
557 struct mro_meta * meta;
559 const char * const stashname = HvNAME_get(stash);
560 const STRLEN stashname_len = HvNAMELEN_get(stash);
562 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
565 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
567 /* wipe out the cached linearizations for this stash */
568 meta = HvMROMETA(stash);
569 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
570 SvREFCNT_dec((SV*)meta->mro_linear_c3);
571 meta->mro_linear_dfs = NULL;
572 meta->mro_linear_c3 = NULL;
574 SvREFCNT_dec(meta->isa);
578 /* Inc the package generation, since our @ISA changed */
581 /* Wipe the global method cache if this package
582 is UNIVERSAL or one of its parents */
584 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
585 isarev = svp ? (HV*)*svp : NULL;
587 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
588 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
592 else { /* Wipe the local method cache otherwise */
594 is_universal = FALSE;
597 /* wipe next::method cache too */
598 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
600 /* Iterate the isarev (classes that are our children),
601 wiping out their linearization and method caches */
604 while((iter = hv_iternext(isarev))) {
606 const char* const revkey = hv_iterkey(iter, &len);
607 HV* revstash = gv_stashpvn(revkey, len, 0);
608 struct mro_meta* revmeta;
610 if(!revstash) continue;
611 revmeta = HvMROMETA(revstash);
612 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
613 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
614 revmeta->mro_linear_dfs = NULL;
615 revmeta->mro_linear_c3 = NULL;
617 revmeta->cache_gen++;
618 if(revmeta->mro_nextmethod)
619 hv_clear(revmeta->mro_nextmethod);
623 /* Now iterate our MRO (parents), and do a few things:
624 1) instantiate with the "fake" flag if they don't exist
625 2) flag them as universal if we are universal
626 3) Add everything from our isarev to their isarev
629 /* We're starting at the 2nd element, skipping ourselves here */
630 linear_mro = mro_get_linear_isa(stash);
631 svp = AvARRAY(linear_mro) + 1;
632 items = AvFILLp(linear_mro);
635 SV* const sv = *svp++;
638 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
640 /* That fetch should not fail. But if it had to create a new SV for
641 us, then will need to upgrade it to an HV (which sv_upgrade() can
644 mroisarev = (HV*)HeVAL(he);
646 SvUPGRADE((SV*)mroisarev, SVt_PVHV);
648 /* This hash only ever contains PL_sv_yes. Storing it over itself is
649 almost as cheap as calling hv_exists, so on aggregate we expect to
650 save time by not making two calls to the common HV code for the
651 case where it doesn't exist. */
653 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
657 while((iter = hv_iternext(isarev))) {
659 char* const revkey = hv_iterkey(iter, &revkeylen);
660 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
667 =for apidoc mro_method_changed_in
669 Invalidates method caching on any child classes
670 of the given stash, so that they might notice
671 the changes in this one.
673 Ideally, all instances of C<PL_sub_generation++> in
674 perl source outside of C<mro.c> should be
675 replaced by calls to this.
677 Perl automatically handles most of the common
678 ways a method might be redefined. However, there
679 are a few ways you could change a method in a stash
680 without the cache code noticing, in which case you
681 need to call this method afterwards:
683 1) Directly manipulating the stash HV entries from
686 2) Assigning a reference to a readonly scalar
687 constant into a stash entry in order to create
688 a constant subroutine (like constant.pm
691 This same method is available from pure perl
692 via, C<mro::method_changed_in(classname)>.
697 Perl_mro_method_changed_in(pTHX_ HV *stash)
699 const char * const stashname = HvNAME_get(stash);
700 const STRLEN stashname_len = HvNAMELEN_get(stash);
702 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
703 HV * const isarev = svp ? (HV*)*svp : NULL;
705 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
708 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
710 /* Inc the package generation, since a local method changed */
711 HvMROMETA(stash)->pkg_gen++;
713 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
714 invalidate all method caches globally */
715 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
716 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
721 /* else, invalidate the method caches of all child classes,
727 while((iter = hv_iternext(isarev))) {
729 const char* const revkey = hv_iterkey(iter, &len);
730 HV* const revstash = gv_stashpvn(revkey, len, 0);
731 struct mro_meta* mrometa;
733 if(!revstash) continue;
734 mrometa = HvMROMETA(revstash);
735 mrometa->cache_gen++;
736 if(mrometa->mro_nextmethod)
737 hv_clear(mrometa->mro_nextmethod);
742 /* These two are static helpers for next::method and friends,
743 and re-implement a bunch of the code from pp_caller() in
744 a more efficient manner for this particular usage.
748 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
750 for (i = startingblock; i >= 0; i--) {
751 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
758 XS(XS_mro_get_linear_isa);
761 XS(XS_mro_get_isarev);
762 XS(XS_mro_is_universal);
763 XS(XS_mro_invalidate_method_caches);
764 XS(XS_mro_method_changed_in);
765 XS(XS_mro_get_pkg_gen);
769 Perl_boot_core_mro(pTHX)
772 static const char file[] = __FILE__;
774 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
775 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
776 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
777 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
778 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
779 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
780 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
781 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
782 newXS("mro::_nextcan", XS_mro_nextcan, file);
785 XS(XS_mro_get_linear_isa) {
792 if(items < 1 || items > 2)
793 croak_xs_usage(cv, "classname [, type ]");
796 class_stash = gv_stashsv(classname, 0);
799 /* No stash exists yet, give them just the classname */
800 AV* isalin = newAV();
801 av_push(isalin, newSVsv(classname));
802 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
806 const char* const which = SvPV_nolen(ST(1));
807 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
809 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
810 RETVAL = algo->resolve(aTHX_ class_stash, 0);
813 RETVAL = mro_get_linear_isa(class_stash);
816 ST(0) = newRV_inc((SV*)RETVAL);
826 const char* whichstr;
827 const struct mro_alg *which;
829 struct mro_meta* meta;
832 croak_xs_usage(cv, "classname, type");
835 whichstr = SvPV_nolen(ST(1));
836 class_stash = gv_stashsv(classname, GV_ADD);
837 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
838 meta = HvMROMETA(class_stash);
840 which = S_get_mro_from_name(aTHX_ whichstr);
842 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
844 if(meta->mro_which != which) {
845 meta->mro_which = which;
846 /* Only affects local method cache, not
847 even child classes */
849 if(meta->mro_nextmethod)
850 hv_clear(meta->mro_nextmethod);
865 croak_xs_usage(cv, "classname");
868 class_stash = gv_stashsv(classname, 0);
870 ST(0) = sv_2mortal(newSVpv(class_stash
871 ? HvMROMETA(class_stash)->mro_which->name
876 XS(XS_mro_get_isarev)
886 croak_xs_usage(cv, "classname");
893 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
894 isarev = he ? (HV*)HeVAL(he) : NULL;
900 while((iter = hv_iternext(isarev)))
901 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
903 mXPUSHs(newRV_noinc((SV*)ret_array));
909 XS(XS_mro_is_universal)
916 STRLEN classname_len;
920 croak_xs_usage(cv, "classname");
924 classname_pv = SvPV(classname,classname_len);
926 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
927 isarev = he ? (HV*)HeVAL(he) : NULL;
929 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
930 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
936 XS(XS_mro_invalidate_method_caches)
942 croak_xs_usage(cv, "");
949 XS(XS_mro_method_changed_in)
957 croak_xs_usage(cv, "classname");
961 class_stash = gv_stashsv(classname, 0);
962 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
964 mro_method_changed_in(class_stash);
969 XS(XS_mro_get_pkg_gen)
977 croak_xs_usage(cv, "classname");
981 class_stash = gv_stashsv(classname, 0);
985 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
996 const I32 throw_nomethod = SvIVX(ST(1));
997 register I32 cxix = cxstack_ix;
998 register const PERL_CONTEXT *ccstack = cxstack;
999 const PERL_SI *top_si = PL_curstackinfo;
1002 const char *fq_subname;
1003 const char *subname;
1004 STRLEN stashname_len;
1012 struct mro_meta* selfmeta;
1016 PERL_UNUSED_ARG(cv);
1020 if(sv_isobject(self))
1021 selfstash = SvSTASH(SvRV(self));
1023 selfstash = gv_stashsv(self, GV_ADD);
1027 hvname = HvNAME_get(selfstash);
1029 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
1031 /* This block finds the contextually-enclosing fully-qualified subname,
1032 much like looking at (caller($i))[3] until you find a real sub that
1033 isn't ANON, etc (also skips over pureperl next::method, etc) */
1034 for(i = 0; i < 2; i++) {
1035 cxix = __dopoptosub_at(ccstack, cxix);
1038 STRLEN fq_subname_len;
1040 /* we may be in a higher stacklevel, so dig down deeper */
1042 if(top_si->si_type == PERLSI_MAIN)
1043 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
1044 top_si = top_si->si_prev;
1045 ccstack = top_si->si_cxstack;
1046 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
1049 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
1050 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
1051 cxix = __dopoptosub_at(ccstack, cxix - 1);
1056 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
1057 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
1058 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1065 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1068 cxix = __dopoptosub_at(ccstack, cxix - 1);
1072 /* we found a real sub here */
1073 sv = sv_2mortal(newSV(0));
1075 gv_efullname3(sv, cvgv, NULL);
1077 fq_subname = SvPVX(sv);
1078 fq_subname_len = SvCUR(sv);
1080 subname = strrchr(fq_subname, ':');
1082 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1085 subname_len = fq_subname_len - (subname - fq_subname);
1086 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1087 cxix = __dopoptosub_at(ccstack, cxix - 1);
1095 /* If we made it to here, we found our context */
1097 /* Initialize the next::method cache for this stash
1099 selfmeta = HvMROMETA(selfstash);
1100 if(!(nmcache = selfmeta->mro_nextmethod)) {
1101 nmcache = selfmeta->mro_nextmethod = newHV();
1103 else { /* Use the cached coderef if it exists */
1104 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1106 SV* const val = HeVAL(cache_entry);
1107 if(val == &PL_sv_undef) {
1109 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1112 mXPUSHs(newRV_inc(val));
1117 /* beyond here is just for cache misses, so perf isn't as critical */
1119 stashname_len = subname - fq_subname - 2;
1120 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1122 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1124 linear_svp = AvARRAY(linear_av);
1125 entries = AvFILLp(linear_av) + 1;
1127 /* Walk down our MRO, skipping everything up
1128 to the contextually enclosing class */
1130 SV * const linear_sv = *linear_svp++;
1132 if(sv_eq(linear_sv, stashname))
1136 /* Now search the remainder of the MRO for the
1137 same method name as the contextually enclosing
1141 SV * const linear_sv = *linear_svp++;
1147 curstash = gv_stashsv(linear_sv, FALSE);
1150 if (ckWARN(WARN_SYNTAX))
1151 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1152 (void*)linear_sv, hvname);
1158 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1164 if (SvTYPE(candidate) != SVt_PVGV)
1165 gv_init(candidate, curstash, subname, subname_len, TRUE);
1167 /* Notably, we only look for real entries, not method cache
1168 entries, because in C3 the method cache of a parent is not
1169 valid for the child */
1170 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1171 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1172 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1173 mXPUSHs(newRV_inc((SV*)cand_cv));
1179 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1181 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1187 * c-indentation-style: bsd
1189 * indent-tabs-mode: t
1192 * ex: set ts=8 sts=4 sw=4 noet: