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 */
223 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
225 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
226 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
228 /* For a better idea how the rest of this works, see the much clearer
229 pure perl version in Algorithm::C3 0.01:
230 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
231 (later versions go about it differently than this code for speed reasons)
234 if(isa && AvFILLp(isa) >= 0) {
237 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
238 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
241 /* This builds @seqs, which is an array of arrays.
242 The members of @seqs are the MROs of
243 the members of @ISA, followed by @ISA itself.
245 I32 items = AvFILLp(isa) + 1;
246 SV** isa_ptr = AvARRAY(isa);
249 SV* const isa_item = *isa_ptr++;
250 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
251 if(!isa_item_stash) {
252 /* if no stash, make a temporary fake MRO
253 containing just itself */
254 isa_lin = (AV*)sv_2mortal((SV*)newAV());
255 av_push(isa_lin, newSVsv(isa_item));
258 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
260 av_push(seqs, (SV*)isa_lin);
262 av_push(seqs, (SV*)isa);
264 /* This builds "heads", which as an array of integer array
265 indices, one per seq, which point at the virtual "head"
266 of the seq (initially zero) */
267 Newxz(heads, AvFILLp(seqs)+1, I32);
269 /* This builds %tails, which has one key for every class
270 mentioned in the tail of any sequence in @seqs (tail meaning
271 everything after the first class, the "head"). The value
272 is how many times this key appears in the tails of @seqs.
274 seqs_ptr = AvARRAY(seqs);
275 seqs_items = AvFILLp(seqs) + 1;
276 while(seqs_items--) {
277 AV* const seq = (AV*)*seqs_ptr++;
278 I32 seq_items = AvFILLp(seq);
280 SV** seq_ptr = AvARRAY(seq) + 1;
282 SV* const seqitem = *seq_ptr++;
283 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
285 hv_store_ent(tails, seqitem, newSViv(1), 0);
288 SV* const val = HeVAL(he);
295 /* This loop won't terminate until we either finish building
296 the MRO, or get an exception. */
302 /* "foreach $seq (@seqs)" */
303 SV** const avptr = AvARRAY(seqs);
304 for(s = 0; s <= AvFILLp(seqs); s++) {
306 AV * const seq = (AV*)(avptr[s]);
308 if(!seq) continue; /* skip empty seqs */
309 svp = av_fetch(seq, heads[s], 0);
310 seqhead = *svp; /* seqhead = head of this seq */
314 /* if we haven't found a winner for this round yet,
315 and this seqhead is not in tails (or the count
316 for it in tails has dropped to zero), then this
317 seqhead is our new winner, and is added to the
318 final MRO immediately */
320 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
321 && (val = HeVAL(tail_entry))
324 winner = newSVsv(cand);
325 av_push(retval, winner);
326 /* note however that even when we find a winner,
327 we continue looping over @seqs to do housekeeping */
329 if(!sv_cmp(seqhead, winner)) {
330 /* Once we have a winner (including the iteration
331 where we first found him), inc the head ptr
332 for any seq which had the winner as a head,
333 NULL out any seq which is now empty,
334 and adjust tails for consistency */
336 const int new_head = ++heads[s];
337 if(new_head > AvFILLp(seq)) {
343 /* Because we know this new seqhead used to be
344 a tail, we can assume it is in tails and has
345 a positive value, which we need to dec */
346 svp = av_fetch(seq, new_head, 0);
348 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
349 val = HeVAL(tail_entry);
355 /* if we found no candidates, we are done building the MRO.
356 !cand means no seqs have any entries left to check */
362 /* If we had candidates, but nobody won, then the @ISA
363 hierarchy is not C3-incompatible */
365 /* we have to do some cleanup before we croak */
366 SV** svp = AvARRAY(seqs);
367 items = AvFILLp(seqs) + 1;
371 SvREFCNT_dec(retval);
374 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
375 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
380 /* we don't want anyone modifying the cache entry but us,
381 and we do so by replacing it completely */
382 SvREADONLY_on(retval);
384 meta->mro_linear_c3 = retval;
389 =for apidoc mro_get_linear_isa
391 Returns either C<mro_get_linear_isa_c3> or
392 C<mro_get_linear_isa_dfs> for the given stash,
393 dependant upon which MRO is in effect
394 for that stash. The return value is a
397 You are responsible for C<SvREFCNT_inc()> on the
398 return value if you plan to store it anywhere
399 semi-permanently (otherwise it might be deleted
400 out from under you the next time the cache is
406 Perl_mro_get_linear_isa(pTHX_ HV *stash)
408 struct mro_meta* meta;
410 assert(HvAUX(stash));
412 meta = HvMROMETA(stash);
413 if(meta->mro_which == MRO_DFS) {
414 return mro_get_linear_isa_dfs(stash, 0);
415 } else if(meta->mro_which == MRO_C3) {
416 return mro_get_linear_isa_c3(stash, 0);
418 Perl_croak(aTHX_ "panic: invalid MRO!");
420 return NULL; /* NOT REACHED */
424 =for apidoc mro_isa_changed_in
426 Takes the necessary steps (cache invalidations, mostly)
427 when the @ISA of the given package has changed. Invoked
428 by the C<setisa> magic, should not need to invoke directly.
433 Perl_mro_isa_changed_in(pTHX_ HV* stash)
443 const char * const stashname = HvNAME_get(stash);
444 const STRLEN stashname_len = HvNAMELEN_get(stash);
446 /* wipe out the cached linearizations for this stash */
447 struct mro_meta * const meta = HvMROMETA(stash);
448 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
449 SvREFCNT_dec((SV*)meta->mro_linear_c3);
450 meta->mro_linear_dfs = NULL;
451 meta->mro_linear_c3 = NULL;
453 /* Wipe the global method cache if this package
454 is UNIVERSAL or one of its parents */
456 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
457 isarev = svp ? (HV*)*svp : NULL;
459 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
460 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
464 else { /* Wipe the local method cache otherwise */
466 is_universal = FALSE;
469 /* wipe next::method cache too */
470 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
472 /* Iterate the isarev (classes that are our children),
473 wiping out their linearization and method caches */
476 while((iter = hv_iternext(isarev))) {
477 SV* const revkey = hv_iterkeysv(iter);
478 HV* revstash = gv_stashsv(revkey, 0);
479 struct mro_meta* revmeta;
481 if(!revstash) continue;
482 revmeta = HvMROMETA(revstash);
483 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
484 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
485 revmeta->mro_linear_dfs = NULL;
486 revmeta->mro_linear_c3 = NULL;
488 revmeta->cache_gen++;
489 if(revmeta->mro_nextmethod)
490 hv_clear(revmeta->mro_nextmethod);
494 /* Now iterate our MRO (parents), and do a few things:
495 1) instantiate with the "fake" flag if they don't exist
496 2) flag them as universal if we are universal
497 3) Add everything from our isarev to their isarev
500 /* We're starting at the 2nd element, skipping ourselves here */
501 linear_mro = mro_get_linear_isa(stash);
502 svp = AvARRAY(linear_mro) + 1;
503 items = AvFILLp(linear_mro);
506 SV* const sv = *svp++;
509 HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
511 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
513 mroisarev = (HV*)HeVAL(he);
515 /* This hash only ever contains PL_sv_yes. Storing it over itself is
516 almost as cheap as calling hv_exists, so on aggregate we expect to
517 save time by not making two calls to the common HV code for the
518 case where it doesn't exist. */
520 hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
524 while((iter = hv_iternext(isarev))) {
526 char* const revkey = hv_iterkey(iter, &revkeylen);
527 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
534 =for apidoc mro_method_changed_in
536 Invalidates method caching on any child classes
537 of the given stash, so that they might notice
538 the changes in this one.
540 Ideally, all instances of C<PL_sub_generation++> in
541 perl source outside of C<mro.c> should be
542 replaced by calls to this.
544 Perl automatically handles most of the common
545 ways a method might be redefined. However, there
546 are a few ways you could change a method in a stash
547 without the cache code noticing, in which case you
548 need to call this method afterwards:
550 1) Directly manipulating the stash HV entries from
553 2) Assigning a reference to a readonly scalar
554 constant into a stash entry in order to create
555 a constant subroutine (like constant.pm
558 This same method is available from pure perl
559 via, C<mro::method_changed_in(classname)>.
564 Perl_mro_method_changed_in(pTHX_ HV *stash)
566 const char * const stashname = HvNAME_get(stash);
567 const STRLEN stashname_len = HvNAMELEN_get(stash);
569 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
570 HV * const isarev = svp ? (HV*)*svp : NULL;
572 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
573 invalidate all method caches globally */
574 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
575 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
580 /* else, invalidate the method caches of all child classes,
586 while((iter = hv_iternext(isarev))) {
587 SV* const revkey = hv_iterkeysv(iter);
588 HV* const revstash = gv_stashsv(revkey, 0);
589 struct mro_meta* mrometa;
591 if(!revstash) continue;
592 mrometa = HvMROMETA(revstash);
593 mrometa->cache_gen++;
594 if(mrometa->mro_nextmethod)
595 hv_clear(mrometa->mro_nextmethod);
600 /* These two are static helpers for next::method and friends,
601 and re-implement a bunch of the code from pp_caller() in
602 a more efficient manner for this particular usage.
606 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
608 for (i = startingblock; i >= 0; i--) {
609 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
615 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
618 register const PERL_CONTEXT *ccstack = cxstack;
619 const PERL_SI *top_si = PL_curstackinfo;
622 const char *fq_subname;
624 STRLEN stashname_len;
632 struct mro_meta* selfmeta;
635 if(sv_isobject(self))
636 selfstash = SvSTASH(SvRV(self));
638 selfstash = gv_stashsv(self, 0);
642 hvname = HvNAME_get(selfstash);
644 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
646 cxix = __dopoptosub_at(cxstack, cxstack_ix);
648 /* This block finds the contextually-enclosing fully-qualified subname,
649 much like looking at (caller($i))[3] until you find a real sub that
653 STRLEN fq_subname_len;
655 /* we may be in a higher stacklevel, so dig down deeper */
657 if(top_si->si_type == PERLSI_MAIN)
658 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
659 top_si = top_si->si_prev;
660 ccstack = top_si->si_cxstack;
661 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
664 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
665 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
666 cxix = __dopoptosub_at(ccstack, cxix - 1);
671 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
672 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
673 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
680 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
683 cxix = __dopoptosub_at(ccstack, cxix - 1);
687 /* we found a real sub here */
688 sv = sv_2mortal(newSV(0));
690 gv_efullname3(sv, cvgv, NULL);
692 fq_subname = SvPVX(sv);
693 fq_subname_len = SvCUR(sv);
695 subname = strrchr(fq_subname, ':');
697 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
700 subname_len = fq_subname_len - (subname - fq_subname);
701 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
702 cxix = __dopoptosub_at(ccstack, cxix - 1);
708 /* If we made it to here, we found our context */
710 /* Initialize the next::method cache for this stash
712 selfmeta = HvMROMETA(selfstash);
713 if(!(nmcache = selfmeta->mro_nextmethod)) {
714 nmcache = selfmeta->mro_nextmethod = newHV();
716 else { /* Use the cached coderef if it exists */
717 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
719 SV* const val = HeVAL(cache_entry);
720 if(val == &PL_sv_undef) {
722 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
728 /* beyond here is just for cache misses, so perf isn't as critical */
730 stashname_len = subname - fq_subname - 2;
731 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
733 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
735 linear_svp = AvARRAY(linear_av);
736 items = AvFILLp(linear_av) + 1;
738 /* Walk down our MRO, skipping everything up
739 to the contextually enclosing class */
741 SV * const linear_sv = *linear_svp++;
743 if(sv_eq(linear_sv, stashname))
747 /* Now search the remainder of the MRO for the
748 same method name as the contextually enclosing
752 SV * const linear_sv = *linear_svp++;
758 curstash = gv_stashsv(linear_sv, FALSE);
761 if (ckWARN(WARN_SYNTAX))
762 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
763 (void*)linear_sv, hvname);
769 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
775 if (SvTYPE(candidate) != SVt_PVGV)
776 gv_init(candidate, curstash, subname, subname_len, TRUE);
778 /* Notably, we only look for real entries, not method cache
779 entries, because in C3 the method cache of a parent is not
780 valid for the child */
781 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
782 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
783 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
789 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
791 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
797 XS(XS_mro_get_linear_isa);
800 XS(XS_mro_get_isarev);
801 XS(XS_mro_is_universal);
802 XS(XS_mro_invalidate_method_caches);
803 XS(XS_mro_method_changed_in);
806 XS(XS_maybe_next_method);
809 Perl_boot_core_mro(pTHX)
812 static const char file[] = __FILE__;
814 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
815 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
816 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
817 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
818 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
819 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
820 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
821 newXS("next::can", XS_next_can, file);
822 newXS("next::method", XS_next_method, file);
823 newXS("maybe::next::method", XS_maybe_next_method, file);
826 XS(XS_mro_get_linear_isa) {
835 if(items < 1 || items > 2)
836 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
839 class_stash = gv_stashsv(classname, 0);
840 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
843 const char* const which = SvPV_nolen(ST(1));
844 if(strEQ(which, "dfs"))
845 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
846 else if(strEQ(which, "c3"))
847 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
849 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
852 RETVAL = mro_get_linear_isa(class_stash);
855 ST(0) = newRV_inc((SV*)RETVAL);
868 struct mro_meta* meta;
873 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
876 whichstr = SvPV_nolen(ST(1));
877 class_stash = gv_stashsv(classname, GV_ADD);
878 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
879 meta = HvMROMETA(class_stash);
881 if(strEQ(whichstr, "dfs"))
883 else if(strEQ(whichstr, "c3"))
886 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
888 if(meta->mro_which != which) {
889 meta->mro_which = which;
890 /* Only affects local method cache, not
891 even child classes */
893 if(meta->mro_nextmethod)
894 hv_clear(meta->mro_nextmethod);
907 struct mro_meta* meta;
912 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
915 class_stash = gv_stashsv(classname, 0);
916 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
917 meta = HvMROMETA(class_stash);
919 if(meta->mro_which == MRO_DFS)
920 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
922 ST(0) = sv_2mortal(newSVpvn("c3", 2));
927 XS(XS_mro_get_isarev)
936 STRLEN stashname_len;
941 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
945 class_stash = gv_stashsv(classname, 0);
947 Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
951 stashname = HvNAME_get(class_stash);
952 stashname_len = HvNAMELEN_get(class_stash);
953 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
954 isarev = svp ? (HV*)*svp : NULL;
958 while((iter = hv_iternext(isarev)))
959 XPUSHs(hv_iterkeysv(iter));
966 XS(XS_mro_is_universal)
974 STRLEN stashname_len;
980 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
983 class_stash = gv_stashsv(classname, 0);
984 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
986 stashname = HvNAME_get(class_stash);
987 stashname_len = HvNAMELEN_get(class_stash);
989 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
990 isarev = svp ? (HV*)*svp : NULL;
992 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
993 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
999 XS(XS_mro_invalidate_method_caches)
1004 PERL_UNUSED_ARG(cv);
1007 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1009 PL_sub_generation++;
1014 XS(XS_mro_method_changed_in)
1021 PERL_UNUSED_ARG(cv);
1024 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1028 class_stash = gv_stashsv(classname, 0);
1029 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1031 mro_method_changed_in(class_stash);
1040 SV* const self = ST(0);
1041 SV* const methcv = __nextcan(aTHX_ self, 0);
1043 PERL_UNUSED_ARG(cv);
1044 PERL_UNUSED_VAR(items);
1046 if(methcv == &PL_sv_undef) {
1047 ST(0) = &PL_sv_undef;
1050 ST(0) = sv_2mortal(newRV_inc(methcv));
1060 SV* const self = ST(0);
1061 SV* const methcv = __nextcan(aTHX_ self, 1);
1063 PERL_UNUSED_ARG(cv);
1066 call_sv(methcv, GIMME_V);
1069 XS(XS_maybe_next_method)
1073 SV* const self = ST(0);
1074 SV* const methcv = __nextcan(aTHX_ self, 0);
1076 PERL_UNUSED_ARG(cv);
1078 if(methcv == &PL_sv_undef) {
1079 ST(0) = &PL_sv_undef;
1084 call_sv(methcv, GIMME_V);
1089 * c-indentation-style: bsd
1091 * indent-tabs-mode: t
1094 * ex: set ts=8 sts=4 sw=4 noet: