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;
488 if(!revstash) continue;
489 revmeta = HvMROMETA(revstash);
490 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
491 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
492 revmeta->mro_linear_dfs = NULL;
493 revmeta->mro_linear_c3 = NULL;
494 if(!meta->is_universal)
495 revmeta->sub_generation++;
496 if(revmeta->mro_nextmethod)
497 hv_clear(revmeta->mro_nextmethod);
501 /* Now iterate our MRO (parents), and do a few things:
502 1) instantiate with the "fake" flag if they don't exist
503 2) flag them as universal if we are universal
504 3) Add everything from our isarev to their isarev
507 /* We're starting at the 2nd element, skipping ourselves here */
508 linear_mro = mro_get_linear_isa(stash);
509 svp = AvARRAY(linear_mro) + 1;
510 items = AvFILLp(linear_mro);
513 SV* const sv = *svp++;
514 struct mro_meta* mrometa;
517 HV* mrostash = gv_stashsv(sv, 0);
519 mrostash = gv_stashsv(sv, GV_ADD);
521 We created the package on the fly, so
522 that we could store isarev information.
523 This flag lets gv_fetchmeth know about it,
524 so that it can still generate the very useful
525 "Can't locate package Foo for @Bar::ISA" warning.
527 HvMROMETA(mrostash)->fake = 1;
530 mrometa = HvMROMETA(mrostash);
531 mroisarev = mrometa->mro_isarev;
533 /* is_universal is viral */
534 if(meta->is_universal)
535 mrometa->is_universal = 1;
538 mroisarev = mrometa->mro_isarev = newHV();
540 /* This hash only ever contains PL_sv_yes. Storing it over itself is
541 almost as cheap as calling hv_exists, so on aggregate we expect to
542 save time by not making two calls to the common HV code for the
543 case where it doesn't exist. */
545 hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
549 while((iter = hv_iternext(isarev))) {
550 SV* revkey = hv_iterkeysv(iter);
551 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
558 =for apidoc mro_method_changed_in
560 Invalidates method caching on any child classes
561 of the given stash, so that they might notice
562 the changes in this one.
564 Ideally, all instances of C<PL_sub_generation++> in
565 the perl source outside of C<mro.c> should be
566 replaced by calls to this. This conversion is
569 Perl has always had problems with method caches
570 getting out of sync when one directly manipulates
571 stashes via things like C<%{Foo::} = %{Bar::}> or
572 C<${Foo::}{bar} = ...> or the equivalent. If
573 you do this in core or XS code, call this afterwards
574 on the destination stash to get things back in sync.
576 If you're doing such a thing from pure perl, use
577 C<mro::method_changed_in(classname)>, which
583 Perl_mro_method_changed_in(pTHX_ HV *stash)
585 struct mro_meta* meta = HvMROMETA(stash);
589 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
590 invalidate all method caches globally */
591 if(meta->is_universal) {
596 /* else, invalidate the method caches of all child classes,
598 if((isarev = meta->mro_isarev)) {
600 while((iter = hv_iternext(isarev))) {
601 SV* revkey = hv_iterkeysv(iter);
602 HV* revstash = gv_stashsv(revkey, 0);
603 struct mro_meta* mrometa;
605 if(!revstash) continue;
606 mrometa = HvMROMETA(revstash);
607 mrometa->sub_generation++;
608 if(mrometa->mro_nextmethod)
609 hv_clear(mrometa->mro_nextmethod);
614 /* These two are static helpers for next::method and friends,
615 and re-implement a bunch of the code from pp_caller() in
616 a more efficient manner for this particular usage.
620 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
622 for (i = startingblock; i >= 0; i--) {
623 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
629 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
632 register const PERL_CONTEXT *ccstack = cxstack;
633 const PERL_SI *top_si = PL_curstackinfo;
637 const char *fq_subname;
639 STRLEN fq_subname_len;
640 STRLEN stashname_len;
648 GV* candidate = NULL;
652 struct mro_meta* selfmeta;
656 if(sv_isobject(self))
657 selfstash = SvSTASH(SvRV(self));
659 selfstash = gv_stashsv(self, 0);
663 hvname = HvNAME_get(selfstash);
665 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
667 cxix = __dopoptosub_at(cxstack, cxstack_ix);
669 /* This block finds the contextually-enclosing fully-qualified subname,
670 much like looking at (caller($i))[3] until you find a real sub that
673 /* we may be in a higher stacklevel, so dig down deeper */
675 if(top_si->si_type == PERLSI_MAIN)
676 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
677 top_si = top_si->si_prev;
678 ccstack = top_si->si_cxstack;
679 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
682 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
683 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
684 cxix = __dopoptosub_at(ccstack, cxix - 1);
689 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
690 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
691 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
698 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
701 cxix = __dopoptosub_at(ccstack, cxix - 1);
705 /* we found a real sub here */
706 sv = sv_2mortal(newSV(0));
708 gv_efullname3(sv, cvgv, NULL);
710 fq_subname = SvPVX(sv);
711 fq_subname_len = SvCUR(sv);
713 subname = strrchr(fq_subname, ':');
715 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
718 subname_len = fq_subname_len - (subname - fq_subname);
719 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
720 cxix = __dopoptosub_at(ccstack, cxix - 1);
726 /* If we made it to here, we found our context */
728 /* Initialize the next::method cache for this stash
730 selfmeta = HvMROMETA(selfstash);
731 if(!(nmcache = selfmeta->mro_nextmethod)) {
732 nmcache = selfmeta->mro_nextmethod = newHV();
735 /* Use the cached coderef if it exists */
736 else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
737 SV* val = HeVAL(cache_entry);
738 if(val == &PL_sv_undef) {
740 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
745 /* beyond here is just for cache misses, so perf isn't as critical */
747 stashname_len = subname - fq_subname - 2;
748 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
750 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
752 linear_svp = AvARRAY(linear_av);
753 items = AvFILLp(linear_av) + 1;
755 /* Walk down our MRO, skipping everything up
756 to the contextually enclosing class */
758 linear_sv = *linear_svp++;
760 if(sv_eq(linear_sv, stashname))
764 /* Now search the remainder of the MRO for the
765 same method name as the contextually enclosing
769 linear_sv = *linear_svp++;
771 curstash = gv_stashsv(linear_sv, FALSE);
773 if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
774 if (ckWARN(WARN_SYNTAX))
775 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
776 (void*)linear_sv, hvname);
782 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
788 if (SvTYPE(candidate) != SVt_PVGV)
789 gv_init(candidate, curstash, subname, subname_len, TRUE);
791 /* Notably, we only look for real entries, not method cache
792 entries, because in C3 the method cache of a parent is not
793 valid for the child */
794 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
795 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
796 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
802 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
804 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
810 XS(XS_mro_get_linear_isa);
813 XS(XS_mro_get_isarev);
814 XS(XS_mro_is_universal);
815 XS(XS_mro_get_global_sub_gen);
816 XS(XS_mro_invalidate_method_caches);
817 XS(XS_mro_get_sub_generation);
818 XS(XS_mro_method_changed_in);
821 XS(XS_maybe_next_method);
824 Perl_boot_core_mro(pTHX)
827 static const char file[] = __FILE__;
829 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
830 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
831 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
832 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
833 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
834 newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, "");
835 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
836 newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
837 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
838 newXS("next::can", XS_next_can, file);
839 newXS("next::method", XS_next_method, file);
840 newXS("maybe::next::method", XS_maybe_next_method, file);
843 XS(XS_mro_get_linear_isa) {
852 if(items < 1 || items > 2)
853 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
856 class_stash = gv_stashsv(classname, 0);
857 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
860 char* which = SvPV_nolen(ST(1));
861 if(strEQ(which, "dfs"))
862 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
863 else if(strEQ(which, "c3"))
864 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
866 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
869 RETVAL = mro_get_linear_isa(class_stash);
872 ST(0) = newRV_inc((SV*)RETVAL);
885 struct mro_meta* meta;
890 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
893 whichstr = SvPV_nolen(ST(1));
894 class_stash = gv_stashsv(classname, GV_ADD);
895 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
896 meta = HvMROMETA(class_stash);
898 if(strEQ(whichstr, "dfs"))
900 else if(strEQ(whichstr, "c3"))
903 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
905 if(meta->mro_which != which) {
906 meta->mro_which = which;
907 /* Only affects local method cache, not
908 even child classes */
909 meta->sub_generation++;
910 if(meta->mro_nextmethod)
911 hv_clear(meta->mro_nextmethod);
924 struct mro_meta* meta;
929 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
932 class_stash = gv_stashsv(classname, 0);
933 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
934 meta = HvMROMETA(class_stash);
936 if(meta->mro_which == MRO_DFS)
937 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
939 ST(0) = sv_2mortal(newSVpvn("c3", 2));
944 XS(XS_mro_get_isarev)
955 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
959 class_stash = gv_stashsv(classname, 0);
960 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
964 if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
967 while((iter = hv_iternext(isarev)))
968 XPUSHs(hv_iterkeysv(iter));
975 XS(XS_mro_is_universal)
985 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
988 class_stash = gv_stashsv(classname, 0);
989 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
991 if (HvMROMETA(class_stash)->is_universal)
997 XS(XS_mro_get_global_sub_gen)
1002 PERL_UNUSED_ARG(cv);
1005 Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
1007 ST(0) = sv_2mortal(newSViv(PL_sub_generation));
1011 XS(XS_mro_invalidate_method_caches)
1016 PERL_UNUSED_ARG(cv);
1019 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1021 PL_sub_generation++;
1026 XS(XS_mro_get_sub_generation)
1033 PERL_UNUSED_ARG(cv);
1036 Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
1039 class_stash = gv_stashsv(classname, 0);
1040 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1042 ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
1046 XS(XS_mro_method_changed_in)
1053 PERL_UNUSED_ARG(cv);
1056 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1060 class_stash = gv_stashsv(classname, 0);
1061 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1063 mro_method_changed_in(class_stash);
1073 SV* methcv = __nextcan(aTHX_ self, 0);
1075 PERL_UNUSED_ARG(cv);
1076 PERL_UNUSED_VAR(items);
1078 if(methcv == &PL_sv_undef) {
1079 ST(0) = &PL_sv_undef;
1082 ST(0) = sv_2mortal(newRV_inc(methcv));
1093 SV* methcv = __nextcan(aTHX_ self, 1);
1095 PERL_UNUSED_ARG(cv);
1098 call_sv(methcv, GIMME_V);
1101 XS(XS_maybe_next_method)
1106 SV* methcv = __nextcan(aTHX_ self, 0);
1108 PERL_UNUSED_ARG(cv);
1110 if(methcv == &PL_sv_undef) {
1111 ST(0) = &PL_sv_undef;
1116 call_sv(methcv, GIMME_V);
1121 * c-indentation-style: bsd
1123 * indent-tabs-mode: t
1126 * ex: set ts=8 sts=4 sw=4 noet: