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;
42 #if defined(USE_ITHREADS)
44 /* for sv_dup on new threads */
46 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
48 struct mro_meta* newmeta;
52 Newx(newmeta, 1, struct mro_meta);
53 Copy(smeta, newmeta, 1, struct mro_meta);
55 if (newmeta->mro_linear_dfs)
56 newmeta->mro_linear_dfs
57 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
58 if (newmeta->mro_linear_c3)
59 newmeta->mro_linear_c3
60 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
61 if (newmeta->mro_nextmethod)
62 newmeta->mro_nextmethod
63 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
68 #endif /* USE_ITHREADS */
71 =for apidoc mro_get_linear_isa_dfs
73 Returns the Depth-First Search linearization of @ISA
74 the given stash. The return value is a read-only AV*.
75 C<level> should be 0 (it is used internally in this
76 function's recursion).
78 You are responsible for C<SvREFCNT_inc()> on the
79 return value if you plan to store it anywhere
80 semi-permanently (otherwise it might be deleted
81 out from under you the next time the cache is
87 Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
93 const char* stashname;
94 struct mro_meta* meta;
99 stashname = HvNAME_get(stash);
101 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
104 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
107 meta = HvMROMETA(stash);
109 /* return cache if valid */
110 if((retval = meta->mro_linear_dfs)) {
114 /* not in cache, make a new one */
117 av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
120 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
121 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
123 if(av && AvFILLp(av) >= 0) {
125 /* "stored" is used to keep track of all of the classnames
126 we have added to the MRO so far, so we can do a quick
127 exists check and avoid adding duplicate classnames to
130 HV* const stored = (HV*)sv_2mortal((SV*)newHV());
131 SV **svp = AvARRAY(av);
132 I32 items = AvFILLp(av) + 1;
136 SV* const sv = *svp++;
137 HV* const basestash = gv_stashsv(sv, 0);
142 /* if no stash exists for this @ISA member,
143 simply add it to the MRO and move on */
148 /* otherwise, recurse into ourselves for the MRO
149 of this @ISA member, and append their MRO to ours */
150 const AV *const subrv
151 = mro_get_linear_isa_dfs(basestash, level + 1);
153 subrv_p = AvARRAY(subrv);
154 subrv_items = AvFILLp(subrv) + 1;
156 while(subrv_items--) {
157 SV *const subsv = *subrv_p++;
158 if(!hv_exists_ent(stored, subsv, 0)) {
159 hv_store_ent(stored, subsv, &PL_sv_undef, 0);
160 av_push(retval, newSVsv(subsv));
166 /* we don't want anyone modifying the cache entry but us,
167 and we do so by replacing it completely */
168 SvREADONLY_on(retval);
170 meta->mro_linear_dfs = retval;
175 =for apidoc mro_get_linear_isa_c3
177 Returns the C3 linearization of @ISA
178 the given stash. The return value is a read-only AV*.
179 C<level> should be 0 (it is used internally in this
180 function's recursion).
182 You are responsible for C<SvREFCNT_inc()> on the
183 return value if you plan to store it anywhere
184 semi-permanently (otherwise it might be deleted
185 out from under you the next time the cache is
192 Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
198 const char* stashname;
199 STRLEN stashname_len;
200 struct mro_meta* meta;
203 assert(HvAUX(stash));
205 stashname = HvNAME_get(stash);
206 stashname_len = HvNAMELEN_get(stash);
208 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
211 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
214 meta = HvMROMETA(stash);
216 /* return cache if valid */
217 if((retval = meta->mro_linear_c3)) {
221 /* not in cache, make a new one */
223 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
224 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
226 /* For a better idea how the rest of this works, see the much clearer
227 pure perl version in Algorithm::C3 0.01:
228 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
229 (later versions go about it differently than this code for speed reasons)
232 if(isa && AvFILLp(isa) >= 0) {
235 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
236 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
239 /* This builds @seqs, which is an array of arrays.
240 The members of @seqs are the MROs of
241 the members of @ISA, followed by @ISA itself.
243 I32 items = AvFILLp(isa) + 1;
244 SV** isa_ptr = AvARRAY(isa);
246 SV* const isa_item = *isa_ptr++;
247 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
248 if(!isa_item_stash) {
249 /* if no stash, make a temporary fake MRO
250 containing just itself */
251 AV* const isa_lin = newAV();
252 av_push(isa_lin, newSVsv(isa_item));
253 av_push(seqs, (SV*)isa_lin);
257 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
258 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
261 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
263 /* This builds "heads", which as an array of integer array
264 indices, one per seq, which point at the virtual "head"
265 of the seq (initially zero) */
266 Newxz(heads, AvFILLp(seqs)+1, I32);
268 /* This builds %tails, which has one key for every class
269 mentioned in the tail of any sequence in @seqs (tail meaning
270 everything after the first class, the "head"). The value
271 is how many times this key appears in the tails of @seqs.
273 seqs_ptr = AvARRAY(seqs);
274 seqs_items = AvFILLp(seqs) + 1;
275 while(seqs_items--) {
276 AV* const seq = (AV*)*seqs_ptr++;
277 I32 seq_items = AvFILLp(seq);
279 SV** seq_ptr = AvARRAY(seq) + 1;
281 SV* const seqitem = *seq_ptr++;
282 HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
284 hv_store_ent(tails, seqitem, newSViv(1), 0);
287 SV* const val = HeVAL(he);
294 /* Initialize retval to build the return value in */
296 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
298 /* This loop won't terminate until we either finish building
299 the MRO, or get an exception. */
305 /* "foreach $seq (@seqs)" */
306 SV** const avptr = AvARRAY(seqs);
307 for(s = 0; s <= AvFILLp(seqs); s++) {
309 AV * const seq = (AV*)(avptr[s]);
311 if(!seq) continue; /* skip empty seqs */
312 svp = av_fetch(seq, heads[s], 0);
313 seqhead = *svp; /* seqhead = head of this seq */
317 /* if we haven't found a winner for this round yet,
318 and this seqhead is not in tails (or the count
319 for it in tails has dropped to zero), then this
320 seqhead is our new winner, and is added to the
321 final MRO immediately */
323 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
324 && (val = HeVAL(tail_entry))
327 winner = newSVsv(cand);
328 av_push(retval, winner);
329 /* note however that even when we find a winner,
330 we continue looping over @seqs to do housekeeping */
332 if(!sv_cmp(seqhead, winner)) {
333 /* Once we have a winner (including the iteration
334 where we first found him), inc the head ptr
335 for any seq which had the winner as a head,
336 NULL out any seq which is now empty,
337 and adjust tails for consistency */
339 const int new_head = ++heads[s];
340 if(new_head > AvFILLp(seq)) {
341 SvREFCNT_dec(avptr[s]);
347 /* Because we know this new seqhead used to be
348 a tail, we can assume it is in tails and has
349 a positive value, which we need to dec */
350 svp = av_fetch(seq, new_head, 0);
352 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
353 val = HeVAL(tail_entry);
359 /* if we found no candidates, we are done building the MRO.
360 !cand means no seqs have any entries left to check */
366 /* If we had candidates, but nobody won, then the @ISA
367 hierarchy is not C3-incompatible */
369 /* we have to do some cleanup before we croak */
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));
379 else { /* @ISA was undefined or empty */
380 /* build a retval containing only ourselves */
382 av_push(retval, newSVpvn(stashname, stashname_len));
385 /* we don't want anyone modifying the cache entry but us,
386 and we do so by replacing it completely */
387 SvREADONLY_on(retval);
389 meta->mro_linear_c3 = retval;
394 =for apidoc mro_get_linear_isa
396 Returns either C<mro_get_linear_isa_c3> or
397 C<mro_get_linear_isa_dfs> for the given stash,
398 dependant upon which MRO is in effect
399 for that stash. The return value is a
402 You are responsible for C<SvREFCNT_inc()> on the
403 return value if you plan to store it anywhere
404 semi-permanently (otherwise it might be deleted
405 out from under you the next time the cache is
411 Perl_mro_get_linear_isa(pTHX_ HV *stash)
413 struct mro_meta* meta;
415 assert(HvAUX(stash));
417 meta = HvMROMETA(stash);
418 if(meta->mro_which == MRO_DFS) {
419 return mro_get_linear_isa_dfs(stash, 0);
420 } else if(meta->mro_which == MRO_C3) {
421 return mro_get_linear_isa_c3(stash, 0);
423 Perl_croak(aTHX_ "panic: invalid MRO!");
425 return NULL; /* NOT REACHED */
429 =for apidoc mro_isa_changed_in
431 Takes the necessary steps (cache invalidations, mostly)
432 when the @ISA of the given package has changed. Invoked
433 by the C<setisa> magic, should not need to invoke directly.
438 Perl_mro_isa_changed_in(pTHX_ HV* stash)
448 const char * const stashname = HvNAME_get(stash);
449 const STRLEN stashname_len = HvNAMELEN_get(stash);
451 /* wipe out the cached linearizations for this stash */
452 struct mro_meta * const meta = HvMROMETA(stash);
453 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
454 SvREFCNT_dec((SV*)meta->mro_linear_c3);
455 meta->mro_linear_dfs = NULL;
456 meta->mro_linear_c3 = NULL;
458 /* Inc the package generation, since our @ISA changed */
461 /* Wipe the global method cache if this package
462 is UNIVERSAL or one of its parents */
464 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
465 isarev = svp ? (HV*)*svp : NULL;
467 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
468 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
472 else { /* Wipe the local method cache otherwise */
474 is_universal = FALSE;
477 /* wipe next::method cache too */
478 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
480 /* Iterate the isarev (classes that are our children),
481 wiping out their linearization and method caches */
484 while((iter = hv_iternext(isarev))) {
485 SV* const revkey = hv_iterkeysv(iter);
486 HV* revstash = gv_stashsv(revkey, 0);
487 struct mro_meta* revmeta;
489 if(!revstash) continue;
490 revmeta = HvMROMETA(revstash);
491 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
492 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
493 revmeta->mro_linear_dfs = NULL;
494 revmeta->mro_linear_c3 = NULL;
496 revmeta->cache_gen++;
497 if(revmeta->mro_nextmethod)
498 hv_clear(revmeta->mro_nextmethod);
502 /* Now iterate our MRO (parents), and do a few things:
503 1) instantiate with the "fake" flag if they don't exist
504 2) flag them as universal if we are universal
505 3) Add everything from our isarev to their isarev
508 /* We're starting at the 2nd element, skipping ourselves here */
509 linear_mro = mro_get_linear_isa(stash);
510 svp = AvARRAY(linear_mro) + 1;
511 items = AvFILLp(linear_mro);
514 SV* const sv = *svp++;
517 HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
519 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
521 mroisarev = (HV*)HeVAL(he);
523 /* This hash only ever contains PL_sv_yes. Storing it over itself is
524 almost as cheap as calling hv_exists, so on aggregate we expect to
525 save time by not making two calls to the common HV code for the
526 case where it doesn't exist. */
528 hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
532 while((iter = hv_iternext(isarev))) {
534 char* const revkey = hv_iterkey(iter, &revkeylen);
535 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
542 =for apidoc mro_method_changed_in
544 Invalidates method caching on any child classes
545 of the given stash, so that they might notice
546 the changes in this one.
548 Ideally, all instances of C<PL_sub_generation++> in
549 perl source outside of C<mro.c> should be
550 replaced by calls to this.
552 Perl automatically handles most of the common
553 ways a method might be redefined. However, there
554 are a few ways you could change a method in a stash
555 without the cache code noticing, in which case you
556 need to call this method afterwards:
558 1) Directly manipulating the stash HV entries from
561 2) Assigning a reference to a readonly scalar
562 constant into a stash entry in order to create
563 a constant subroutine (like constant.pm
566 This same method is available from pure perl
567 via, C<mro::method_changed_in(classname)>.
572 Perl_mro_method_changed_in(pTHX_ HV *stash)
574 const char * const stashname = HvNAME_get(stash);
575 const STRLEN stashname_len = HvNAMELEN_get(stash);
577 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
578 HV * const isarev = svp ? (HV*)*svp : NULL;
580 /* Inc the package generation, since a local method changed */
581 HvMROMETA(stash)->pkg_gen++;
583 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
584 invalidate all method caches globally */
585 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
586 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
591 /* else, invalidate the method caches of all child classes,
597 while((iter = hv_iternext(isarev))) {
598 SV* const revkey = hv_iterkeysv(iter);
599 HV* const revstash = gv_stashsv(revkey, 0);
600 struct mro_meta* mrometa;
602 if(!revstash) continue;
603 mrometa = HvMROMETA(revstash);
604 mrometa->cache_gen++;
605 if(mrometa->mro_nextmethod)
606 hv_clear(mrometa->mro_nextmethod);
611 /* These two are static helpers for next::method and friends,
612 and re-implement a bunch of the code from pp_caller() in
613 a more efficient manner for this particular usage.
617 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
619 for (i = startingblock; i >= 0; i--) {
620 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
626 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
629 register const PERL_CONTEXT *ccstack = cxstack;
630 const PERL_SI *top_si = PL_curstackinfo;
633 const char *fq_subname;
635 STRLEN stashname_len;
643 struct mro_meta* selfmeta;
646 if(sv_isobject(self))
647 selfstash = SvSTASH(SvRV(self));
649 selfstash = gv_stashsv(self, 0);
653 hvname = HvNAME_get(selfstash);
655 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
657 cxix = __dopoptosub_at(cxstack, cxstack_ix);
659 /* This block finds the contextually-enclosing fully-qualified subname,
660 much like looking at (caller($i))[3] until you find a real sub that
664 STRLEN fq_subname_len;
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();
727 else { /* Use the cached coderef if it exists */
728 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
730 SV* const val = HeVAL(cache_entry);
731 if(val == &PL_sv_undef) {
733 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 SV * const 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 SV * const linear_sv = *linear_svp++;
769 curstash = gv_stashsv(linear_sv, FALSE);
772 if (ckWARN(WARN_SYNTAX))
773 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
774 (void*)linear_sv, hvname);
780 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
786 if (SvTYPE(candidate) != SVt_PVGV)
787 gv_init(candidate, curstash, subname, subname_len, TRUE);
789 /* Notably, we only look for real entries, not method cache
790 entries, because in C3 the method cache of a parent is not
791 valid for the child */
792 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
793 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
794 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
800 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
802 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
808 XS(XS_mro_get_linear_isa);
811 XS(XS_mro_get_isarev);
812 XS(XS_mro_is_universal);
813 XS(XS_mro_invalidate_method_caches);
814 XS(XS_mro_method_changed_in);
815 XS(XS_mro_get_pkg_gen);
818 XS(XS_maybe_next_method);
821 Perl_boot_core_mro(pTHX)
824 static const char file[] = __FILE__;
826 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
827 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
828 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
829 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
830 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
831 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
832 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
833 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
834 newXS("next::can", XS_next_can, file);
835 newXS("next::method", XS_next_method, file);
836 newXS("maybe::next::method", XS_maybe_next_method, file);
839 XS(XS_mro_get_linear_isa) {
848 if(items < 1 || items > 2)
849 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
852 class_stash = gv_stashsv(classname, 0);
855 /* No stash exists yet, give them just the classname */
856 AV* isalin = newAV();
857 av_push(isalin, newSVsv(classname));
858 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
862 const char* const which = SvPV_nolen(ST(1));
863 if(strEQ(which, "dfs"))
864 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
865 else if(strEQ(which, "c3"))
866 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
868 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
871 RETVAL = mro_get_linear_isa(class_stash);
874 ST(0) = newRV_inc((SV*)RETVAL);
887 struct mro_meta* meta;
892 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
895 whichstr = SvPV_nolen(ST(1));
896 class_stash = gv_stashsv(classname, GV_ADD);
897 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
898 meta = HvMROMETA(class_stash);
900 if(strEQ(whichstr, "dfs"))
902 else if(strEQ(whichstr, "c3"))
905 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
907 if(meta->mro_which != which) {
908 meta->mro_which = which;
909 /* Only affects local method cache, not
910 even child classes */
912 if(meta->mro_nextmethod)
913 hv_clear(meta->mro_nextmethod);
930 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
933 class_stash = gv_stashsv(classname, 0);
935 if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
936 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
938 ST(0) = sv_2mortal(newSVpvn("c3", 2));
943 XS(XS_mro_get_isarev)
951 STRLEN classname_len;
957 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
964 classname_pv = SvPV_nolen(classname);
965 classname_len = strlen(classname_pv);
966 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
967 isarev = svp ? (HV*)*svp : NULL;
973 while((iter = hv_iternext(isarev)))
974 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
976 XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
982 XS(XS_mro_is_universal)
989 STRLEN classname_len;
995 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
999 classname_pv = SvPV_nolen(classname);
1000 classname_len = strlen(classname_pv);
1002 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
1003 isarev = svp ? (HV*)*svp : NULL;
1005 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
1006 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
1012 XS(XS_mro_invalidate_method_caches)
1017 PERL_UNUSED_ARG(cv);
1020 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1022 PL_sub_generation++;
1027 XS(XS_mro_method_changed_in)
1034 PERL_UNUSED_ARG(cv);
1037 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1041 class_stash = gv_stashsv(classname, 0);
1042 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1044 mro_method_changed_in(class_stash);
1049 XS(XS_mro_get_pkg_gen)
1056 PERL_UNUSED_ARG(cv);
1059 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
1063 class_stash = gv_stashsv(classname, 0);
1067 XPUSHs(sv_2mortal(newSViv(
1068 class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
1079 SV* const self = ST(0);
1080 SV* const methcv = __nextcan(aTHX_ self, 0);
1082 PERL_UNUSED_ARG(cv);
1083 PERL_UNUSED_VAR(items);
1085 if(methcv == &PL_sv_undef) {
1086 ST(0) = &PL_sv_undef;
1089 ST(0) = sv_2mortal(newRV_inc(methcv));
1099 SV* const self = ST(0);
1100 SV* const methcv = __nextcan(aTHX_ self, 1);
1102 PERL_UNUSED_ARG(cv);
1105 call_sv(methcv, GIMME_V);
1108 XS(XS_maybe_next_method)
1112 SV* const self = ST(0);
1113 SV* const methcv = __nextcan(aTHX_ self, 0);
1115 PERL_UNUSED_ARG(cv);
1117 if(methcv == &PL_sv_undef) {
1118 ST(0) = &PL_sv_undef;
1123 call_sv(methcv, GIMME_V);
1128 * c-indentation-style: bsd
1130 * indent-tabs-mode: t
1133 * ex: set ts=8 sts=4 sw=4 noet: