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
29 AV *(*resolve)(pTHX_ HV* stash, I32 level);
32 /* First one is the default */
33 static struct mro_alg mros[] = {
34 {"dfs", S_mro_get_linear_isa_dfs},
35 {"c3", S_mro_get_linear_isa_c3}
38 #define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
40 static const struct mro_alg *
41 S_get_mro_from_name(pTHX_ const char *const name) {
42 const struct mro_alg *algo = mros;
43 const struct mro_alg *const end = mros + NUMBER_OF_MROS;
45 if(strEQ(name, algo->name))
53 Perl_mro_meta_init(pTHX_ HV* stash)
55 struct mro_meta* newmeta;
57 PERL_ARGS_ASSERT_MRO_META_INIT;
59 assert(!(HvAUX(stash)->xhv_mro_meta));
60 Newxz(newmeta, 1, struct mro_meta);
61 HvAUX(stash)->xhv_mro_meta = newmeta;
62 newmeta->cache_gen = 1;
64 newmeta->mro_which = mros;
69 #if defined(USE_ITHREADS)
71 /* for sv_dup on new threads */
73 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
75 struct mro_meta* newmeta;
77 PERL_ARGS_ASSERT_MRO_META_DUP;
79 Newx(newmeta, 1, struct mro_meta);
80 Copy(smeta, newmeta, 1, struct mro_meta);
82 if (newmeta->mro_linear_dfs)
83 newmeta->mro_linear_dfs
84 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
85 if (newmeta->mro_linear_c3)
86 newmeta->mro_linear_c3
87 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
88 if (newmeta->mro_nextmethod)
89 newmeta->mro_nextmethod
90 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
93 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->isa, param));
98 #endif /* USE_ITHREADS */
101 Perl_get_isa_hash(pTHX_ HV *const stash)
104 struct mro_meta *const meta = HvMROMETA(stash);
106 PERL_ARGS_ASSERT_GET_ISA_HASH;
109 AV *const isa = mro_get_linear_isa(stash);
111 HV *const isa_hash = newHV();
112 /* Linearisation didn't build it for us, so do it here. */
113 SV *const *svp = AvARRAY(isa);
114 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
115 const HEK *const canon_name = HvNAME_HEK(stash);
117 while (svp < svp_end) {
118 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
121 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
122 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
123 HV_FETCH_ISSTORE, &PL_sv_undef,
124 HEK_HASH(canon_name));
125 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
127 SvREADONLY_on(isa_hash);
129 meta->isa = isa_hash;
136 =for apidoc mro_get_linear_isa_dfs
138 Returns the Depth-First Search linearization of @ISA
139 the given stash. The return value is a read-only AV*.
140 C<level> should be 0 (it is used internally in this
141 function's recursion).
143 You are responsible for C<SvREFCNT_inc()> on the
144 return value if you plan to store it anywhere
145 semi-permanently (otherwise it might be deleted
146 out from under you the next time the cache is
152 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
159 struct mro_meta* meta;
163 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
164 assert(HvAUX(stash));
166 stashhek = HvNAME_HEK(stash);
168 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
171 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
174 meta = HvMROMETA(stash);
176 /* return cache if valid */
177 if((retval = meta->mro_linear_dfs)) {
181 /* not in cache, make a new one */
183 retval = (AV*)sv_2mortal((SV *)newAV());
184 /* We use this later in this function, but don't need a reference to it
185 beyond the end of this function, so reference count is fine. */
186 our_name = newSVhek(stashhek);
187 av_push(retval, our_name); /* add ourselves at the top */
190 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
191 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
193 /* "stored" is used to keep track of all of the classnames we have added to
194 the MRO so far, so we can do a quick exists check and avoid adding
195 duplicate classnames to the MRO as we go.
196 It's then retained to be re-used as a fast lookup for ->isa(), by adding
197 our own name and "UNIVERSAL" to it. */
199 stored = (HV*)sv_2mortal((SV*)newHV());
201 if(av && AvFILLp(av) >= 0) {
203 SV **svp = AvARRAY(av);
204 I32 items = AvFILLp(av) + 1;
208 SV* const sv = *svp++;
209 HV* const basestash = gv_stashsv(sv, 0);
214 /* if no stash exists for this @ISA member,
215 simply add it to the MRO and move on */
220 /* otherwise, recurse into ourselves for the MRO
221 of this @ISA member, and append their MRO to ours.
222 The recursive call could throw an exception, which
223 has memory management implications here, hence the use of
225 const AV *const subrv
226 = mro_get_linear_isa_dfs(basestash, level + 1);
228 subrv_p = AvARRAY(subrv);
229 subrv_items = AvFILLp(subrv) + 1;
231 while(subrv_items--) {
232 SV *const subsv = *subrv_p++;
233 /* LVALUE fetch will create a new undefined SV if necessary
235 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
237 if(HeVAL(he) != &PL_sv_undef) {
238 /* It was newly created. Steal it for our new SV, and
239 replace it in the hash with the "real" thing. */
240 SV *const val = HeVAL(he);
241 HEK *const key = HeKEY_hek(he);
243 HeVAL(he) = &PL_sv_undef;
244 /* Save copying by making a shared hash key scalar. We
245 inline this here rather than calling Perl_newSVpvn_share
246 because we already have the scalar, and we already have
248 assert(SvTYPE(val) == SVt_NULL);
249 sv_upgrade(val, SVt_PV);
250 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
251 SvCUR_set(val, HEK_LEN(key));
258 av_push(retval, val);
264 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
265 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
267 SvREFCNT_inc_simple_void_NN(stored);
269 SvREADONLY_on(stored);
273 /* now that we're past the exception dangers, grab our own reference to
274 the AV we're about to use for the result. The reference owned by the
275 mortals' stack will be released soon, so everything will balance. */
276 SvREFCNT_inc_simple_void_NN(retval);
279 /* we don't want anyone modifying the cache entry but us,
280 and we do so by replacing it completely */
281 SvREADONLY_on(retval);
283 meta->mro_linear_dfs = retval;
288 =for apidoc mro_get_linear_isa_c3
290 Returns the C3 linearization of @ISA
291 the given stash. The return value is a read-only AV*.
292 C<level> should be 0 (it is used internally in this
293 function's recursion).
295 You are responsible for C<SvREFCNT_inc()> on the
296 return value if you plan to store it anywhere
297 semi-permanently (otherwise it might be deleted
298 out from under you the next time the cache is
305 S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
312 struct mro_meta* meta;
314 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
315 assert(HvAUX(stash));
317 stashhek = HvNAME_HEK(stash);
319 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
322 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
325 meta = HvMROMETA(stash);
327 /* return cache if valid */
328 if((retval = meta->mro_linear_c3)) {
332 /* not in cache, make a new one */
334 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
335 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
337 /* For a better idea how the rest of this works, see the much clearer
338 pure perl version in Algorithm::C3 0.01:
339 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
340 (later versions go about it differently than this code for speed reasons)
343 if(isa && AvFILLp(isa) >= 0) {
346 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
347 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
350 /* This builds @seqs, which is an array of arrays.
351 The members of @seqs are the MROs of
352 the members of @ISA, followed by @ISA itself.
354 I32 items = AvFILLp(isa) + 1;
355 SV** isa_ptr = AvARRAY(isa);
357 SV* const isa_item = *isa_ptr++;
358 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
359 if(!isa_item_stash) {
360 /* if no stash, make a temporary fake MRO
361 containing just itself */
362 AV* const isa_lin = newAV();
363 av_push(isa_lin, newSVsv(isa_item));
364 av_push(seqs, (SV*)isa_lin);
368 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
369 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
372 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
374 /* This builds "heads", which as an array of integer array
375 indices, one per seq, which point at the virtual "head"
376 of the seq (initially zero) */
377 Newxz(heads, AvFILLp(seqs)+1, I32);
379 /* This builds %tails, which has one key for every class
380 mentioned in the tail of any sequence in @seqs (tail meaning
381 everything after the first class, the "head"). The value
382 is how many times this key appears in the tails of @seqs.
384 seqs_ptr = AvARRAY(seqs);
385 seqs_items = AvFILLp(seqs) + 1;
386 while(seqs_items--) {
387 AV* const seq = (AV*)*seqs_ptr++;
388 I32 seq_items = AvFILLp(seq);
390 SV** seq_ptr = AvARRAY(seq) + 1;
392 SV* const seqitem = *seq_ptr++;
393 /* LVALUE fetch will create a new undefined SV if necessary
395 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
397 SV* const val = HeVAL(he);
398 /* This will increment undef to 1, which is what we
399 want for a newly created entry. */
406 /* Initialize retval to build the return value in */
408 av_push(retval, newSVhek(stashhek)); /* us first */
410 /* This loop won't terminate until we either finish building
411 the MRO, or get an exception. */
417 /* "foreach $seq (@seqs)" */
418 SV** const avptr = AvARRAY(seqs);
419 for(s = 0; s <= AvFILLp(seqs); s++) {
421 AV * const seq = (AV*)(avptr[s]);
423 if(!seq) continue; /* skip empty seqs */
424 svp = av_fetch(seq, heads[s], 0);
425 seqhead = *svp; /* seqhead = head of this seq */
429 /* if we haven't found a winner for this round yet,
430 and this seqhead is not in tails (or the count
431 for it in tails has dropped to zero), then this
432 seqhead is our new winner, and is added to the
433 final MRO immediately */
435 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
436 && (val = HeVAL(tail_entry))
439 winner = newSVsv(cand);
440 av_push(retval, winner);
441 /* note however that even when we find a winner,
442 we continue looping over @seqs to do housekeeping */
444 if(!sv_cmp(seqhead, winner)) {
445 /* Once we have a winner (including the iteration
446 where we first found him), inc the head ptr
447 for any seq which had the winner as a head,
448 NULL out any seq which is now empty,
449 and adjust tails for consistency */
451 const int new_head = ++heads[s];
452 if(new_head > AvFILLp(seq)) {
453 SvREFCNT_dec(avptr[s]);
459 /* Because we know this new seqhead used to be
460 a tail, we can assume it is in tails and has
461 a positive value, which we need to dec */
462 svp = av_fetch(seq, new_head, 0);
464 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
465 val = HeVAL(tail_entry);
471 /* if we found no candidates, we are done building the MRO.
472 !cand means no seqs have any entries left to check */
478 /* If we had candidates, but nobody won, then the @ISA
479 hierarchy is not C3-incompatible */
481 /* we have to do some cleanup before we croak */
483 SvREFCNT_dec(retval);
486 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
487 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
491 else { /* @ISA was undefined or empty */
492 /* build a retval containing only ourselves */
494 av_push(retval, newSVhek(stashhek));
497 /* we don't want anyone modifying the cache entry but us,
498 and we do so by replacing it completely */
499 SvREADONLY_on(retval);
501 meta->mro_linear_c3 = retval;
506 =for apidoc mro_get_linear_isa
508 Returns either C<mro_get_linear_isa_c3> or
509 C<mro_get_linear_isa_dfs> for the given stash,
510 dependant upon which MRO is in effect
511 for that stash. The return value is a
514 You are responsible for C<SvREFCNT_inc()> on the
515 return value if you plan to store it anywhere
516 semi-permanently (otherwise it might be deleted
517 out from under you the next time the cache is
523 Perl_mro_get_linear_isa(pTHX_ HV *stash)
525 struct mro_meta* meta;
527 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
529 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
531 meta = HvMROMETA(stash);
532 if (!meta->mro_which)
533 Perl_croak(aTHX_ "panic: invalid MRO!");
534 return meta->mro_which->resolve(aTHX_ stash, 0);
538 =for apidoc mro_isa_changed_in
540 Takes the necessary steps (cache invalidations, mostly)
541 when the @ISA of the given package has changed. Invoked
542 by the C<setisa> magic, should not need to invoke directly.
547 Perl_mro_isa_changed_in(pTHX_ HV* stash)
556 struct mro_meta * meta;
558 const char * const stashname = HvNAME_get(stash);
559 const STRLEN stashname_len = HvNAMELEN_get(stash);
561 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
564 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
566 /* wipe out the cached linearizations for this stash */
567 meta = HvMROMETA(stash);
568 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
569 SvREFCNT_dec((SV*)meta->mro_linear_c3);
570 meta->mro_linear_dfs = NULL;
571 meta->mro_linear_c3 = NULL;
573 SvREFCNT_dec(meta->isa);
577 /* Inc the package generation, since our @ISA changed */
580 /* Wipe the global method cache if this package
581 is UNIVERSAL or one of its parents */
583 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
584 isarev = svp ? (HV*)*svp : NULL;
586 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
587 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
591 else { /* Wipe the local method cache otherwise */
593 is_universal = FALSE;
596 /* wipe next::method cache too */
597 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
599 /* Iterate the isarev (classes that are our children),
600 wiping out their linearization and method caches */
603 while((iter = hv_iternext(isarev))) {
605 const char* const revkey = hv_iterkey(iter, &len);
606 HV* revstash = gv_stashpvn(revkey, len, 0);
607 struct mro_meta* revmeta;
609 if(!revstash) continue;
610 revmeta = HvMROMETA(revstash);
611 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
612 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
613 revmeta->mro_linear_dfs = NULL;
614 revmeta->mro_linear_c3 = NULL;
616 revmeta->cache_gen++;
617 if(revmeta->mro_nextmethod)
618 hv_clear(revmeta->mro_nextmethod);
622 /* Now iterate our MRO (parents), and do a few things:
623 1) instantiate with the "fake" flag if they don't exist
624 2) flag them as universal if we are universal
625 3) Add everything from our isarev to their isarev
628 /* We're starting at the 2nd element, skipping ourselves here */
629 linear_mro = mro_get_linear_isa(stash);
630 svp = AvARRAY(linear_mro) + 1;
631 items = AvFILLp(linear_mro);
634 SV* const sv = *svp++;
637 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
639 /* That fetch should not fail. But if it had to create a new SV for
640 us, then will need to upgrade it to an HV (which sv_upgrade() can
643 mroisarev = (HV*)HeVAL(he);
645 SvUPGRADE((SV*)mroisarev, SVt_PVHV);
647 /* This hash only ever contains PL_sv_yes. Storing it over itself is
648 almost as cheap as calling hv_exists, so on aggregate we expect to
649 save time by not making two calls to the common HV code for the
650 case where it doesn't exist. */
652 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
656 while((iter = hv_iternext(isarev))) {
658 char* const revkey = hv_iterkey(iter, &revkeylen);
659 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
666 =for apidoc mro_method_changed_in
668 Invalidates method caching on any child classes
669 of the given stash, so that they might notice
670 the changes in this one.
672 Ideally, all instances of C<PL_sub_generation++> in
673 perl source outside of C<mro.c> should be
674 replaced by calls to this.
676 Perl automatically handles most of the common
677 ways a method might be redefined. However, there
678 are a few ways you could change a method in a stash
679 without the cache code noticing, in which case you
680 need to call this method afterwards:
682 1) Directly manipulating the stash HV entries from
685 2) Assigning a reference to a readonly scalar
686 constant into a stash entry in order to create
687 a constant subroutine (like constant.pm
690 This same method is available from pure perl
691 via, C<mro::method_changed_in(classname)>.
696 Perl_mro_method_changed_in(pTHX_ HV *stash)
698 const char * const stashname = HvNAME_get(stash);
699 const STRLEN stashname_len = HvNAMELEN_get(stash);
701 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
702 HV * const isarev = svp ? (HV*)*svp : NULL;
704 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
707 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
709 /* Inc the package generation, since a local method changed */
710 HvMROMETA(stash)->pkg_gen++;
712 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
713 invalidate all method caches globally */
714 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
715 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
720 /* else, invalidate the method caches of all child classes,
726 while((iter = hv_iternext(isarev))) {
728 const char* const revkey = hv_iterkey(iter, &len);
729 HV* const revstash = gv_stashpvn(revkey, len, 0);
730 struct mro_meta* mrometa;
732 if(!revstash) continue;
733 mrometa = HvMROMETA(revstash);
734 mrometa->cache_gen++;
735 if(mrometa->mro_nextmethod)
736 hv_clear(mrometa->mro_nextmethod);
741 /* These two are static helpers for next::method and friends,
742 and re-implement a bunch of the code from pp_caller() in
743 a more efficient manner for this particular usage.
747 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
749 for (i = startingblock; i >= 0; i--) {
750 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
757 XS(XS_mro_get_linear_isa);
760 XS(XS_mro_get_isarev);
761 XS(XS_mro_is_universal);
762 XS(XS_mro_invalidate_method_caches);
763 XS(XS_mro_method_changed_in);
764 XS(XS_mro_get_pkg_gen);
768 Perl_boot_core_mro(pTHX)
771 static const char file[] = __FILE__;
773 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
774 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
775 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
776 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
777 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
778 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
779 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
780 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
781 newXS("mro::_nextcan", XS_mro_nextcan, file);
784 XS(XS_mro_get_linear_isa) {
791 if(items < 1 || items > 2)
792 croak_xs_usage(cv, "classname [, type ]");
795 class_stash = gv_stashsv(classname, 0);
798 /* No stash exists yet, give them just the classname */
799 AV* isalin = newAV();
800 av_push(isalin, newSVsv(classname));
801 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
805 const char* const which = SvPV_nolen(ST(1));
806 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
808 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
809 RETVAL = algo->resolve(aTHX_ class_stash, 0);
812 RETVAL = mro_get_linear_isa(class_stash);
815 ST(0) = newRV_inc((SV*)RETVAL);
825 const char* whichstr;
826 const struct mro_alg *which;
828 struct mro_meta* meta;
831 croak_xs_usage(cv, "classname, type");
834 whichstr = SvPV_nolen(ST(1));
835 class_stash = gv_stashsv(classname, GV_ADD);
836 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
837 meta = HvMROMETA(class_stash);
839 which = S_get_mro_from_name(aTHX_ whichstr);
841 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
843 if(meta->mro_which != which) {
844 meta->mro_which = which;
845 /* Only affects local method cache, not
846 even child classes */
848 if(meta->mro_nextmethod)
849 hv_clear(meta->mro_nextmethod);
864 croak_xs_usage(cv, "classname");
867 class_stash = gv_stashsv(classname, 0);
869 ST(0) = sv_2mortal(newSVpv(class_stash
870 ? HvMROMETA(class_stash)->mro_which->name
875 XS(XS_mro_get_isarev)
885 croak_xs_usage(cv, "classname");
892 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
893 isarev = he ? (HV*)HeVAL(he) : NULL;
899 while((iter = hv_iternext(isarev)))
900 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
902 mXPUSHs(newRV_noinc((SV*)ret_array));
908 XS(XS_mro_is_universal)
915 STRLEN classname_len;
919 croak_xs_usage(cv, "classname");
923 classname_pv = SvPV(classname,classname_len);
925 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
926 isarev = he ? (HV*)HeVAL(he) : NULL;
928 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
929 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
935 XS(XS_mro_invalidate_method_caches)
941 croak_xs_usage(cv, "");
948 XS(XS_mro_method_changed_in)
956 croak_xs_usage(cv, "classname");
960 class_stash = gv_stashsv(classname, 0);
961 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
963 mro_method_changed_in(class_stash);
968 XS(XS_mro_get_pkg_gen)
976 croak_xs_usage(cv, "classname");
980 class_stash = gv_stashsv(classname, 0);
984 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
995 const I32 throw_nomethod = SvIVX(ST(1));
996 register I32 cxix = cxstack_ix;
997 register const PERL_CONTEXT *ccstack = cxstack;
998 const PERL_SI *top_si = PL_curstackinfo;
1001 const char *fq_subname;
1002 const char *subname;
1003 STRLEN stashname_len;
1011 struct mro_meta* selfmeta;
1015 PERL_UNUSED_ARG(cv);
1019 if(sv_isobject(self))
1020 selfstash = SvSTASH(SvRV(self));
1022 selfstash = gv_stashsv(self, GV_ADD);
1026 hvname = HvNAME_get(selfstash);
1028 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
1030 /* This block finds the contextually-enclosing fully-qualified subname,
1031 much like looking at (caller($i))[3] until you find a real sub that
1032 isn't ANON, etc (also skips over pureperl next::method, etc) */
1033 for(i = 0; i < 2; i++) {
1034 cxix = __dopoptosub_at(ccstack, cxix);
1037 STRLEN fq_subname_len;
1039 /* we may be in a higher stacklevel, so dig down deeper */
1041 if(top_si->si_type == PERLSI_MAIN)
1042 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
1043 top_si = top_si->si_prev;
1044 ccstack = top_si->si_cxstack;
1045 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
1048 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
1049 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
1050 cxix = __dopoptosub_at(ccstack, cxix - 1);
1055 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
1056 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
1057 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1064 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1067 cxix = __dopoptosub_at(ccstack, cxix - 1);
1071 /* we found a real sub here */
1072 sv = sv_2mortal(newSV(0));
1074 gv_efullname3(sv, cvgv, NULL);
1076 fq_subname = SvPVX(sv);
1077 fq_subname_len = SvCUR(sv);
1079 subname = strrchr(fq_subname, ':');
1081 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1084 subname_len = fq_subname_len - (subname - fq_subname);
1085 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1086 cxix = __dopoptosub_at(ccstack, cxix - 1);
1094 /* If we made it to here, we found our context */
1096 /* Initialize the next::method cache for this stash
1098 selfmeta = HvMROMETA(selfstash);
1099 if(!(nmcache = selfmeta->mro_nextmethod)) {
1100 nmcache = selfmeta->mro_nextmethod = newHV();
1102 else { /* Use the cached coderef if it exists */
1103 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1105 SV* const val = HeVAL(cache_entry);
1106 if(val == &PL_sv_undef) {
1108 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1111 mXPUSHs(newRV_inc(val));
1116 /* beyond here is just for cache misses, so perf isn't as critical */
1118 stashname_len = subname - fq_subname - 2;
1119 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1121 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1123 linear_svp = AvARRAY(linear_av);
1124 entries = AvFILLp(linear_av) + 1;
1126 /* Walk down our MRO, skipping everything up
1127 to the contextually enclosing class */
1129 SV * const linear_sv = *linear_svp++;
1131 if(sv_eq(linear_sv, stashname))
1135 /* Now search the remainder of the MRO for the
1136 same method name as the contextually enclosing
1140 SV * const linear_sv = *linear_svp++;
1146 curstash = gv_stashsv(linear_sv, FALSE);
1149 if (ckWARN(WARN_SYNTAX))
1150 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1151 (void*)linear_sv, hvname);
1157 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1163 if (SvTYPE(candidate) != SVt_PVGV)
1164 gv_init(candidate, curstash, subname, subname_len, TRUE);
1166 /* Notably, we only look for real entries, not method cache
1167 entries, because in C3 the method cache of a parent is not
1168 valid for the child */
1169 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1170 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1171 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1172 mXPUSHs(newRV_inc((SV*)cand_cv));
1178 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1180 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1186 * c-indentation-style: bsd
1188 * indent-tabs-mode: t
1191 * ex: set ts=8 sts=4 sw=4 noet: