3 * Copyright (c) 2007 Brandon L Black
4 * Copyright (c) 2007, 2008 Larry Wall and others
6 * You may distribute under the terms of either the GNU General Public
7 * License or the Artistic License, as specified in the README file.
12 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
13 * You'll be last either way, Master Peregrin.'
15 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
21 These functions are related to the method resolution order of perl classes
31 AV *(*resolve)(pTHX_ HV* stash, U32 level);
34 U16 kflags; /* For the hash API - set HVhek_UTF8 if name is UTF-8 */
38 static const struct mro_alg dfs_alg =
39 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
41 static const struct mro_alg c3_alg =
42 {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
46 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
47 const struct mro_alg *const which)
50 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
52 data = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
53 which->name, which->length, which->kflags,
54 HV_FETCH_JUST_SV, NULL, which->hash);
58 /* If we've been asked to look up the private data for the current MRO, then
60 if (smeta->mro_which == which)
61 smeta->mro_linear_c3 = MUTABLE_AV(*data);
67 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
68 const struct mro_alg *const which, SV *const data)
70 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
72 /* If we've been asked to look up the private data for the current MRO, then
74 if (smeta->mro_which == which)
75 smeta->mro_linear_c3 = MUTABLE_AV(data);
77 if (!smeta->mro_linear_dfs) {
78 HV *const hv = newHV();
79 HvMAX(hv) = 0; /* Start with 1 bucket. It's unlikely we'll need more.
81 smeta->mro_linear_dfs = MUTABLE_AV(hv);
84 if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
85 which->name, which->length, which->kflags,
86 HV_FETCH_ISSTORE, data, which->hash)) {
87 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
88 "for '%.*s' %d", (int) which->length, which->name,
95 const struct mro_alg *
96 Perl_mro_get_from_name(pTHX_ SV *name) {
99 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
101 data = Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
102 HV_FETCH_JUST_SV, NULL, 0);
105 assert(SvTYPE(*data) == SVt_IV);
106 assert(SvIOK(*data));
107 return INT2PTR(const struct mro_alg *, SvUVX(*data));
111 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
112 SV *wrapper = newSVuv(PTR2UV(mro));
114 PERL_ARGS_ASSERT_MRO_REGISTER;
117 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
118 mro->name, mro->length, mro->kflags,
119 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
120 SvREFCNT_dec(wrapper);
121 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
122 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
127 Perl_mro_meta_init(pTHX_ HV* stash)
129 struct mro_meta* newmeta;
131 PERL_ARGS_ASSERT_MRO_META_INIT;
132 assert(HvAUX(stash));
133 assert(!(HvAUX(stash)->xhv_mro_meta));
134 Newxz(newmeta, 1, struct mro_meta);
135 HvAUX(stash)->xhv_mro_meta = newmeta;
136 newmeta->cache_gen = 1;
137 newmeta->pkg_gen = 1;
138 newmeta->mro_which = &dfs_alg;
143 #if defined(USE_ITHREADS)
145 /* for sv_dup on new threads */
147 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
149 struct mro_meta* newmeta;
151 PERL_ARGS_ASSERT_MRO_META_DUP;
153 Newx(newmeta, 1, struct mro_meta);
154 Copy(smeta, newmeta, 1, struct mro_meta);
156 if (newmeta->mro_linear_dfs)
157 newmeta->mro_linear_dfs
158 = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
159 newmeta->mro_linear_c3 = NULL;
160 if (newmeta->mro_nextmethod)
161 newmeta->mro_nextmethod
162 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
165 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
170 #endif /* USE_ITHREADS */
173 Perl_get_isa_hash(pTHX_ HV *const stash)
176 struct mro_meta *const meta = HvMROMETA(stash);
178 PERL_ARGS_ASSERT_GET_ISA_HASH;
181 AV *const isa = mro_get_linear_isa(stash);
183 HV *const isa_hash = newHV();
184 /* Linearisation didn't build it for us, so do it here. */
185 SV *const *svp = AvARRAY(isa);
186 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
187 const HEK *const canon_name = HvNAME_HEK(stash);
189 while (svp < svp_end) {
190 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
193 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
194 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
195 HV_FETCH_ISSTORE, &PL_sv_undef,
196 HEK_HASH(canon_name));
197 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
199 SvREADONLY_on(isa_hash);
201 meta->isa = isa_hash;
208 =for apidoc mro_get_linear_isa_dfs
210 Returns the Depth-First Search linearization of @ISA
211 the given stash. The return value is a read-only AV*.
212 C<level> should be 0 (it is used internally in this
213 function's recursion).
215 You are responsible for C<SvREFCNT_inc()> on the
216 return value if you plan to store it anywhere
217 semi-permanently (otherwise it might be deleted
218 out from under you the next time the cache is
224 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
231 struct mro_meta* meta;
235 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
236 assert(HvAUX(stash));
238 stashhek = HvNAME_HEK(stash);
240 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
243 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
246 meta = HvMROMETA(stash);
248 /* return cache if valid */
249 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
253 /* not in cache, make a new one */
255 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
256 /* We use this later in this function, but don't need a reference to it
257 beyond the end of this function, so reference count is fine. */
258 our_name = newSVhek(stashhek);
259 av_push(retval, our_name); /* add ourselves at the top */
262 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
263 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
265 /* "stored" is used to keep track of all of the classnames we have added to
266 the MRO so far, so we can do a quick exists check and avoid adding
267 duplicate classnames to the MRO as we go.
268 It's then retained to be re-used as a fast lookup for ->isa(), by adding
269 our own name and "UNIVERSAL" to it. */
271 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
273 if(av && AvFILLp(av) >= 0) {
275 SV **svp = AvARRAY(av);
276 I32 items = AvFILLp(av) + 1;
280 SV* const sv = *svp++;
281 HV* const basestash = gv_stashsv(sv, 0);
286 /* if no stash exists for this @ISA member,
287 simply add it to the MRO and move on */
292 /* otherwise, recurse into ourselves for the MRO
293 of this @ISA member, and append their MRO to ours.
294 The recursive call could throw an exception, which
295 has memory management implications here, hence the use of
297 const AV *const subrv
298 = mro_get_linear_isa_dfs(basestash, level + 1);
300 subrv_p = AvARRAY(subrv);
301 subrv_items = AvFILLp(subrv) + 1;
303 while(subrv_items--) {
304 SV *const subsv = *subrv_p++;
305 /* LVALUE fetch will create a new undefined SV if necessary
307 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
309 if(HeVAL(he) != &PL_sv_undef) {
310 /* It was newly created. Steal it for our new SV, and
311 replace it in the hash with the "real" thing. */
312 SV *const val = HeVAL(he);
313 HEK *const key = HeKEY_hek(he);
315 HeVAL(he) = &PL_sv_undef;
316 /* Save copying by making a shared hash key scalar. We
317 inline this here rather than calling Perl_newSVpvn_share
318 because we already have the scalar, and we already have
320 assert(SvTYPE(val) == SVt_NULL);
321 sv_upgrade(val, SVt_PV);
322 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
323 SvCUR_set(val, HEK_LEN(key));
330 av_push(retval, val);
336 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
337 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
339 SvREFCNT_inc_simple_void_NN(stored);
341 SvREADONLY_on(stored);
345 /* now that we're past the exception dangers, grab our own reference to
346 the AV we're about to use for the result. The reference owned by the
347 mortals' stack will be released soon, so everything will balance. */
348 SvREFCNT_inc_simple_void_NN(retval);
351 /* we don't want anyone modifying the cache entry but us,
352 and we do so by replacing it completely */
353 SvREADONLY_on(retval);
355 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
356 MUTABLE_SV(retval)));
360 =for apidoc mro_get_linear_isa_c3
362 Returns the C3 linearization of @ISA
363 the given stash. The return value is a read-only AV*.
364 C<level> should be 0 (it is used internally in this
365 function's recursion).
367 You are responsible for C<SvREFCNT_inc()> on the
368 return value if you plan to store it anywhere
369 semi-permanently (otherwise it might be deleted
370 out from under you the next time the cache is
377 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
384 struct mro_meta* meta;
386 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
387 assert(HvAUX(stash));
389 stashhek = HvNAME_HEK(stash);
391 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
394 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
397 meta = HvMROMETA(stash);
399 /* return cache if valid */
400 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
404 /* not in cache, make a new one */
406 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
407 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
409 /* For a better idea how the rest of this works, see the much clearer
410 pure perl version in Algorithm::C3 0.01:
411 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
412 (later versions go about it differently than this code for speed reasons)
415 if(isa && AvFILLp(isa) >= 0) {
418 HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
419 AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
422 /* This builds @seqs, which is an array of arrays.
423 The members of @seqs are the MROs of
424 the members of @ISA, followed by @ISA itself.
426 I32 items = AvFILLp(isa) + 1;
427 SV** isa_ptr = AvARRAY(isa);
429 SV* const isa_item = *isa_ptr++;
430 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
431 if(!isa_item_stash) {
432 /* if no stash, make a temporary fake MRO
433 containing just itself */
434 AV* const isa_lin = newAV();
435 av_push(isa_lin, newSVsv(isa_item));
436 av_push(seqs, MUTABLE_SV(isa_lin));
440 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
441 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
444 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
446 /* This builds "heads", which as an array of integer array
447 indices, one per seq, which point at the virtual "head"
448 of the seq (initially zero) */
449 Newxz(heads, AvFILLp(seqs)+1, I32);
451 /* This builds %tails, which has one key for every class
452 mentioned in the tail of any sequence in @seqs (tail meaning
453 everything after the first class, the "head"). The value
454 is how many times this key appears in the tails of @seqs.
456 seqs_ptr = AvARRAY(seqs);
457 seqs_items = AvFILLp(seqs) + 1;
458 while(seqs_items--) {
459 AV *const seq = MUTABLE_AV(*seqs_ptr++);
460 I32 seq_items = AvFILLp(seq);
462 SV** seq_ptr = AvARRAY(seq) + 1;
464 SV* const seqitem = *seq_ptr++;
465 /* LVALUE fetch will create a new undefined SV if necessary
467 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
469 SV* const val = HeVAL(he);
470 /* This will increment undef to 1, which is what we
471 want for a newly created entry. */
478 /* Initialize retval to build the return value in */
480 av_push(retval, newSVhek(stashhek)); /* us first */
482 /* This loop won't terminate until we either finish building
483 the MRO, or get an exception. */
489 /* "foreach $seq (@seqs)" */
490 SV** const avptr = AvARRAY(seqs);
491 for(s = 0; s <= AvFILLp(seqs); s++) {
493 AV * const seq = MUTABLE_AV(avptr[s]);
495 if(!seq) continue; /* skip empty seqs */
496 svp = av_fetch(seq, heads[s], 0);
497 seqhead = *svp; /* seqhead = head of this seq */
501 /* if we haven't found a winner for this round yet,
502 and this seqhead is not in tails (or the count
503 for it in tails has dropped to zero), then this
504 seqhead is our new winner, and is added to the
505 final MRO immediately */
507 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
508 && (val = HeVAL(tail_entry))
511 winner = newSVsv(cand);
512 av_push(retval, winner);
513 /* note however that even when we find a winner,
514 we continue looping over @seqs to do housekeeping */
516 if(!sv_cmp(seqhead, winner)) {
517 /* Once we have a winner (including the iteration
518 where we first found him), inc the head ptr
519 for any seq which had the winner as a head,
520 NULL out any seq which is now empty,
521 and adjust tails for consistency */
523 const int new_head = ++heads[s];
524 if(new_head > AvFILLp(seq)) {
525 SvREFCNT_dec(avptr[s]);
531 /* Because we know this new seqhead used to be
532 a tail, we can assume it is in tails and has
533 a positive value, which we need to dec */
534 svp = av_fetch(seq, new_head, 0);
536 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
537 val = HeVAL(tail_entry);
543 /* if we found no candidates, we are done building the MRO.
544 !cand means no seqs have any entries left to check */
550 /* If we had candidates, but nobody won, then the @ISA
551 hierarchy is not C3-incompatible */
553 /* we have to do some cleanup before we croak */
555 SvREFCNT_dec(retval);
558 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
559 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
563 else { /* @ISA was undefined or empty */
564 /* build a retval containing only ourselves */
566 av_push(retval, newSVhek(stashhek));
569 /* we don't want anyone modifying the cache entry but us,
570 and we do so by replacing it completely */
571 SvREADONLY_on(retval);
573 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
574 MUTABLE_SV(retval)));
579 =for apidoc mro_get_linear_isa
581 Returns either C<mro_get_linear_isa_c3> or
582 C<mro_get_linear_isa_dfs> for the given stash,
583 dependant upon which MRO is in effect
584 for that stash. The return value is a
587 You are responsible for C<SvREFCNT_inc()> on the
588 return value if you plan to store it anywhere
589 semi-permanently (otherwise it might be deleted
590 out from under you the next time the cache is
596 Perl_mro_get_linear_isa(pTHX_ HV *stash)
598 struct mro_meta* meta;
600 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
602 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
604 meta = HvMROMETA(stash);
605 if (!meta->mro_which)
606 Perl_croak(aTHX_ "panic: invalid MRO!");
607 return meta->mro_which->resolve(aTHX_ stash, 0);
611 =for apidoc mro_isa_changed_in
613 Takes the necessary steps (cache invalidations, mostly)
614 when the @ISA of the given package has changed. Invoked
615 by the C<setisa> magic, should not need to invoke directly.
620 Perl_mro_isa_changed_in(pTHX_ HV* stash)
629 struct mro_meta * meta;
631 const char * const stashname = HvNAME_get(stash);
632 const STRLEN stashname_len = HvNAMELEN_get(stash);
634 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
637 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
639 /* wipe out the cached linearizations for this stash */
640 meta = HvMROMETA(stash);
641 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
642 meta->mro_linear_dfs = NULL;
643 meta->mro_linear_c3 = NULL;
645 SvREFCNT_dec(meta->isa);
649 /* Inc the package generation, since our @ISA changed */
652 /* Wipe the global method cache if this package
653 is UNIVERSAL or one of its parents */
655 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
656 isarev = svp ? MUTABLE_HV(*svp) : NULL;
658 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
659 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
663 else { /* Wipe the local method cache otherwise */
665 is_universal = FALSE;
668 /* wipe next::method cache too */
669 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
671 /* Iterate the isarev (classes that are our children),
672 wiping out their linearization and method caches */
675 while((iter = hv_iternext(isarev))) {
677 const char* const revkey = hv_iterkey(iter, &len);
678 HV* revstash = gv_stashpvn(revkey, len, 0);
679 struct mro_meta* revmeta;
681 if(!revstash) continue;
682 revmeta = HvMROMETA(revstash);
683 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
684 revmeta->mro_linear_dfs = NULL;
685 revmeta->mro_linear_c3 = NULL;
687 revmeta->cache_gen++;
688 if(revmeta->mro_nextmethod)
689 hv_clear(revmeta->mro_nextmethod);
693 /* Now iterate our MRO (parents), and do a few things:
694 1) instantiate with the "fake" flag if they don't exist
695 2) flag them as universal if we are universal
696 3) Add everything from our isarev to their isarev
699 /* We're starting at the 2nd element, skipping ourselves here */
700 linear_mro = mro_get_linear_isa(stash);
701 svp = AvARRAY(linear_mro) + 1;
702 items = AvFILLp(linear_mro);
705 SV* const sv = *svp++;
708 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
710 /* That fetch should not fail. But if it had to create a new SV for
711 us, then will need to upgrade it to an HV (which sv_upgrade() can
714 mroisarev = MUTABLE_HV(HeVAL(he));
716 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
718 /* This hash only ever contains PL_sv_yes. Storing it over itself is
719 almost as cheap as calling hv_exists, so on aggregate we expect to
720 save time by not making two calls to the common HV code for the
721 case where it doesn't exist. */
723 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
727 while((iter = hv_iternext(isarev))) {
729 char* const revkey = hv_iterkey(iter, &revkeylen);
730 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
737 =for apidoc mro_method_changed_in
739 Invalidates method caching on any child classes
740 of the given stash, so that they might notice
741 the changes in this one.
743 Ideally, all instances of C<PL_sub_generation++> in
744 perl source outside of C<mro.c> should be
745 replaced by calls to this.
747 Perl automatically handles most of the common
748 ways a method might be redefined. However, there
749 are a few ways you could change a method in a stash
750 without the cache code noticing, in which case you
751 need to call this method afterwards:
753 1) Directly manipulating the stash HV entries from
756 2) Assigning a reference to a readonly scalar
757 constant into a stash entry in order to create
758 a constant subroutine (like constant.pm
761 This same method is available from pure perl
762 via, C<mro::method_changed_in(classname)>.
767 Perl_mro_method_changed_in(pTHX_ HV *stash)
769 const char * const stashname = HvNAME_get(stash);
770 const STRLEN stashname_len = HvNAMELEN_get(stash);
772 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
773 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
775 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
778 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
780 /* Inc the package generation, since a local method changed */
781 HvMROMETA(stash)->pkg_gen++;
783 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
784 invalidate all method caches globally */
785 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
786 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
791 /* else, invalidate the method caches of all child classes,
797 while((iter = hv_iternext(isarev))) {
799 const char* const revkey = hv_iterkey(iter, &len);
800 HV* const revstash = gv_stashpvn(revkey, len, 0);
801 struct mro_meta* mrometa;
803 if(!revstash) continue;
804 mrometa = HvMROMETA(revstash);
805 mrometa->cache_gen++;
806 if(mrometa->mro_nextmethod)
807 hv_clear(mrometa->mro_nextmethod);
812 /* These two are static helpers for next::method and friends,
813 and re-implement a bunch of the code from pp_caller() in
814 a more efficient manner for this particular usage.
818 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
820 for (i = startingblock; i >= 0; i--) {
821 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
828 XS(XS_mro_get_linear_isa);
831 XS(XS_mro_get_isarev);
832 XS(XS_mro_is_universal);
833 XS(XS_mro_invalidate_method_caches);
834 XS(XS_mro_method_changed_in);
835 XS(XS_mro_get_pkg_gen);
839 Perl_boot_core_mro(pTHX)
842 static const char file[] = __FILE__;
844 Perl_mro_register(aTHX_ &dfs_alg);
845 Perl_mro_register(aTHX_ &c3_alg);
847 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
848 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
849 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
850 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
851 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
852 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
853 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
854 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
855 newXS("mro::_nextcan", XS_mro_nextcan, file);
858 XS(XS_mro_get_linear_isa) {
865 if(items < 1 || items > 2)
866 croak_xs_usage(cv, "classname [, type ]");
869 class_stash = gv_stashsv(classname, 0);
872 /* No stash exists yet, give them just the classname */
873 AV* isalin = newAV();
874 av_push(isalin, newSVsv(classname));
875 ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
879 const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
881 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
882 RETVAL = algo->resolve(aTHX_ class_stash, 0);
885 RETVAL = mro_get_linear_isa(class_stash);
888 ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
898 const struct mro_alg *which;
900 struct mro_meta* meta;
903 croak_xs_usage(cv, "classname, type");
906 class_stash = gv_stashsv(classname, GV_ADD);
907 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
908 meta = HvMROMETA(class_stash);
910 which = Perl_mro_get_from_name(aTHX_ ST(1));
912 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
914 if(meta->mro_which != which) {
915 meta->mro_which = which;
916 /* Scrub our cached pointer to the private data. */
917 meta->mro_linear_c3 = NULL;
918 /* Only affects local method cache, not
919 even child classes */
921 if(meta->mro_nextmethod)
922 hv_clear(meta->mro_nextmethod);
937 croak_xs_usage(cv, "classname");
940 class_stash = gv_stashsv(classname, 0);
942 ST(0) = sv_2mortal(newSVpv(class_stash
943 ? HvMROMETA(class_stash)->mro_which->name
948 XS(XS_mro_get_isarev)
958 croak_xs_usage(cv, "classname");
965 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
966 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
972 while((iter = hv_iternext(isarev)))
973 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
975 mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
981 XS(XS_mro_is_universal)
988 STRLEN classname_len;
992 croak_xs_usage(cv, "classname");
996 classname_pv = SvPV(classname,classname_len);
998 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
999 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
1001 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
1002 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
1008 XS(XS_mro_invalidate_method_caches)
1014 croak_xs_usage(cv, "");
1016 PL_sub_generation++;
1021 XS(XS_mro_method_changed_in)
1029 croak_xs_usage(cv, "classname");
1033 class_stash = gv_stashsv(classname, 0);
1034 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1036 mro_method_changed_in(class_stash);
1041 XS(XS_mro_get_pkg_gen)
1049 croak_xs_usage(cv, "classname");
1053 class_stash = gv_stashsv(classname, 0);
1057 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
1068 const I32 throw_nomethod = SvIVX(ST(1));
1069 register I32 cxix = cxstack_ix;
1070 register const PERL_CONTEXT *ccstack = cxstack;
1071 const PERL_SI *top_si = PL_curstackinfo;
1074 const char *fq_subname;
1075 const char *subname;
1076 STRLEN stashname_len;
1084 struct mro_meta* selfmeta;
1088 PERL_UNUSED_ARG(cv);
1092 if(sv_isobject(self))
1093 selfstash = SvSTASH(SvRV(self));
1095 selfstash = gv_stashsv(self, GV_ADD);
1099 hvname = HvNAME_get(selfstash);
1101 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
1103 /* This block finds the contextually-enclosing fully-qualified subname,
1104 much like looking at (caller($i))[3] until you find a real sub that
1105 isn't ANON, etc (also skips over pureperl next::method, etc) */
1106 for(i = 0; i < 2; i++) {
1107 cxix = __dopoptosub_at(ccstack, cxix);
1110 STRLEN fq_subname_len;
1112 /* we may be in a higher stacklevel, so dig down deeper */
1114 if(top_si->si_type == PERLSI_MAIN)
1115 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
1116 top_si = top_si->si_prev;
1117 ccstack = top_si->si_cxstack;
1118 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
1121 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
1122 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
1123 cxix = __dopoptosub_at(ccstack, cxix - 1);
1128 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
1129 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
1130 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1137 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1140 cxix = __dopoptosub_at(ccstack, cxix - 1);
1144 /* we found a real sub here */
1145 sv = sv_2mortal(newSV(0));
1147 gv_efullname3(sv, cvgv, NULL);
1149 fq_subname = SvPVX(sv);
1150 fq_subname_len = SvCUR(sv);
1152 subname = strrchr(fq_subname, ':');
1154 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1157 subname_len = fq_subname_len - (subname - fq_subname);
1158 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1159 cxix = __dopoptosub_at(ccstack, cxix - 1);
1167 /* If we made it to here, we found our context */
1169 /* Initialize the next::method cache for this stash
1171 selfmeta = HvMROMETA(selfstash);
1172 if(!(nmcache = selfmeta->mro_nextmethod)) {
1173 nmcache = selfmeta->mro_nextmethod = newHV();
1175 else { /* Use the cached coderef if it exists */
1176 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1178 SV* const val = HeVAL(cache_entry);
1179 if(val == &PL_sv_undef) {
1181 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1184 mXPUSHs(newRV_inc(val));
1189 /* beyond here is just for cache misses, so perf isn't as critical */
1191 stashname_len = subname - fq_subname - 2;
1192 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
1194 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1196 linear_svp = AvARRAY(linear_av);
1197 entries = AvFILLp(linear_av) + 1;
1199 /* Walk down our MRO, skipping everything up
1200 to the contextually enclosing class */
1202 SV * const linear_sv = *linear_svp++;
1204 if(sv_eq(linear_sv, stashname))
1208 /* Now search the remainder of the MRO for the
1209 same method name as the contextually enclosing
1213 SV * const linear_sv = *linear_svp++;
1219 curstash = gv_stashsv(linear_sv, FALSE);
1222 if (ckWARN(WARN_SYNTAX))
1223 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1224 (void*)linear_sv, hvname);
1230 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1236 if (SvTYPE(candidate) != SVt_PVGV)
1237 gv_init(candidate, curstash, subname, subname_len, TRUE);
1239 /* Notably, we only look for real entries, not method cache
1240 entries, because in C3 the method cache of a parent is not
1241 valid for the child */
1242 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1243 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
1244 (void)hv_store_ent(nmcache, newSVsv(sv), MUTABLE_SV(cand_cv), 0);
1245 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
1251 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1253 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1259 * c-indentation-style: bsd
1261 * indent-tabs-mode: t
1264 * ex: set ts=8 sts=4 sw=4 noet: