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
27 Perl_mro_meta_init(pTHX_ HV* stash)
29 struct mro_meta* newmeta;
33 assert(!(HvAUX(stash)->xhv_mro_meta));
34 Newxz(newmeta, 1, struct mro_meta);
35 HvAUX(stash)->xhv_mro_meta = newmeta;
36 newmeta->cache_gen = 1;
41 #if defined(USE_ITHREADS)
43 /* for sv_dup on new threads */
45 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
47 struct mro_meta* newmeta;
51 Newx(newmeta, 1, struct mro_meta);
52 Copy(smeta, newmeta, 1, struct mro_meta);
54 if (newmeta->mro_linear_dfs)
55 newmeta->mro_linear_dfs
56 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
57 if (newmeta->mro_linear_c3)
58 newmeta->mro_linear_c3
59 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
60 if (newmeta->mro_nextmethod)
61 newmeta->mro_nextmethod
62 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
67 #endif /* USE_ITHREADS */
70 =for apidoc mro_get_linear_isa_dfs
72 Returns the Depth-First Search linearization of @ISA
73 the given stash. The return value is a read-only AV*.
74 C<level> should be 0 (it is used internally in this
75 function's recursion).
77 You are responsible for C<SvREFCNT_inc()> on the
78 return value if you plan to store it anywhere
79 semi-permanently (otherwise it might be deleted
80 out from under you the next time the cache is
86 Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
92 const char* stashname;
93 struct mro_meta* meta;
98 stashname = HvNAME_get(stash);
100 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
103 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
106 meta = HvMROMETA(stash);
108 /* return cache if valid */
109 if((retval = meta->mro_linear_dfs)) {
113 /* not in cache, make a new one */
116 av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
119 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
120 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
122 if(av && AvFILLp(av) >= 0) {
124 /* "stored" is used to keep track of all of the classnames
125 we have added to the MRO so far, so we can do a quick
126 exists check and avoid adding duplicate classnames to
129 HV* const stored = (HV*)sv_2mortal((SV*)newHV());
130 SV **svp = AvARRAY(av);
131 I32 items = AvFILLp(av) + 1;
135 SV* const sv = *svp++;
136 HV* const basestash = gv_stashsv(sv, 0);
141 /* if no stash exists for this @ISA member,
142 simply add it to the MRO and move on */
147 /* otherwise, recurse into ourselves for the MRO
148 of this @ISA member, and append their MRO to ours */
149 const AV *const subrv
150 = mro_get_linear_isa_dfs(basestash, level + 1);
152 subrv_p = AvARRAY(subrv);
153 subrv_items = AvFILLp(subrv) + 1;
155 while(subrv_items--) {
156 SV *const subsv = *subrv_p++;
157 if(!hv_exists_ent(stored, subsv, 0)) {
158 hv_store_ent(stored, subsv, &PL_sv_undef, 0);
159 av_push(retval, newSVsv(subsv));
165 /* we don't want anyone modifying the cache entry but us,
166 and we do so by replacing it completely */
167 SvREADONLY_on(retval);
169 meta->mro_linear_dfs = retval;
174 =for apidoc mro_get_linear_isa_c3
176 Returns the C3 linearization of @ISA
177 the given stash. The return value is a read-only AV*.
178 C<level> should be 0 (it is used internally in this
179 function's recursion).
181 You are responsible for C<SvREFCNT_inc()> on the
182 return value if you plan to store it anywhere
183 semi-permanently (otherwise it might be deleted
184 out from under you the next time the cache is
191 Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
197 const char* stashname;
198 STRLEN stashname_len;
199 struct mro_meta* meta;
202 assert(HvAUX(stash));
204 stashname = HvNAME_get(stash);
205 stashname_len = HvNAMELEN_get(stash);
207 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
210 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
213 meta = HvMROMETA(stash);
215 /* return cache if valid */
216 if((retval = meta->mro_linear_c3)) {
220 /* not in cache, make a new one */
222 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
223 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
225 /* For a better idea how the rest of this works, see the much clearer
226 pure perl version in Algorithm::C3 0.01:
227 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
228 (later versions go about it differently than this code for speed reasons)
231 if(isa && AvFILLp(isa) >= 0) {
234 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
235 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
238 /* This builds @seqs, which is an array of arrays.
239 The members of @seqs are the MROs of
240 the members of @ISA, followed by @ISA itself.
242 I32 items = AvFILLp(isa) + 1;
243 SV** isa_ptr = AvARRAY(isa);
246 SV* const isa_item = *isa_ptr++;
247 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
248 if(!isa_item_stash) {
249 /* if no stash, make a temporary fake MRO
250 containing just itself */
251 isa_lin = (AV*)sv_2mortal((SV*)newAV());
252 av_push(isa_lin, newSVsv(isa_item));
255 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
257 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
259 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
261 /* This builds "heads", which as an array of integer array
262 indices, one per seq, which point at the virtual "head"
263 of the seq (initially zero) */
264 Newxz(heads, AvFILLp(seqs)+1, I32);
266 /* This builds %tails, which has one key for every class
267 mentioned in the tail of any sequence in @seqs (tail meaning
268 everything after the first class, the "head"). The value
269 is how many times this key appears in the tails of @seqs.
271 seqs_ptr = AvARRAY(seqs);
272 seqs_items = AvFILLp(seqs) + 1;
273 while(seqs_items--) {
274 AV* const seq = (AV*)*seqs_ptr++;
275 I32 seq_items = AvFILLp(seq);
277 SV** seq_ptr = AvARRAY(seq) + 1;
279 SV* const seqitem = *seq_ptr++;
280 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
282 hv_store_ent(tails, seqitem, newSViv(1), 0);
285 SV* const val = HeVAL(he);
292 /* Initialize retval to build the return value in */
294 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
296 /* This loop won't terminate until we either finish building
297 the MRO, or get an exception. */
303 /* "foreach $seq (@seqs)" */
304 SV** const avptr = AvARRAY(seqs);
305 for(s = 0; s <= AvFILLp(seqs); s++) {
307 AV * const seq = (AV*)(avptr[s]);
309 if(!seq) continue; /* skip empty seqs */
310 svp = av_fetch(seq, heads[s], 0);
311 seqhead = *svp; /* seqhead = head of this seq */
315 /* if we haven't found a winner for this round yet,
316 and this seqhead is not in tails (or the count
317 for it in tails has dropped to zero), then this
318 seqhead is our new winner, and is added to the
319 final MRO immediately */
321 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
322 && (val = HeVAL(tail_entry))
325 winner = newSVsv(cand);
326 av_push(retval, winner);
327 /* note however that even when we find a winner,
328 we continue looping over @seqs to do housekeeping */
330 if(!sv_cmp(seqhead, winner)) {
331 /* Once we have a winner (including the iteration
332 where we first found him), inc the head ptr
333 for any seq which had the winner as a head,
334 NULL out any seq which is now empty,
335 and adjust tails for consistency */
337 const int new_head = ++heads[s];
338 if(new_head > AvFILLp(seq)) {
339 SvREFCNT_dec(avptr[s]);
345 /* Because we know this new seqhead used to be
346 a tail, we can assume it is in tails and has
347 a positive value, which we need to dec */
348 svp = av_fetch(seq, new_head, 0);
350 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
351 val = HeVAL(tail_entry);
357 /* if we found no candidates, we are done building the MRO.
358 !cand means no seqs have any entries left to check */
364 /* If we had candidates, but nobody won, then the @ISA
365 hierarchy is not C3-incompatible */
367 /* we have to do some cleanup before we croak */
369 SvREFCNT_dec(retval);
372 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
373 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
377 else { /* @ISA was undefined or empty */
378 /* build a retval containing only ourselves */
380 av_push(retval, newSVpvn(stashname, stashname_len));
383 /* we don't want anyone modifying the cache entry but us,
384 and we do so by replacing it completely */
385 SvREADONLY_on(retval);
387 meta->mro_linear_c3 = retval;
392 =for apidoc mro_get_linear_isa
394 Returns either C<mro_get_linear_isa_c3> or
395 C<mro_get_linear_isa_dfs> for the given stash,
396 dependant upon which MRO is in effect
397 for that stash. The return value is a
400 You are responsible for C<SvREFCNT_inc()> on the
401 return value if you plan to store it anywhere
402 semi-permanently (otherwise it might be deleted
403 out from under you the next time the cache is
409 Perl_mro_get_linear_isa(pTHX_ HV *stash)
411 struct mro_meta* meta;
413 assert(HvAUX(stash));
415 meta = HvMROMETA(stash);
416 if(meta->mro_which == MRO_DFS) {
417 return mro_get_linear_isa_dfs(stash, 0);
418 } else if(meta->mro_which == MRO_C3) {
419 return mro_get_linear_isa_c3(stash, 0);
421 Perl_croak(aTHX_ "panic: invalid MRO!");
423 return NULL; /* NOT REACHED */
427 =for apidoc mro_isa_changed_in
429 Takes the necessary steps (cache invalidations, mostly)
430 when the @ISA of the given package has changed. Invoked
431 by the C<setisa> magic, should not need to invoke directly.
436 Perl_mro_isa_changed_in(pTHX_ HV* stash)
446 const char * const stashname = HvNAME_get(stash);
447 const STRLEN stashname_len = HvNAMELEN_get(stash);
449 /* wipe out the cached linearizations for this stash */
450 struct mro_meta * const meta = HvMROMETA(stash);
451 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
452 SvREFCNT_dec((SV*)meta->mro_linear_c3);
453 meta->mro_linear_dfs = NULL;
454 meta->mro_linear_c3 = NULL;
456 /* Wipe the global method cache if this package
457 is UNIVERSAL or one of its parents */
459 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
460 isarev = svp ? (HV*)*svp : NULL;
462 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
463 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
467 else { /* Wipe the local method cache otherwise */
469 is_universal = FALSE;
472 /* wipe next::method cache too */
473 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
475 /* Iterate the isarev (classes that are our children),
476 wiping out their linearization and method caches */
479 while((iter = hv_iternext(isarev))) {
480 SV* const revkey = hv_iterkeysv(iter);
481 HV* revstash = gv_stashsv(revkey, 0);
482 struct mro_meta* revmeta;
484 if(!revstash) continue;
485 revmeta = HvMROMETA(revstash);
486 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
487 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
488 revmeta->mro_linear_dfs = NULL;
489 revmeta->mro_linear_c3 = NULL;
491 revmeta->cache_gen++;
492 if(revmeta->mro_nextmethod)
493 hv_clear(revmeta->mro_nextmethod);
497 /* Now iterate our MRO (parents), and do a few things:
498 1) instantiate with the "fake" flag if they don't exist
499 2) flag them as universal if we are universal
500 3) Add everything from our isarev to their isarev
503 /* We're starting at the 2nd element, skipping ourselves here */
504 linear_mro = mro_get_linear_isa(stash);
505 svp = AvARRAY(linear_mro) + 1;
506 items = AvFILLp(linear_mro);
509 SV* const sv = *svp++;
512 HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
514 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
516 mroisarev = (HV*)HeVAL(he);
518 /* This hash only ever contains PL_sv_yes. Storing it over itself is
519 almost as cheap as calling hv_exists, so on aggregate we expect to
520 save time by not making two calls to the common HV code for the
521 case where it doesn't exist. */
523 hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
527 while((iter = hv_iternext(isarev))) {
529 char* const revkey = hv_iterkey(iter, &revkeylen);
530 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
537 =for apidoc mro_method_changed_in
539 Invalidates method caching on any child classes
540 of the given stash, so that they might notice
541 the changes in this one.
543 Ideally, all instances of C<PL_sub_generation++> in
544 perl source outside of C<mro.c> should be
545 replaced by calls to this.
547 Perl automatically handles most of the common
548 ways a method might be redefined. However, there
549 are a few ways you could change a method in a stash
550 without the cache code noticing, in which case you
551 need to call this method afterwards:
553 1) Directly manipulating the stash HV entries from
556 2) Assigning a reference to a readonly scalar
557 constant into a stash entry in order to create
558 a constant subroutine (like constant.pm
561 This same method is available from pure perl
562 via, C<mro::method_changed_in(classname)>.
567 Perl_mro_method_changed_in(pTHX_ HV *stash)
569 const char * const stashname = HvNAME_get(stash);
570 const STRLEN stashname_len = HvNAMELEN_get(stash);
572 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
573 HV * const isarev = svp ? (HV*)*svp : NULL;
575 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
576 invalidate all method caches globally */
577 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
578 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
583 /* else, invalidate the method caches of all child classes,
589 while((iter = hv_iternext(isarev))) {
590 SV* const revkey = hv_iterkeysv(iter);
591 HV* const revstash = gv_stashsv(revkey, 0);
592 struct mro_meta* mrometa;
594 if(!revstash) continue;
595 mrometa = HvMROMETA(revstash);
596 mrometa->cache_gen++;
597 if(mrometa->mro_nextmethod)
598 hv_clear(mrometa->mro_nextmethod);
603 /* These two are static helpers for next::method and friends,
604 and re-implement a bunch of the code from pp_caller() in
605 a more efficient manner for this particular usage.
609 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
611 for (i = startingblock; i >= 0; i--) {
612 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
618 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
621 register const PERL_CONTEXT *ccstack = cxstack;
622 const PERL_SI *top_si = PL_curstackinfo;
625 const char *fq_subname;
627 STRLEN stashname_len;
635 struct mro_meta* selfmeta;
638 if(sv_isobject(self))
639 selfstash = SvSTASH(SvRV(self));
641 selfstash = gv_stashsv(self, 0);
645 hvname = HvNAME_get(selfstash);
647 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
649 cxix = __dopoptosub_at(cxstack, cxstack_ix);
651 /* This block finds the contextually-enclosing fully-qualified subname,
652 much like looking at (caller($i))[3] until you find a real sub that
656 STRLEN fq_subname_len;
658 /* we may be in a higher stacklevel, so dig down deeper */
660 if(top_si->si_type == PERLSI_MAIN)
661 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
662 top_si = top_si->si_prev;
663 ccstack = top_si->si_cxstack;
664 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
667 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
668 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
669 cxix = __dopoptosub_at(ccstack, cxix - 1);
674 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
675 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
676 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
683 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
686 cxix = __dopoptosub_at(ccstack, cxix - 1);
690 /* we found a real sub here */
691 sv = sv_2mortal(newSV(0));
693 gv_efullname3(sv, cvgv, NULL);
695 fq_subname = SvPVX(sv);
696 fq_subname_len = SvCUR(sv);
698 subname = strrchr(fq_subname, ':');
700 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
703 subname_len = fq_subname_len - (subname - fq_subname);
704 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
705 cxix = __dopoptosub_at(ccstack, cxix - 1);
711 /* If we made it to here, we found our context */
713 /* Initialize the next::method cache for this stash
715 selfmeta = HvMROMETA(selfstash);
716 if(!(nmcache = selfmeta->mro_nextmethod)) {
717 nmcache = selfmeta->mro_nextmethod = newHV();
719 else { /* Use the cached coderef if it exists */
720 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
722 SV* const val = HeVAL(cache_entry);
723 if(val == &PL_sv_undef) {
725 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
731 /* beyond here is just for cache misses, so perf isn't as critical */
733 stashname_len = subname - fq_subname - 2;
734 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
736 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
738 linear_svp = AvARRAY(linear_av);
739 items = AvFILLp(linear_av) + 1;
741 /* Walk down our MRO, skipping everything up
742 to the contextually enclosing class */
744 SV * const linear_sv = *linear_svp++;
746 if(sv_eq(linear_sv, stashname))
750 /* Now search the remainder of the MRO for the
751 same method name as the contextually enclosing
755 SV * const linear_sv = *linear_svp++;
761 curstash = gv_stashsv(linear_sv, FALSE);
764 if (ckWARN(WARN_SYNTAX))
765 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
766 (void*)linear_sv, hvname);
772 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
778 if (SvTYPE(candidate) != SVt_PVGV)
779 gv_init(candidate, curstash, subname, subname_len, TRUE);
781 /* Notably, we only look for real entries, not method cache
782 entries, because in C3 the method cache of a parent is not
783 valid for the child */
784 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
785 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
786 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
792 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
794 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
800 XS(XS_mro_get_linear_isa);
803 XS(XS_mro_get_isarev);
804 XS(XS_mro_is_universal);
805 XS(XS_mro_invalidate_method_caches);
806 XS(XS_mro_method_changed_in);
809 XS(XS_maybe_next_method);
812 Perl_boot_core_mro(pTHX)
815 static const char file[] = __FILE__;
817 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
818 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
819 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
820 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
821 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
822 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
823 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
824 newXS("next::can", XS_next_can, file);
825 newXS("next::method", XS_next_method, file);
826 newXS("maybe::next::method", XS_maybe_next_method, file);
829 XS(XS_mro_get_linear_isa) {
838 if(items < 1 || items > 2)
839 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
842 class_stash = gv_stashsv(classname, 0);
843 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
846 const char* const which = SvPV_nolen(ST(1));
847 if(strEQ(which, "dfs"))
848 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
849 else if(strEQ(which, "c3"))
850 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
852 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
855 RETVAL = mro_get_linear_isa(class_stash);
858 ST(0) = newRV_inc((SV*)RETVAL);
871 struct mro_meta* meta;
876 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
879 whichstr = SvPV_nolen(ST(1));
880 class_stash = gv_stashsv(classname, GV_ADD);
881 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
882 meta = HvMROMETA(class_stash);
884 if(strEQ(whichstr, "dfs"))
886 else if(strEQ(whichstr, "c3"))
889 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
891 if(meta->mro_which != which) {
892 meta->mro_which = which;
893 /* Only affects local method cache, not
894 even child classes */
896 if(meta->mro_nextmethod)
897 hv_clear(meta->mro_nextmethod);
910 struct mro_meta* meta;
915 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
918 class_stash = gv_stashsv(classname, 0);
919 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
920 meta = HvMROMETA(class_stash);
922 if(meta->mro_which == MRO_DFS)
923 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
925 ST(0) = sv_2mortal(newSVpvn("c3", 2));
930 XS(XS_mro_get_isarev)
939 STRLEN stashname_len;
944 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
948 class_stash = gv_stashsv(classname, 0);
950 Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
954 stashname = HvNAME_get(class_stash);
955 stashname_len = HvNAMELEN_get(class_stash);
956 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
957 isarev = svp ? (HV*)*svp : NULL;
961 while((iter = hv_iternext(isarev)))
962 XPUSHs(hv_iterkeysv(iter));
969 XS(XS_mro_is_universal)
977 STRLEN stashname_len;
983 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
986 class_stash = gv_stashsv(classname, 0);
987 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
989 stashname = HvNAME_get(class_stash);
990 stashname_len = HvNAMELEN_get(class_stash);
992 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
993 isarev = svp ? (HV*)*svp : NULL;
995 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
996 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
1002 XS(XS_mro_invalidate_method_caches)
1007 PERL_UNUSED_ARG(cv);
1010 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1012 PL_sub_generation++;
1017 XS(XS_mro_method_changed_in)
1024 PERL_UNUSED_ARG(cv);
1027 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1031 class_stash = gv_stashsv(classname, 0);
1032 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1034 mro_method_changed_in(class_stash);
1043 SV* const self = ST(0);
1044 SV* const methcv = __nextcan(aTHX_ self, 0);
1046 PERL_UNUSED_ARG(cv);
1047 PERL_UNUSED_VAR(items);
1049 if(methcv == &PL_sv_undef) {
1050 ST(0) = &PL_sv_undef;
1053 ST(0) = sv_2mortal(newRV_inc(methcv));
1063 SV* const self = ST(0);
1064 SV* const methcv = __nextcan(aTHX_ self, 1);
1066 PERL_UNUSED_ARG(cv);
1069 call_sv(methcv, GIMME_V);
1072 XS(XS_maybe_next_method)
1076 SV* const self = ST(0);
1077 SV* const methcv = __nextcan(aTHX_ self, 0);
1079 PERL_UNUSED_ARG(cv);
1081 if(methcv == &PL_sv_undef) {
1082 ST(0) = &PL_sv_undef;
1087 call_sv(methcv, GIMME_V);
1092 * c-indentation-style: bsd
1094 * indent-tabs-mode: t
1097 * ex: set ts=8 sts=4 sw=4 noet: