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;
41 #if defined(USE_ITHREADS)
43 /* for sv_dup on new threads */
45 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
47 struct mro_meta* newmeta;
51 Newx(newmeta, 1, struct mro_meta);
52 Copy(smeta, newmeta, 1, struct mro_meta);
54 if (newmeta->mro_linear_dfs)
55 newmeta->mro_linear_dfs
56 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
57 if (newmeta->mro_linear_c3)
58 newmeta->mro_linear_c3
59 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
60 if (newmeta->mro_nextmethod)
61 newmeta->mro_nextmethod
62 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
67 #endif /* USE_ITHREADS */
70 =for apidoc mro_get_linear_isa_dfs
72 Returns the Depth-First Search linearization of @ISA
73 the given stash. The return value is a read-only AV*.
74 C<level> should be 0 (it is used internally in this
75 function's recursion).
77 You are responsible for C<SvREFCNT_inc()> on the
78 return value if you plan to store it anywhere
79 semi-permanently (otherwise it might be deleted
80 out from under you the next time the cache is
86 Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
92 const char* stashname;
93 struct mro_meta* meta;
98 stashname = HvNAME_get(stash);
101 "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* 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);
209 "Can't linearize anonymous symbol table");
212 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
215 meta = HvMROMETA(stash);
217 /* return cache if valid */
218 if((retval = meta->mro_linear_c3)) {
222 /* not in cache, make a new one */
225 av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
227 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
228 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
230 /* For a better idea how the rest of this works, see the much clearer
231 pure perl version in Algorithm::C3 0.01:
232 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
233 (later versions go about it differently than this code for speed reasons)
236 if(isa && AvFILLp(isa) >= 0) {
239 HV* tails = (HV*)sv_2mortal((SV*)newHV());
240 AV* seqs = (AV*)sv_2mortal((SV*)newAV());
243 /* This builds @seqs, which is an array of arrays.
244 The members of @seqs are the MROs of
245 the members of @ISA, followed by @ISA itself.
247 I32 items = AvFILLp(isa) + 1;
248 SV** isa_ptr = AvARRAY(isa);
251 SV* isa_item = *isa_ptr++;
252 HV* isa_item_stash = gv_stashsv(isa_item, 0);
253 if(!isa_item_stash) {
254 /* if no stash, make a temporary fake MRO
255 containing just itself */
256 isa_lin = (AV*)sv_2mortal((SV*)newAV());
257 av_push(isa_lin, newSVsv(isa_item));
260 isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
262 av_push(seqs, (SV*)isa_lin);
264 av_push(seqs, (SV*)isa);
266 /* This builds "heads", which as an array of integer array
267 indices, one per seq, which point at the virtual "head"
268 of the seq (initially zero) */
269 Newxz(heads, AvFILLp(seqs)+1, I32);
271 /* This builds %tails, which has one key for every class
272 mentioned in the tail of any sequence in @seqs (tail meaning
273 everything after the first class, the "head"). The value
274 is how many times this key appears in the tails of @seqs.
276 seqs_ptr = AvARRAY(seqs);
277 seqs_items = AvFILLp(seqs) + 1;
278 while(seqs_items--) {
279 AV* seq = (AV*)*seqs_ptr++;
280 I32 seq_items = AvFILLp(seq);
282 SV** seq_ptr = AvARRAY(seq) + 1;
284 SV* seqitem = *seq_ptr++;
285 HE* he = hv_fetch_ent(tails, seqitem, 0, 0);
287 hv_store_ent(tails, seqitem, newSViv(1), 0);
297 /* This loop won't terminate until we either finish building
298 the MRO, or get an exception. */
308 /* "foreach $seq (@seqs)" */
309 SV** avptr = AvARRAY(seqs);
310 for(s = 0; s <= AvFILLp(seqs); s++) {
312 seq = (AV*)(avptr[s]);
313 if(!seq) continue; /* skip empty seqs */
314 svp = av_fetch(seq, heads[s], 0);
315 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 int new_head = ++heads[s];
340 if(new_head > AvFILLp(seq)) {
344 /* Because we know this new seqhead used to be
345 a tail, we can assume it is in tails and has
346 a positive value, which we need to dec */
347 svp = av_fetch(seq, new_head, 0);
349 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
350 val = HeVAL(tail_entry);
356 /* if we found no candidates, we are done building the MRO.
357 !cand means no seqs have any entries left to check */
363 /* If we had candidates, but nobody won, then the @ISA
364 hierarchy is not C3-incompatible */
366 /* we have to do some cleanup before we croak */
367 SV** svp = AvARRAY(seqs);
368 items = AvFILLp(seqs) + 1;
372 SvREFCNT_dec(retval);
375 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
376 "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
381 /* we don't want anyone modifying the cache entry but us,
382 and we do so by replacing it completely */
383 SvREADONLY_on(retval);
385 meta->mro_linear_c3 = retval;
390 =for apidoc mro_get_linear_isa
392 Returns either C<mro_get_linear_isa_c3> or
393 C<mro_get_linear_isa_dfs> for the given stash,
394 dependant upon which MRO is in effect
395 for that stash. The return value is a
398 You are responsible for C<SvREFCNT_inc()> on the
399 return value if you plan to store it anywhere
400 semi-permanently (otherwise it might be deleted
401 out from under you the next time the cache is
407 Perl_mro_get_linear_isa(pTHX_ HV *stash)
409 struct mro_meta* meta;
411 assert(HvAUX(stash));
413 meta = HvMROMETA(stash);
414 if(meta->mro_which == MRO_DFS) {
415 return mro_get_linear_isa_dfs(stash, 0);
416 } else if(meta->mro_which == MRO_C3) {
417 return mro_get_linear_isa_c3(stash, 0);
419 Perl_croak(aTHX_ "panic: invalid MRO!");
421 return NULL; /* NOT REACHED */
425 =for apidoc mro_isa_changed_in
427 Takes the necessary steps (cache invalidations, mostly)
428 when the @ISA of the given package has changed. Invoked
429 by the C<setisa> magic, should not need to invoke directly.
434 Perl_mro_isa_changed_in(pTHX_ HV* stash)
442 struct mro_meta* meta;
444 STRLEN stashname_len;
445 bool is_universal = FALSE;
447 stashname = HvNAME_get(stash);
448 stashname_len = HvNAMELEN_get(stash);
450 /* wipe out the cached linearizations for this stash */
451 meta = HvMROMETA(stash);
452 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
453 SvREFCNT_dec((SV*)meta->mro_linear_c3);
454 meta->mro_linear_dfs = NULL;
455 meta->mro_linear_c3 = NULL;
457 /* Wipe the global method cache if this package
458 is UNIVERSAL or one of its parents */
460 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
461 isarev = svp ? (HV*)*svp : NULL;
463 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
464 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
469 /* Wipe the local method cache otherwise */
473 /* wipe next::method cache too */
474 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
476 /* Iterate the isarev (classes that are our children),
477 wiping out their linearization and method caches */
480 while((iter = hv_iternext(isarev))) {
481 SV* revkey = hv_iterkeysv(iter);
482 HV* revstash = gv_stashsv(revkey, 0);
483 struct mro_meta* revmeta;
485 if(!revstash) continue;
486 revmeta = HvMROMETA(revstash);
487 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
488 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
489 revmeta->mro_linear_dfs = NULL;
490 revmeta->mro_linear_c3 = NULL;
492 revmeta->cache_gen++;
493 if(revmeta->mro_nextmethod)
494 hv_clear(revmeta->mro_nextmethod);
498 /* Now iterate our MRO (parents), and do a few things:
499 1) instantiate with the "fake" flag if they don't exist
500 2) flag them as universal if we are universal
501 3) Add everything from our isarev to their isarev
504 /* We're starting at the 2nd element, skipping ourselves here */
505 linear_mro = mro_get_linear_isa(stash);
506 svp = AvARRAY(linear_mro) + 1;
507 items = AvFILLp(linear_mro);
511 SV* const sv = *svp++;
514 he = hv_fetch_ent(PL_isarev, sv, 0, 0);
516 he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
518 mroisarev = (HV*)HeVAL(he);
520 /* This hash only ever contains PL_sv_yes. Storing it over itself is
521 almost as cheap as calling hv_exists, so on aggregate we expect to
522 save time by not making two calls to the common HV code for the
523 case where it doesn't exist. */
525 hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
529 while((iter = hv_iternext(isarev))) {
531 char* revkey = hv_iterkey(iter, &revkeylen);
532 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
539 =for apidoc mro_method_changed_in
541 Invalidates method caching on any child classes
542 of the given stash, so that they might notice
543 the changes in this one.
545 Ideally, all instances of C<PL_sub_generation++> in
546 perl source outside of C<mro.c> should be
547 replaced by calls to this.
549 Perl automatically handles most of the common
550 ways a method might be redefined. However, there
551 are a few ways you could change a method in a stash
552 without the cache code noticing, in which case you
553 need to call this method afterwards:
555 1) Directly manipulating the stash HV entries from
558 2) Assigning a reference to a readonly scalar
559 constant into a stash entry in order to create
560 a constant subroutine (like constant.pm
563 This same method is available from pure perl
564 via, C<mro::method_changed_in(classname)>.
569 Perl_mro_method_changed_in(pTHX_ HV *stash)
575 STRLEN stashname_len;
577 stashname = HvNAME_get(stash);
578 stashname_len = HvNAMELEN_get(stash);
580 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
581 isarev = svp ? (HV*)*svp : NULL;
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,
595 while((iter = hv_iternext(isarev))) {
596 SV* revkey = hv_iterkeysv(iter);
597 HV* revstash = gv_stashsv(revkey, 0);
598 struct mro_meta* mrometa;
600 if(!revstash) continue;
601 mrometa = HvMROMETA(revstash);
602 mrometa->cache_gen++;
603 if(mrometa->mro_nextmethod)
604 hv_clear(mrometa->mro_nextmethod);
609 /* These two are static helpers for next::method and friends,
610 and re-implement a bunch of the code from pp_caller() in
611 a more efficient manner for this particular usage.
615 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
617 for (i = startingblock; i >= 0; i--) {
618 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
624 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
627 register const PERL_CONTEXT *ccstack = cxstack;
628 const PERL_SI *top_si = PL_curstackinfo;
632 const char *fq_subname;
634 STRLEN fq_subname_len;
635 STRLEN stashname_len;
643 GV* candidate = NULL;
647 struct mro_meta* selfmeta;
651 if(sv_isobject(self))
652 selfstash = SvSTASH(SvRV(self));
654 selfstash = gv_stashsv(self, 0);
658 hvname = HvNAME_get(selfstash);
660 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
662 cxix = __dopoptosub_at(cxstack, cxstack_ix);
664 /* This block finds the contextually-enclosing fully-qualified subname,
665 much like looking at (caller($i))[3] until you find a real sub that
668 /* we may be in a higher stacklevel, so dig down deeper */
670 if(top_si->si_type == PERLSI_MAIN)
671 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
672 top_si = top_si->si_prev;
673 ccstack = top_si->si_cxstack;
674 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
677 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
678 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
679 cxix = __dopoptosub_at(ccstack, cxix - 1);
684 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
685 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
686 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
693 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
696 cxix = __dopoptosub_at(ccstack, cxix - 1);
700 /* we found a real sub here */
701 sv = sv_2mortal(newSV(0));
703 gv_efullname3(sv, cvgv, NULL);
705 fq_subname = SvPVX(sv);
706 fq_subname_len = SvCUR(sv);
708 subname = strrchr(fq_subname, ':');
710 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
713 subname_len = fq_subname_len - (subname - fq_subname);
714 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
715 cxix = __dopoptosub_at(ccstack, cxix - 1);
721 /* If we made it to here, we found our context */
723 /* Initialize the next::method cache for this stash
725 selfmeta = HvMROMETA(selfstash);
726 if(!(nmcache = selfmeta->mro_nextmethod)) {
727 nmcache = selfmeta->mro_nextmethod = newHV();
730 /* Use the cached coderef if it exists */
731 else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
732 SV* val = HeVAL(cache_entry);
733 if(val == &PL_sv_undef) {
735 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
740 /* beyond here is just for cache misses, so perf isn't as critical */
742 stashname_len = subname - fq_subname - 2;
743 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
745 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
747 linear_svp = AvARRAY(linear_av);
748 items = AvFILLp(linear_av) + 1;
750 /* Walk down our MRO, skipping everything up
751 to the contextually enclosing class */
753 linear_sv = *linear_svp++;
755 if(sv_eq(linear_sv, stashname))
759 /* Now search the remainder of the MRO for the
760 same method name as the contextually enclosing
764 linear_sv = *linear_svp++;
766 curstash = gv_stashsv(linear_sv, FALSE);
769 if (ckWARN(WARN_SYNTAX))
770 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
771 (void*)linear_sv, hvname);
777 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
783 if (SvTYPE(candidate) != SVt_PVGV)
784 gv_init(candidate, curstash, subname, subname_len, TRUE);
786 /* Notably, we only look for real entries, not method cache
787 entries, because in C3 the method cache of a parent is not
788 valid for the child */
789 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
790 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
791 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
797 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
799 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
805 XS(XS_mro_get_linear_isa);
808 XS(XS_mro_get_isarev);
809 XS(XS_mro_is_universal);
810 XS(XS_mro_invalidate_method_caches);
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::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
828 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
829 newXS("next::can", XS_next_can, file);
830 newXS("next::method", XS_next_method, file);
831 newXS("maybe::next::method", XS_maybe_next_method, file);
834 XS(XS_mro_get_linear_isa) {
843 if(items < 1 || items > 2)
844 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
847 class_stash = gv_stashsv(classname, 0);
848 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
851 char* which = SvPV_nolen(ST(1));
852 if(strEQ(which, "dfs"))
853 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
854 else if(strEQ(which, "c3"))
855 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
857 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
860 RETVAL = mro_get_linear_isa(class_stash);
863 ST(0) = newRV_inc((SV*)RETVAL);
876 struct mro_meta* meta;
881 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
884 whichstr = SvPV_nolen(ST(1));
885 class_stash = gv_stashsv(classname, GV_ADD);
886 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
887 meta = HvMROMETA(class_stash);
889 if(strEQ(whichstr, "dfs"))
891 else if(strEQ(whichstr, "c3"))
894 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
896 if(meta->mro_which != which) {
897 meta->mro_which = which;
898 /* Only affects local method cache, not
899 even child classes */
901 if(meta->mro_nextmethod)
902 hv_clear(meta->mro_nextmethod);
915 struct mro_meta* meta;
920 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
923 class_stash = gv_stashsv(classname, 0);
924 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
925 meta = HvMROMETA(class_stash);
927 if(meta->mro_which == MRO_DFS)
928 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
930 ST(0) = sv_2mortal(newSVpvn("c3", 2));
935 XS(XS_mro_get_isarev)
944 STRLEN stashname_len;
949 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
953 class_stash = gv_stashsv(classname, 0);
954 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
958 stashname = HvNAME_get(class_stash);
959 stashname_len = HvNAMELEN_get(class_stash);
960 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
961 isarev = svp ? (HV*)*svp : NULL;
965 while((iter = hv_iternext(isarev)))
966 XPUSHs(hv_iterkeysv(iter));
973 XS(XS_mro_is_universal)
981 STRLEN stashname_len;
987 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
990 class_stash = gv_stashsv(classname, 0);
991 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
993 stashname = HvNAME_get(class_stash);
994 stashname_len = HvNAMELEN_get(class_stash);
996 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
997 isarev = svp ? (HV*)*svp : NULL;
999 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1000 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
1006 XS(XS_mro_invalidate_method_caches)
1011 PERL_UNUSED_ARG(cv);
1014 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1016 PL_sub_generation++;
1021 XS(XS_mro_method_changed_in)
1028 PERL_UNUSED_ARG(cv);
1031 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1035 class_stash = gv_stashsv(classname, 0);
1036 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1038 mro_method_changed_in(class_stash);
1048 SV* methcv = __nextcan(aTHX_ self, 0);
1050 PERL_UNUSED_ARG(cv);
1051 PERL_UNUSED_VAR(items);
1053 if(methcv == &PL_sv_undef) {
1054 ST(0) = &PL_sv_undef;
1057 ST(0) = sv_2mortal(newRV_inc(methcv));
1068 SV* methcv = __nextcan(aTHX_ self, 1);
1070 PERL_UNUSED_ARG(cv);
1073 call_sv(methcv, GIMME_V);
1076 XS(XS_maybe_next_method)
1081 SV* methcv = __nextcan(aTHX_ self, 0);
1083 PERL_UNUSED_ARG(cv);
1085 if(methcv == &PL_sv_undef) {
1086 ST(0) = &PL_sv_undef;
1091 call_sv(methcv, GIMME_V);
1096 * c-indentation-style: bsd
1098 * indent-tabs-mode: t
1101 * ex: set ts=8 sts=4 sw=4 noet: