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->sub_generation = 1;
38 /* Manually flag UNIVERSAL as being universal.
39 This happens early in perl booting (when universal.c
40 does the newXS calls for UNIVERSAL::*), and infects
41 other packages as they are added to UNIVERSAL's MRO
43 if(HvNAMELEN_get(stash) == 9
44 && strEQ(HEK_KEY(HvAUX(stash)->xhv_name), "UNIVERSAL")) {
45 HvMROMETA(stash)->is_universal = 1;
51 #if defined(USE_ITHREADS)
53 /* for sv_dup on new threads */
55 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
57 struct mro_meta* newmeta;
61 Newx(newmeta, 1, struct mro_meta);
62 Copy(smeta, newmeta, 1, struct mro_meta);
64 if (newmeta->mro_linear_dfs)
65 newmeta->mro_linear_dfs
66 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
67 if (newmeta->mro_linear_c3)
68 newmeta->mro_linear_c3
69 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
70 if (newmeta->mro_isarev)
72 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_isarev, param));
73 if (newmeta->mro_nextmethod)
74 newmeta->mro_nextmethod
75 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
80 #endif /* USE_ITHREADS */
83 =for apidoc mro_get_linear_isa_dfs
85 Returns the Depth-First Search linearization of @ISA
86 the given stash. The return value is a read-only AV*.
87 C<level> should be 0 (it is used internally in this
88 function's recursion).
90 You are responsible for C<SvREFCNT_inc()> on the
91 return value if you plan to store it anywhere
92 semi-permanently (otherwise it might be deleted
93 out from under you the next time the cache is
99 Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
105 const char* stashname;
106 struct mro_meta* meta;
109 assert(HvAUX(stash));
111 stashname = HvNAME_get(stash);
114 "Can't linearize anonymous symbol table");
117 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
120 meta = HvMROMETA(stash);
122 /* return cache if valid */
123 if((retval = meta->mro_linear_dfs)) {
127 /* not in cache, make a new one */
130 av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
133 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
134 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
136 if(av && AvFILLp(av) >= 0) {
138 /* "stored" is used to keep track of all of the classnames
139 we have added to the MRO so far, so we can do a quick
140 exists check and avoid adding duplicate classnames to
143 HV* stored = (HV*)sv_2mortal((SV*)newHV());
144 SV **svp = AvARRAY(av);
145 I32 items = AvFILLp(av) + 1;
149 SV* const sv = *svp++;
150 HV* const basestash = gv_stashsv(sv, 0);
155 /* if no stash exists for this @ISA member,
156 simply add it to the MRO and move on */
161 /* otherwise, recurse into ourselves for the MRO
162 of this @ISA member, and append their MRO to ours */
163 const AV *const subrv
164 = mro_get_linear_isa_dfs(basestash, level + 1);
166 subrv_p = AvARRAY(subrv);
167 subrv_items = AvFILLp(subrv) + 1;
169 while(subrv_items--) {
170 SV *const subsv = *subrv_p++;
171 if(!hv_exists_ent(stored, subsv, 0)) {
172 hv_store_ent(stored, subsv, &PL_sv_undef, 0);
173 av_push(retval, newSVsv(subsv));
179 /* we don't want anyone modifying the cache entry but us,
180 and we do so by replacing it completely */
181 SvREADONLY_on(retval);
183 meta->mro_linear_dfs = retval;
188 =for apidoc mro_get_linear_isa_c3
190 Returns the C3 linearization of @ISA
191 the given stash. The return value is a read-only AV*.
192 C<level> should be 0 (it is used internally in this
193 function's recursion).
195 You are responsible for C<SvREFCNT_inc()> on the
196 return value if you plan to store it anywhere
197 semi-permanently (otherwise it might be deleted
198 out from under you the next time the cache is
205 Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
211 const char* stashname;
212 STRLEN stashname_len;
213 struct mro_meta* meta;
216 assert(HvAUX(stash));
218 stashname = HvNAME_get(stash);
219 stashname_len = HvNAMELEN_get(stash);
222 "Can't linearize anonymous symbol table");
225 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
228 meta = HvMROMETA(stash);
230 /* return cache if valid */
231 if((retval = meta->mro_linear_c3)) {
235 /* not in cache, make a new one */
238 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
240 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
241 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
243 /* For a better idea how the rest of this works, see the much clearer
244 pure perl version in Algorithm::C3 0.01:
245 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
246 (later versions go about it differently than this code for speed reasons)
249 if(isa && AvFILLp(isa) >= 0) {
252 HV* tails = (HV*)sv_2mortal((SV*)newHV());
253 AV* seqs = (AV*)sv_2mortal((SV*)newAV());
256 /* This builds @seqs, which is an array of arrays.
257 The members of @seqs are the MROs of
258 the members of @ISA, followed by @ISA itself.
260 I32 items = AvFILLp(isa) + 1;
261 SV** isa_ptr = AvARRAY(isa);
264 SV* isa_item = *isa_ptr++;
265 HV* isa_item_stash = gv_stashsv(isa_item, 0);
266 if(!isa_item_stash) {
267 /* if no stash, make a temporary fake MRO
268 containing just itself */
269 isa_lin = (AV*)sv_2mortal((SV*)newAV());
270 av_push(isa_lin, newSVsv(isa_item));
273 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
275 av_push(seqs, (SV*)isa_lin);
277 av_push(seqs, (SV*)isa);
279 /* This builds "heads", which as an array of integer array
280 indices, one per seq, which point at the virtual "head"
281 of the seq (initially zero) */
282 Newxz(heads, AvFILLp(seqs)+1, I32);
284 /* This builds %tails, which has one key for every class
285 mentioned in the tail of any sequence in @seqs (tail meaning
286 everything after the first class, the "head"). The value
287 is how many times this key appears in the tails of @seqs.
289 seqs_ptr = AvARRAY(seqs);
290 seqs_items = AvFILLp(seqs) + 1;
291 while(seqs_items--) {
292 AV* seq = (AV*)*seqs_ptr++;
293 I32 seq_items = AvFILLp(seq);
295 SV** seq_ptr = AvARRAY(seq) + 1;
297 SV* seqitem = *seq_ptr++;
298 HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
300 hv_store_ent(tails, seqitem, newSViv(1), 0);
310 /* This loop won't terminate until we either finish building
311 the MRO, or get an exception. */
321 /* "foreach $seq (@seqs)" */
322 SV** avptr = AvARRAY(seqs);
323 for(s = 0; s <= AvFILLp(seqs); s++) {
325 seq = (AV*)(avptr[s]);
326 if(!seq) continue; /* skip empty seqs */
327 svp = av_fetch(seq, heads[s], 0);
328 seqhead = *svp; /* seqhead = head of this seq */
330 /* if we haven't found a winner for this round yet,
331 and this seqhead is not in tails (or the count
332 for it in tails has dropped to zero), then this
333 seqhead is our new winner, and is added to the
334 final MRO immediately */
336 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
337 && (val = HeVAL(tail_entry))
340 winner = newSVsv(cand);
341 av_push(retval, winner);
342 /* note however that even when we find a winner,
343 we continue looping over @seqs to do housekeeping */
345 if(!sv_cmp(seqhead, winner)) {
346 /* Once we have a winner (including the iteration
347 where we first found him), inc the head ptr
348 for any seq which had the winner as a head,
349 NULL out any seq which is now empty,
350 and adjust tails for consistency */
352 int new_head = ++heads[s];
353 if(new_head > AvFILLp(seq)) {
357 /* Because we know this new seqhead used to be
358 a tail, we can assume it is in tails and has
359 a positive value, which we need to dec */
360 svp = av_fetch(seq, new_head, 0);
362 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
363 val = HeVAL(tail_entry);
369 /* if we found no candidates, we are done building the MRO.
370 !cand means no seqs have any entries left to check */
376 /* If we had candidates, but nobody won, then the @ISA
377 hierarchy is not C3-incompatible */
379 /* we have to do some cleanup before we croak */
380 SV** svp = AvARRAY(seqs);
381 items = AvFILLp(seqs) + 1;
385 SvREFCNT_dec(retval);
388 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
389 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
394 /* we don't want anyone modifying the cache entry but us,
395 and we do so by replacing it completely */
396 SvREADONLY_on(retval);
398 meta->mro_linear_c3 = retval;
403 =for apidoc mro_get_linear_isa
405 Returns either C<mro_get_linear_isa_c3> or
406 C<mro_get_linear_isa_dfs> for the given stash,
407 dependant upon which MRO is in effect
408 for that stash. The return value is a
411 You are responsible for C<SvREFCNT_inc()> on the
412 return value if you plan to store it anywhere
413 semi-permanently (otherwise it might be deleted
414 out from under you the next time the cache is
420 Perl_mro_get_linear_isa(pTHX_ HV *stash)
422 struct mro_meta* meta;
424 assert(HvAUX(stash));
426 meta = HvMROMETA(stash);
427 if(meta->mro_which == MRO_DFS) {
428 return mro_get_linear_isa_dfs(stash, 0);
429 } else if(meta->mro_which == MRO_C3) {
430 return mro_get_linear_isa_c3(stash, 0);
432 Perl_croak(aTHX_ "panic: invalid MRO!");
434 return NULL; /* NOT REACHED */
438 =for apidoc mro_isa_changed_in
440 Takes the necessary steps (cache invalidations, mostly)
441 when the @ISA of the given package has changed. Invoked
442 by the C<setisa> magic, should not need to invoke directly.
447 Perl_mro_isa_changed_in(pTHX_ HV* stash)
455 struct mro_meta* meta;
458 stashname = HvNAME_get(stash);
460 /* wipe out the cached linearizations for this stash */
461 meta = HvMROMETA(stash);
462 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
463 SvREFCNT_dec((SV*)meta->mro_linear_c3);
464 meta->mro_linear_dfs = NULL;
465 meta->mro_linear_c3 = NULL;
467 /* Wipe the global method cache if this package
468 is UNIVERSAL or one of its parents */
469 if(meta->is_universal)
472 /* Wipe the local method cache otherwise */
474 meta->sub_generation++;
476 /* wipe next::method cache too */
477 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
479 /* Iterate the isarev (classes that are our children),
480 wiping out their linearization and method caches */
481 if((isarev = meta->mro_isarev)) {
483 while((iter = hv_iternext(isarev))) {
484 SV* revkey = hv_iterkeysv(iter);
485 HV* revstash = gv_stashsv(revkey, 0);
486 struct mro_meta* revmeta = HvMROMETA(revstash);
487 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
488 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
489 revmeta->mro_linear_dfs = NULL;
490 revmeta->mro_linear_c3 = NULL;
491 if(!meta->is_universal)
492 revmeta->sub_generation++;
493 if(revmeta->mro_nextmethod)
494 hv_clear(revmeta->mro_nextmethod);
498 /* Now iterate our MRO (parents), and do a few things:
499 1) instantiate with the "fake" flag if they don't exist
500 2) flag them as universal if we are universal
501 3) Add everything from our isarev to their isarev
504 /* We're starting at the 2nd element, skipping ourselves here */
505 linear_mro = mro_get_linear_isa(stash);
506 svp = AvARRAY(linear_mro) + 1;
507 items = AvFILLp(linear_mro);
510 SV* const sv = *svp++;
511 struct mro_meta* mrometa;
514 HV* mrostash = gv_stashsv(sv, 0);
516 mrostash = gv_stashsv(sv, GV_ADD);
518 We created the package on the fly, so
519 that we could store isarev information.
520 This flag lets gv_fetchmeth know about it,
521 so that it can still generate the very useful
522 "Can't locate package Foo for @Bar::ISA" warning.
524 HvMROMETA(mrostash)->fake = 1;
527 mrometa = HvMROMETA(mrostash);
528 mroisarev = mrometa->mro_isarev;
530 /* is_universal is viral */
531 if(meta->is_universal)
532 mrometa->is_universal = 1;
535 mroisarev = mrometa->mro_isarev = newHV();
537 /* This hash only ever contains PL_sv_yes. Storing it over itself is
538 almost as cheap as calling hv_exists, so on aggregate we expect to
539 save time by not making two calls to the common HV code for the
540 case where it doesn't exist. */
542 hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
546 while((iter = hv_iternext(isarev))) {
547 SV* revkey = hv_iterkeysv(iter);
548 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
555 =for apidoc mro_method_changed_in
557 Like C<mro_isa_changed_in>, but invalidates method
558 caching on any child classes of the given stash, so
559 that they might notice the changes in this one.
561 Ideally, all instances of C<PL_sub_generation++> in
562 the perl source should be replaced by calls to this.
563 Some already are, but some are more difficult to
566 Perl has always had problems with method caches
567 getting out of sync when one directly manipulates
568 stashes via things like C<%{Foo::} = %{Bar::}> or
569 C<${Foo::}{bar} = ...> or the equivalent. If
570 you do this in core or XS code, call this afterwards
571 on the destination stash to get things back in sync.
573 If you're doing such a thing from pure perl, use
574 C<mro::method_changed_in(classname)>, which
580 Perl_mro_method_changed_in(pTHX_ HV *stash)
582 struct mro_meta* meta = HvMROMETA(stash);
586 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
587 invalidate all method caches globally */
588 if(meta->is_universal) {
593 /* else, invalidate the method caches of all child classes,
595 if((isarev = meta->mro_isarev)) {
597 while((iter = hv_iternext(isarev))) {
598 SV* revkey = hv_iterkeysv(iter);
599 HV* revstash = gv_stashsv(revkey, 0);
600 struct mro_meta* mrometa = HvMROMETA(revstash);
601 mrometa->sub_generation++;
602 if(mrometa->mro_nextmethod)
603 hv_clear(mrometa->mro_nextmethod);
608 /* These two are static helpers for next::method and friends,
609 and re-implement a bunch of the code from pp_caller() in
610 a more efficient manner for this particular usage.
614 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
616 for (i = startingblock; i >= 0; i--) {
617 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
623 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
626 register const PERL_CONTEXT *ccstack = cxstack;
627 const PERL_SI *top_si = PL_curstackinfo;
631 const char *fq_subname;
633 STRLEN fq_subname_len;
634 STRLEN stashname_len;
642 GV* candidate = NULL;
646 struct mro_meta* selfmeta;
650 if(sv_isobject(self))
651 selfstash = SvSTASH(SvRV(self));
653 selfstash = gv_stashsv(self, 0);
657 hvname = HvNAME_get(selfstash);
659 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
661 cxix = __dopoptosub_at(cxstack, cxstack_ix);
663 /* This block finds the contextually-enclosing fully-qualified subname,
664 much like looking at (caller($i))[3] until you find a real sub that
667 /* we may be in a higher stacklevel, so dig down deeper */
669 if(top_si->si_type == PERLSI_MAIN)
670 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
671 top_si = top_si->si_prev;
672 ccstack = top_si->si_cxstack;
673 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
676 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
677 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
678 cxix = __dopoptosub_at(ccstack, cxix - 1);
683 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
684 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
685 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
692 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
695 cxix = __dopoptosub_at(ccstack, cxix - 1);
699 /* we found a real sub here */
700 sv = sv_2mortal(newSV(0));
702 gv_efullname3(sv, cvgv, NULL);
704 fq_subname = SvPVX(sv);
705 fq_subname_len = SvCUR(sv);
707 subname = strrchr(fq_subname, ':');
709 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
712 subname_len = fq_subname_len - (subname - fq_subname);
713 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
714 cxix = __dopoptosub_at(ccstack, cxix - 1);
720 /* If we made it to here, we found our context */
722 /* Initialize the next::method cache for this stash
724 selfmeta = HvMROMETA(selfstash);
725 if(!(nmcache = selfmeta->mro_nextmethod)) {
726 nmcache = selfmeta->mro_nextmethod = newHV();
729 /* Use the cached coderef if it exists */
730 else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
731 SV* val = HeVAL(cache_entry);
732 if(val == &PL_sv_undef) {
734 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
739 /* beyond here is just for cache misses, so perf isn't as critical */
741 stashname_len = subname - fq_subname - 2;
742 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
744 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
746 linear_svp = AvARRAY(linear_av);
747 items = AvFILLp(linear_av) + 1;
749 /* Walk down our MRO, skipping everything up
750 to the contextually enclosing class */
752 linear_sv = *linear_svp++;
754 if(sv_eq(linear_sv, stashname))
758 /* Now search the remainder of the MRO for the
759 same method name as the contextually enclosing
763 linear_sv = *linear_svp++;
765 curstash = gv_stashsv(linear_sv, FALSE);
767 if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
768 if (ckWARN(WARN_SYNTAX))
769 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
770 (void*)linear_sv, hvname);
776 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
782 if (SvTYPE(candidate) != SVt_PVGV)
783 gv_init(candidate, curstash, subname, subname_len, TRUE);
785 /* Notably, we only look for real entries, not method cache
786 entries, because in C3 the method cache of a parent is not
787 valid for the child */
788 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
789 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
790 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
796 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
798 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
804 XS(XS_mro_get_linear_isa);
807 XS(XS_mro_get_isarev);
808 XS(XS_mro_is_universal);
809 XS(XS_mro_get_global_sub_gen);
810 XS(XS_mro_invalidate_method_caches);
811 XS(XS_mro_get_sub_generation);
812 XS(XS_mro_method_changed_in);
815 XS(XS_maybe_next_method);
818 Perl_boot_core_mro(pTHX)
821 static const char file[] = __FILE__;
823 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
824 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
825 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
826 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
827 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
828 newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, "");
829 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
830 newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
831 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
832 newXS("next::can", XS_next_can, file);
833 newXS("next::method", XS_next_method, file);
834 newXS("maybe::next::method", XS_maybe_next_method, file);
837 XS(XS_mro_get_linear_isa) {
846 if(items < 1 || items > 2)
847 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
850 class_stash = gv_stashsv(classname, 0);
851 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
854 char* which = SvPV_nolen(ST(1));
855 if(strEQ(which, "dfs"))
856 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
857 else if(strEQ(which, "c3"))
858 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
860 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
863 RETVAL = mro_get_linear_isa(class_stash);
866 ST(0) = newRV_inc((SV*)RETVAL);
879 struct mro_meta* meta;
884 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
887 whichstr = SvPV_nolen(ST(1));
888 class_stash = gv_stashsv(classname, GV_ADD);
889 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
890 meta = HvMROMETA(class_stash);
892 if(strEQ(whichstr, "dfs"))
894 else if(strEQ(whichstr, "c3"))
897 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
899 if(meta->mro_which != which) {
900 meta->mro_which = which;
901 /* Only affects local method cache, not
902 even child classes */
903 meta->sub_generation++;
904 if(meta->mro_nextmethod)
905 hv_clear(meta->mro_nextmethod);
918 struct mro_meta* meta;
923 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
926 class_stash = gv_stashsv(classname, 0);
927 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
928 meta = HvMROMETA(class_stash);
930 if(meta->mro_which == MRO_DFS)
931 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
933 ST(0) = sv_2mortal(newSVpvn("c3", 2));
938 XS(XS_mro_get_isarev)
949 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
953 class_stash = gv_stashsv(classname, 0);
954 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
958 if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
961 while((iter = hv_iternext(isarev)))
962 XPUSHs(hv_iterkeysv(iter));
969 XS(XS_mro_is_universal)
979 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
982 class_stash = gv_stashsv(classname, 0);
983 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
985 if (HvMROMETA(class_stash)->is_universal)
991 XS(XS_mro_get_global_sub_gen)
999 Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
1001 ST(0) = sv_2mortal(newSViv(PL_sub_generation));
1005 XS(XS_mro_invalidate_method_caches)
1010 PERL_UNUSED_ARG(cv);
1013 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1015 PL_sub_generation++;
1020 XS(XS_mro_get_sub_generation)
1027 PERL_UNUSED_ARG(cv);
1030 Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
1033 class_stash = gv_stashsv(classname, 0);
1034 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1036 ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
1040 XS(XS_mro_method_changed_in)
1047 PERL_UNUSED_ARG(cv);
1050 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1054 class_stash = gv_stashsv(classname, 0);
1055 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1057 mro_method_changed_in(class_stash);
1067 SV* methcv = __nextcan(aTHX_ self, 0);
1069 PERL_UNUSED_ARG(cv);
1070 PERL_UNUSED_VAR(items);
1072 if(methcv == &PL_sv_undef) {
1073 ST(0) = &PL_sv_undef;
1076 ST(0) = sv_2mortal(newRV_inc(methcv));
1087 SV* methcv = __nextcan(aTHX_ self, 1);
1089 PERL_UNUSED_ARG(cv);
1092 call_sv(methcv, GIMME_V);
1095 XS(XS_maybe_next_method)
1100 SV* methcv = __nextcan(aTHX_ self, 0);
1102 PERL_UNUSED_ARG(cv);
1104 if(methcv == &PL_sv_undef) {
1105 ST(0) = &PL_sv_undef;
1110 call_sv(methcv, GIMME_V);
1115 * c-indentation-style: bsd
1117 * indent-tabs-mode: t
1120 * ex: set ts=8 sts=4 sw=4 noet: