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;
417 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
419 meta = HvMROMETA(stash);
420 if(meta->mro_which == MRO_DFS) {
421 return mro_get_linear_isa_dfs(stash, 0);
422 } else if(meta->mro_which == MRO_C3) {
423 return mro_get_linear_isa_c3(stash, 0);
425 Perl_croak(aTHX_ "panic: invalid MRO!");
427 return NULL; /* NOT REACHED */
431 =for apidoc mro_isa_changed_in
433 Takes the necessary steps (cache invalidations, mostly)
434 when the @ISA of the given package has changed. Invoked
435 by the C<setisa> magic, should not need to invoke directly.
440 Perl_mro_isa_changed_in(pTHX_ HV* stash)
449 struct mro_meta * meta;
451 const char * const stashname = HvNAME_get(stash);
452 const STRLEN stashname_len = HvNAMELEN_get(stash);
455 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
457 /* wipe out the cached linearizations for this stash */
458 meta = HvMROMETA(stash);
459 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
460 SvREFCNT_dec((SV*)meta->mro_linear_c3);
461 meta->mro_linear_dfs = NULL;
462 meta->mro_linear_c3 = NULL;
464 /* Inc the package generation, since our @ISA changed */
467 /* Wipe the global method cache if this package
468 is UNIVERSAL or one of its parents */
470 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
471 isarev = svp ? (HV*)*svp : NULL;
473 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
474 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
478 else { /* Wipe the local method cache otherwise */
480 is_universal = FALSE;
483 /* wipe next::method cache too */
484 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
486 /* Iterate the isarev (classes that are our children),
487 wiping out their linearization and method caches */
490 while((iter = hv_iternext(isarev))) {
491 SV* const revkey = hv_iterkeysv(iter);
492 HV* revstash = gv_stashsv(revkey, 0);
493 struct mro_meta* revmeta;
495 if(!revstash) continue;
496 revmeta = HvMROMETA(revstash);
497 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
498 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
499 revmeta->mro_linear_dfs = NULL;
500 revmeta->mro_linear_c3 = NULL;
502 revmeta->cache_gen++;
503 if(revmeta->mro_nextmethod)
504 hv_clear(revmeta->mro_nextmethod);
508 /* Now iterate our MRO (parents), and do a few things:
509 1) instantiate with the "fake" flag if they don't exist
510 2) flag them as universal if we are universal
511 3) Add everything from our isarev to their isarev
514 /* We're starting at the 2nd element, skipping ourselves here */
515 linear_mro = mro_get_linear_isa(stash);
516 svp = AvARRAY(linear_mro) + 1;
517 items = AvFILLp(linear_mro);
520 SV* const sv = *svp++;
523 HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
525 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
527 mroisarev = (HV*)HeVAL(he);
529 /* This hash only ever contains PL_sv_yes. Storing it over itself is
530 almost as cheap as calling hv_exists, so on aggregate we expect to
531 save time by not making two calls to the common HV code for the
532 case where it doesn't exist. */
534 hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
538 while((iter = hv_iternext(isarev))) {
540 char* const revkey = hv_iterkey(iter, &revkeylen);
541 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
548 =for apidoc mro_method_changed_in
550 Invalidates method caching on any child classes
551 of the given stash, so that they might notice
552 the changes in this one.
554 Ideally, all instances of C<PL_sub_generation++> in
555 perl source outside of C<mro.c> should be
556 replaced by calls to this.
558 Perl automatically handles most of the common
559 ways a method might be redefined. However, there
560 are a few ways you could change a method in a stash
561 without the cache code noticing, in which case you
562 need to call this method afterwards:
564 1) Directly manipulating the stash HV entries from
567 2) Assigning a reference to a readonly scalar
568 constant into a stash entry in order to create
569 a constant subroutine (like constant.pm
572 This same method is available from pure perl
573 via, C<mro::method_changed_in(classname)>.
578 Perl_mro_method_changed_in(pTHX_ HV *stash)
580 const char * const stashname = HvNAME_get(stash);
581 const STRLEN stashname_len = HvNAMELEN_get(stash);
583 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
584 HV * const isarev = svp ? (HV*)*svp : NULL;
587 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
589 /* Inc the package generation, since a local method changed */
590 HvMROMETA(stash)->pkg_gen++;
592 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
593 invalidate all method caches globally */
594 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
595 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
600 /* else, invalidate the method caches of all child classes,
606 while((iter = hv_iternext(isarev))) {
607 SV* const revkey = hv_iterkeysv(iter);
608 HV* const revstash = gv_stashsv(revkey, 0);
609 struct mro_meta* mrometa;
611 if(!revstash) continue;
612 mrometa = HvMROMETA(revstash);
613 mrometa->cache_gen++;
614 if(mrometa->mro_nextmethod)
615 hv_clear(mrometa->mro_nextmethod);
620 /* These two are static helpers for next::method and friends,
621 and re-implement a bunch of the code from pp_caller() in
622 a more efficient manner for this particular usage.
626 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
628 for (i = startingblock; i >= 0; i--) {
629 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
635 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
638 register const PERL_CONTEXT *ccstack = cxstack;
639 const PERL_SI *top_si = PL_curstackinfo;
642 const char *fq_subname;
644 STRLEN stashname_len;
652 struct mro_meta* selfmeta;
655 if(sv_isobject(self))
656 selfstash = SvSTASH(SvRV(self));
658 selfstash = gv_stashsv(self, 0);
662 hvname = HvNAME_get(selfstash);
664 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
666 cxix = __dopoptosub_at(cxstack, cxstack_ix);
668 /* This block finds the contextually-enclosing fully-qualified subname,
669 much like looking at (caller($i))[3] until you find a real sub that
673 STRLEN fq_subname_len;
675 /* we may be in a higher stacklevel, so dig down deeper */
677 if(top_si->si_type == PERLSI_MAIN)
678 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
679 top_si = top_si->si_prev;
680 ccstack = top_si->si_cxstack;
681 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
684 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
685 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
686 cxix = __dopoptosub_at(ccstack, cxix - 1);
691 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
692 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
693 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
700 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
703 cxix = __dopoptosub_at(ccstack, cxix - 1);
707 /* we found a real sub here */
708 sv = sv_2mortal(newSV(0));
710 gv_efullname3(sv, cvgv, NULL);
712 fq_subname = SvPVX(sv);
713 fq_subname_len = SvCUR(sv);
715 subname = strrchr(fq_subname, ':');
717 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
720 subname_len = fq_subname_len - (subname - fq_subname);
721 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
722 cxix = __dopoptosub_at(ccstack, cxix - 1);
728 /* If we made it to here, we found our context */
730 /* Initialize the next::method cache for this stash
732 selfmeta = HvMROMETA(selfstash);
733 if(!(nmcache = selfmeta->mro_nextmethod)) {
734 nmcache = selfmeta->mro_nextmethod = newHV();
736 else { /* Use the cached coderef if it exists */
737 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
739 SV* const val = HeVAL(cache_entry);
740 if(val == &PL_sv_undef) {
742 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
748 /* beyond here is just for cache misses, so perf isn't as critical */
750 stashname_len = subname - fq_subname - 2;
751 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
753 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
755 linear_svp = AvARRAY(linear_av);
756 items = AvFILLp(linear_av) + 1;
758 /* Walk down our MRO, skipping everything up
759 to the contextually enclosing class */
761 SV * const linear_sv = *linear_svp++;
763 if(sv_eq(linear_sv, stashname))
767 /* Now search the remainder of the MRO for the
768 same method name as the contextually enclosing
772 SV * const linear_sv = *linear_svp++;
778 curstash = gv_stashsv(linear_sv, FALSE);
781 if (ckWARN(WARN_SYNTAX))
782 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
783 (void*)linear_sv, hvname);
789 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
795 if (SvTYPE(candidate) != SVt_PVGV)
796 gv_init(candidate, curstash, subname, subname_len, TRUE);
798 /* Notably, we only look for real entries, not method cache
799 entries, because in C3 the method cache of a parent is not
800 valid for the child */
801 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
802 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
803 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
809 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
811 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
817 XS(XS_mro_get_linear_isa);
820 XS(XS_mro_get_isarev);
821 XS(XS_mro_is_universal);
822 XS(XS_mro_invalidate_method_caches);
823 XS(XS_mro_method_changed_in);
824 XS(XS_mro_get_pkg_gen);
827 XS(XS_maybe_next_method);
830 Perl_boot_core_mro(pTHX)
833 static const char file[] = __FILE__;
835 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
836 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
837 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
838 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
839 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
840 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
841 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
842 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
843 newXS("next::can", XS_next_can, file);
844 newXS("next::method", XS_next_method, file);
845 newXS("maybe::next::method", XS_maybe_next_method, file);
848 XS(XS_mro_get_linear_isa) {
857 if(items < 1 || items > 2)
858 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
861 class_stash = gv_stashsv(classname, 0);
864 /* No stash exists yet, give them just the classname */
865 AV* isalin = newAV();
866 av_push(isalin, newSVsv(classname));
867 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
871 const char* const which = SvPV_nolen(ST(1));
872 if(strEQ(which, "dfs"))
873 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
874 else if(strEQ(which, "c3"))
875 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
877 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
880 RETVAL = mro_get_linear_isa(class_stash);
883 ST(0) = newRV_inc((SV*)RETVAL);
896 struct mro_meta* meta;
901 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
904 whichstr = SvPV_nolen(ST(1));
905 class_stash = gv_stashsv(classname, GV_ADD);
906 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
907 meta = HvMROMETA(class_stash);
909 if(strEQ(whichstr, "dfs"))
911 else if(strEQ(whichstr, "c3"))
914 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
916 if(meta->mro_which != which) {
917 meta->mro_which = which;
918 /* Only affects local method cache, not
919 even child classes */
921 if(meta->mro_nextmethod)
922 hv_clear(meta->mro_nextmethod);
939 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
942 class_stash = gv_stashsv(classname, 0);
944 if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
945 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
947 ST(0) = sv_2mortal(newSVpvn("c3", 2));
952 XS(XS_mro_get_isarev)
960 STRLEN classname_len;
966 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
973 classname_pv = SvPV_nolen(classname);
974 classname_len = strlen(classname_pv);
975 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
976 isarev = svp ? (HV*)*svp : NULL;
982 while((iter = hv_iternext(isarev)))
983 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
985 XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
991 XS(XS_mro_is_universal)
998 STRLEN classname_len;
1001 PERL_UNUSED_ARG(cv);
1004 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
1008 classname_pv = SvPV_nolen(classname);
1009 classname_len = strlen(classname_pv);
1011 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
1012 isarev = svp ? (HV*)*svp : NULL;
1014 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
1015 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
1021 XS(XS_mro_invalidate_method_caches)
1026 PERL_UNUSED_ARG(cv);
1029 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1031 PL_sub_generation++;
1036 XS(XS_mro_method_changed_in)
1043 PERL_UNUSED_ARG(cv);
1046 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1050 class_stash = gv_stashsv(classname, 0);
1051 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1053 mro_method_changed_in(class_stash);
1058 XS(XS_mro_get_pkg_gen)
1065 PERL_UNUSED_ARG(cv);
1068 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
1072 class_stash = gv_stashsv(classname, 0);
1076 XPUSHs(sv_2mortal(newSViv(
1077 class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
1088 SV* const self = ST(0);
1089 SV* const methcv = __nextcan(aTHX_ self, 0);
1091 PERL_UNUSED_ARG(cv);
1092 PERL_UNUSED_VAR(items);
1094 if(methcv == &PL_sv_undef) {
1095 ST(0) = &PL_sv_undef;
1098 ST(0) = sv_2mortal(newRV_inc(methcv));
1108 SV* const self = ST(0);
1109 SV* const methcv = __nextcan(aTHX_ self, 1);
1111 PERL_UNUSED_ARG(cv);
1114 call_sv(methcv, GIMME_V);
1117 XS(XS_maybe_next_method)
1121 SV* const self = ST(0);
1122 SV* const methcv = __nextcan(aTHX_ self, 0);
1124 PERL_UNUSED_ARG(cv);
1126 if(methcv == &PL_sv_undef) {
1127 ST(0) = &PL_sv_undef;
1132 call_sv(methcv, GIMME_V);
1137 * c-indentation-style: bsd
1139 * indent-tabs-mode: t
1142 * ex: set ts=8 sts=4 sw=4 noet: