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!");
437 =for apidoc mro_isa_changed_in
439 Takes the necessary steps (cache invalidations, mostly)
440 when the @ISA of the given package has changed. Invoked
441 by the C<setisa> magic, should not need to invoke directly.
446 Perl_mro_isa_changed_in(pTHX_ HV* stash)
454 struct mro_meta* meta;
457 stashname = HvNAME_get(stash);
459 /* wipe out the cached linearizations for this stash */
460 meta = HvMROMETA(stash);
461 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
462 SvREFCNT_dec((SV*)meta->mro_linear_c3);
463 meta->mro_linear_dfs = NULL;
464 meta->mro_linear_c3 = NULL;
466 /* Wipe the global method cache if this package
467 is UNIVERSAL or one of its parents */
468 if(meta->is_universal)
471 /* Wipe the local method cache otherwise */
473 meta->sub_generation++;
475 /* wipe next::method cache too */
476 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
478 /* Iterate the isarev (classes that are our children),
479 wiping out their linearization and method caches */
480 if((isarev = meta->mro_isarev)) {
482 while((iter = hv_iternext(isarev))) {
483 SV* revkey = hv_iterkeysv(iter);
484 HV* revstash = gv_stashsv(revkey, 0);
485 struct mro_meta* 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;
490 if(!meta->is_universal)
491 revmeta->sub_generation++;
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++;
510 struct mro_meta* mrometa;
513 HV* mrostash = gv_stashsv(sv, 0);
515 mrostash = gv_stashsv(sv, GV_ADD);
517 We created the package on the fly, so
518 that we could store isarev information.
519 This flag lets gv_fetchmeth know about it,
520 so that it can still generate the very useful
521 "Can't locate package Foo for @Bar::ISA" warning.
523 HvMROMETA(mrostash)->fake = 1;
526 mrometa = HvMROMETA(mrostash);
527 mroisarev = mrometa->mro_isarev;
529 /* is_universal is viral */
530 if(meta->is_universal)
531 mrometa->is_universal = 1;
534 mroisarev = mrometa->mro_isarev = newHV();
536 /* This hash only ever contains PL_sv_yes. Storing it over itself is
537 almost as cheap as calling hv_exists, so on aggregate we expect to
538 save time by not making two calls to the common HV code for the
539 case where it doesn't exist. */
541 hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
545 while((iter = hv_iternext(isarev))) {
546 SV* revkey = hv_iterkeysv(iter);
547 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
554 =for apidoc mro_method_changed_in
556 Like C<mro_isa_changed_in>, but invalidates method
557 caching on any child classes of the given stash, so
558 that they might notice the changes in this one.
560 Ideally, all instances of C<PL_sub_generation++> in
561 the perl source should be replaced by calls to this.
562 Some already are, but some are more difficult to
565 Perl has always had problems with method caches
566 getting out of sync when one directly manipulates
567 stashes via things like C<%{Foo::} = %{Bar::}> or
568 C<${Foo::}{bar} = ...> or the equivalent. If
569 you do this in core or XS code, call this afterwards
570 on the destination stash to get things back in sync.
572 If you're doing such a thing from pure perl, use
573 C<mro::method_changed_in(classname)>, which
579 Perl_mro_method_changed_in(pTHX_ HV *stash)
581 struct mro_meta* meta = HvMROMETA(stash);
585 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
586 invalidate all method caches globally */
587 if(meta->is_universal) {
592 /* else, invalidate the method caches of all child classes,
594 if((isarev = meta->mro_isarev)) {
596 while((iter = hv_iternext(isarev))) {
597 SV* revkey = hv_iterkeysv(iter);
598 HV* revstash = gv_stashsv(revkey, 0);
599 struct mro_meta* mrometa = HvMROMETA(revstash);
600 mrometa->sub_generation++;
601 if(mrometa->mro_nextmethod)
602 hv_clear(mrometa->mro_nextmethod);
607 /* These two are static helpers for next::method and friends,
608 and re-implement a bunch of the code from pp_caller() in
609 a more efficient manner for this particular usage.
613 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
615 for (i = startingblock; i >= 0; i--) {
616 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
622 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
625 register const PERL_CONTEXT *ccstack = cxstack;
626 const PERL_SI *top_si = PL_curstackinfo;
630 const char *fq_subname;
632 STRLEN fq_subname_len;
633 STRLEN stashname_len;
641 GV* candidate = NULL;
645 struct mro_meta* selfmeta;
649 if(sv_isobject(self))
650 selfstash = SvSTASH(SvRV(self));
652 selfstash = gv_stashsv(self, 0);
656 hvname = HvNAME_get(selfstash);
658 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
660 cxix = __dopoptosub_at(cxstack, cxstack_ix);
662 /* This block finds the contextually-enclosing fully-qualified subname,
663 much like looking at (caller($i))[3] until you find a real sub that
666 /* we may be in a higher stacklevel, so dig down deeper */
668 if(top_si->si_type == PERLSI_MAIN)
669 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
670 top_si = top_si->si_prev;
671 ccstack = top_si->si_cxstack;
672 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
675 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
676 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
677 cxix = __dopoptosub_at(ccstack, cxix - 1);
682 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
683 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
684 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
691 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
694 cxix = __dopoptosub_at(ccstack, cxix - 1);
698 /* we found a real sub here */
699 sv = sv_2mortal(newSV(0));
701 gv_efullname3(sv, cvgv, NULL);
703 fq_subname = SvPVX(sv);
704 fq_subname_len = SvCUR(sv);
706 subname = strrchr(fq_subname, ':');
708 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
711 subname_len = fq_subname_len - (subname - fq_subname);
712 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
713 cxix = __dopoptosub_at(ccstack, cxix - 1);
719 /* If we made it to here, we found our context */
721 /* Initialize the next::method cache for this stash
723 selfmeta = HvMROMETA(selfstash);
724 if(!(nmcache = selfmeta->mro_nextmethod)) {
725 nmcache = selfmeta->mro_nextmethod = newHV();
728 /* Use the cached coderef if it exists */
729 else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
730 SV* val = HeVAL(cache_entry);
731 if(val == &PL_sv_undef) {
733 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
738 /* beyond here is just for cache misses, so perf isn't as critical */
740 stashname_len = subname - fq_subname - 2;
741 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
743 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
745 linear_svp = AvARRAY(linear_av);
746 items = AvFILLp(linear_av) + 1;
748 /* Walk down our MRO, skipping everything up
749 to the contextually enclosing class */
751 linear_sv = *linear_svp++;
753 if(sv_eq(linear_sv, stashname))
757 /* Now search the remainder of the MRO for the
758 same method name as the contextually enclosing
762 linear_sv = *linear_svp++;
764 curstash = gv_stashsv(linear_sv, FALSE);
766 if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
767 if (ckWARN(WARN_SYNTAX))
768 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
769 (void*)linear_sv, hvname);
775 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
781 if (SvTYPE(candidate) != SVt_PVGV)
782 gv_init(candidate, curstash, subname, subname_len, TRUE);
784 /* Notably, we only look for real entries, not method cache
785 entries, because in C3 the method cache of a parent is not
786 valid for the child */
787 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
788 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
789 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
795 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
797 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
803 XS(XS_mro_get_linear_isa);
806 XS(XS_mro_get_isarev);
807 XS(XS_mro_is_universal);
808 XS(XS_mro_get_global_sub_gen);
809 XS(XS_mro_invalidate_method_caches);
810 XS(XS_mro_get_sub_generation);
811 XS(XS_mro_method_changed_in);
814 XS(XS_maybe_next_method);
817 Perl_boot_core_mro(pTHX)
820 static const char file[] = __FILE__;
822 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
823 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
824 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
825 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
826 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
827 newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, "");
828 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
829 newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
830 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
831 newXS("next::can", XS_next_can, file);
832 newXS("next::method", XS_next_method, file);
833 newXS("maybe::next::method", XS_maybe_next_method, file);
836 XS(XS_mro_get_linear_isa) {
845 if(items < 1 || items > 2)
846 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
849 class_stash = gv_stashsv(classname, 0);
850 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
853 char* which = SvPV_nolen(ST(1));
854 if(strEQ(which, "dfs"))
855 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
856 else if(strEQ(which, "c3"))
857 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
859 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
862 RETVAL = mro_get_linear_isa(class_stash);
865 ST(0) = newRV_inc((SV*)RETVAL);
878 struct mro_meta* meta;
883 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
886 whichstr = SvPV_nolen(ST(1));
887 class_stash = gv_stashsv(classname, GV_ADD);
888 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
889 meta = HvMROMETA(class_stash);
891 if(strEQ(whichstr, "dfs"))
893 else if(strEQ(whichstr, "c3"))
896 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
898 if(meta->mro_which != which) {
899 meta->mro_which = which;
900 /* Only affects local method cache, not
901 even child classes */
902 meta->sub_generation++;
903 if(meta->mro_nextmethod)
904 hv_clear(meta->mro_nextmethod);
917 struct mro_meta* meta;
922 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
925 class_stash = gv_stashsv(classname, 0);
926 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
927 meta = HvMROMETA(class_stash);
929 if(meta->mro_which == MRO_DFS)
930 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
932 ST(0) = sv_2mortal(newSVpvn("c3", 2));
937 XS(XS_mro_get_isarev)
948 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
952 class_stash = gv_stashsv(classname, 0);
953 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
957 if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
960 while((iter = hv_iternext(isarev)))
961 XPUSHs(hv_iterkeysv(iter));
968 XS(XS_mro_is_universal)
978 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
981 class_stash = gv_stashsv(classname, 0);
982 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
984 if (HvMROMETA(class_stash)->is_universal)
990 XS(XS_mro_get_global_sub_gen)
998 Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
1000 ST(0) = sv_2mortal(newSViv(PL_sub_generation));
1004 XS(XS_mro_invalidate_method_caches)
1009 PERL_UNUSED_ARG(cv);
1012 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1014 PL_sub_generation++;
1019 XS(XS_mro_get_sub_generation)
1026 PERL_UNUSED_ARG(cv);
1029 Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
1032 class_stash = gv_stashsv(classname, 0);
1033 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1035 ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
1039 XS(XS_mro_method_changed_in)
1046 PERL_UNUSED_ARG(cv);
1049 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1053 class_stash = gv_stashsv(classname, 0);
1054 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1056 mro_method_changed_in(class_stash);
1066 SV* methcv = __nextcan(aTHX_ self, 0);
1068 PERL_UNUSED_ARG(cv);
1069 PERL_UNUSED_VAR(items);
1071 if(methcv == &PL_sv_undef) {
1072 ST(0) = &PL_sv_undef;
1075 ST(0) = sv_2mortal(newRV_inc(methcv));
1086 SV* methcv = __nextcan(aTHX_ self, 1);
1088 PERL_UNUSED_ARG(cv);
1091 call_sv(methcv, GIMME_V);
1094 XS(XS_maybe_next_method)
1099 SV* methcv = __nextcan(aTHX_ self, 0);
1101 PERL_UNUSED_ARG(cv);
1103 if(methcv == &PL_sv_undef) {
1104 ST(0) = &PL_sv_undef;
1109 call_sv(methcv, GIMME_V);
1114 * c-indentation-style: bsd
1116 * indent-tabs-mode: t
1119 * ex: set ts=8 sts=4 sw=4 noet: