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
30 static const struct mro_alg dfs_alg =
31 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
34 Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35 const struct mro_alg *const which)
38 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
40 data = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
41 which->name, which->length, which->kflags,
42 HV_FETCH_JUST_SV, NULL, which->hash);
46 /* If we've been asked to look up the private data for the current MRO, then
48 if (smeta->mro_which == which)
49 smeta->mro_linear_current = *data;
55 Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56 const struct mro_alg *const which, SV *const data)
58 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
60 if (!smeta->mro_linear_dfs) {
61 if (smeta->mro_which == which) {
62 /* If all we need to store is the current MRO's data, then don't use
63 memory on a hash with 1 element - store it direct, and signal
64 this by leaving the would-be-hash NULL. */
65 smeta->mro_linear_current = data;
68 HV *const hv = newHV();
69 /* Start with 2 buckets. It's unlikely we'll need more. */
71 smeta->mro_linear_dfs = MUTABLE_AV(hv);
73 if (smeta->mro_linear_current) {
74 /* If we were storing something directly, put it in the hash
76 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
77 smeta->mro_linear_current);
82 /* We get here if we're storing more than one linearisation for this stash,
83 or the linearisation we are storing is not that if its current MRO. */
85 if (smeta->mro_which == which) {
86 /* If we've been asked to store the private data for the current MRO,
88 smeta->mro_linear_current = data;
91 if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
92 which->name, which->length, which->kflags,
93 HV_FETCH_ISSTORE, data, which->hash)) {
94 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
95 "for '%.*s' %d", (int) which->length, which->name,
102 const struct mro_alg *
103 Perl_mro_get_from_name(pTHX_ SV *name) {
106 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
108 data = Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109 HV_FETCH_JUST_SV, NULL, 0);
112 assert(SvTYPE(*data) == SVt_IV);
113 assert(SvIOK(*data));
114 return INT2PTR(const struct mro_alg *, SvUVX(*data));
118 Perl_mro_register(pTHX_ const struct mro_alg *mro) {
119 SV *wrapper = newSVuv(PTR2UV(mro));
121 PERL_ARGS_ASSERT_MRO_REGISTER;
124 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
125 mro->name, mro->length, mro->kflags,
126 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
127 SvREFCNT_dec(wrapper);
128 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
129 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
134 Perl_mro_meta_init(pTHX_ HV* stash)
136 struct mro_meta* newmeta;
138 PERL_ARGS_ASSERT_MRO_META_INIT;
139 assert(HvAUX(stash));
140 assert(!(HvAUX(stash)->xhv_mro_meta));
141 Newxz(newmeta, 1, struct mro_meta);
142 HvAUX(stash)->xhv_mro_meta = newmeta;
143 newmeta->cache_gen = 1;
144 newmeta->pkg_gen = 1;
145 newmeta->mro_which = &dfs_alg;
150 #if defined(USE_ITHREADS)
152 /* for sv_dup on new threads */
154 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
156 struct mro_meta* newmeta;
158 PERL_ARGS_ASSERT_MRO_META_DUP;
160 Newx(newmeta, 1, struct mro_meta);
161 Copy(smeta, newmeta, 1, struct mro_meta);
163 if (newmeta->mro_linear_dfs) {
164 newmeta->mro_linear_dfs
165 = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
166 /* This is just acting as a shortcut pointer, and will be automatically
167 updated on the first get. */
168 newmeta->mro_linear_current = NULL;
169 } else if (newmeta->mro_linear_current) {
170 /* Only the current MRO is stored, so this owns the data. */
171 newmeta->mro_linear_current
172 = SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_current,
176 if (newmeta->mro_nextmethod)
177 newmeta->mro_nextmethod
178 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
181 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
186 #endif /* USE_ITHREADS */
189 Perl_get_isa_hash(pTHX_ HV *const stash)
192 struct mro_meta *const meta = HvMROMETA(stash);
194 PERL_ARGS_ASSERT_GET_ISA_HASH;
197 AV *const isa = mro_get_linear_isa(stash);
199 HV *const isa_hash = newHV();
200 /* Linearisation didn't build it for us, so do it here. */
201 SV *const *svp = AvARRAY(isa);
202 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
203 const HEK *const canon_name = HvNAME_HEK(stash);
205 while (svp < svp_end) {
206 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
209 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
210 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
211 HV_FETCH_ISSTORE, &PL_sv_undef,
212 HEK_HASH(canon_name));
213 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
215 SvREADONLY_on(isa_hash);
217 meta->isa = isa_hash;
224 =for apidoc mro_get_linear_isa_dfs
226 Returns the Depth-First Search linearization of @ISA
227 the given stash. The return value is a read-only AV*.
228 C<level> should be 0 (it is used internally in this
229 function's recursion).
231 You are responsible for C<SvREFCNT_inc()> on the
232 return value if you plan to store it anywhere
233 semi-permanently (otherwise it might be deleted
234 out from under you the next time the cache is
240 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
247 struct mro_meta* meta;
251 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
252 assert(HvAUX(stash));
254 stashhek = HvNAME_HEK(stash);
256 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
259 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
262 meta = HvMROMETA(stash);
264 /* return cache if valid */
265 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
269 /* not in cache, make a new one */
271 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
272 /* We use this later in this function, but don't need a reference to it
273 beyond the end of this function, so reference count is fine. */
274 our_name = newSVhek(stashhek);
275 av_push(retval, our_name); /* add ourselves at the top */
278 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
279 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
281 /* "stored" is used to keep track of all of the classnames we have added to
282 the MRO so far, so we can do a quick exists check and avoid adding
283 duplicate classnames to the MRO as we go.
284 It's then retained to be re-used as a fast lookup for ->isa(), by adding
285 our own name and "UNIVERSAL" to it. */
287 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
289 if(av && AvFILLp(av) >= 0) {
291 SV **svp = AvARRAY(av);
292 I32 items = AvFILLp(av) + 1;
296 SV* const sv = *svp++;
297 HV* const basestash = gv_stashsv(sv, 0);
302 /* if no stash exists for this @ISA member,
303 simply add it to the MRO and move on */
308 /* otherwise, recurse into ourselves for the MRO
309 of this @ISA member, and append their MRO to ours.
310 The recursive call could throw an exception, which
311 has memory management implications here, hence the use of
313 const AV *const subrv
314 = mro_get_linear_isa_dfs(basestash, level + 1);
316 subrv_p = AvARRAY(subrv);
317 subrv_items = AvFILLp(subrv) + 1;
319 while(subrv_items--) {
320 SV *const subsv = *subrv_p++;
321 /* LVALUE fetch will create a new undefined SV if necessary
323 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
325 if(HeVAL(he) != &PL_sv_undef) {
326 /* It was newly created. Steal it for our new SV, and
327 replace it in the hash with the "real" thing. */
328 SV *const val = HeVAL(he);
329 HEK *const key = HeKEY_hek(he);
331 HeVAL(he) = &PL_sv_undef;
332 /* Save copying by making a shared hash key scalar. We
333 inline this here rather than calling Perl_newSVpvn_share
334 because we already have the scalar, and we already have
336 assert(SvTYPE(val) == SVt_NULL);
337 sv_upgrade(val, SVt_PV);
338 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
339 SvCUR_set(val, HEK_LEN(key));
346 av_push(retval, val);
352 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
353 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
355 SvREFCNT_inc_simple_void_NN(stored);
357 SvREADONLY_on(stored);
361 /* now that we're past the exception dangers, grab our own reference to
362 the AV we're about to use for the result. The reference owned by the
363 mortals' stack will be released soon, so everything will balance. */
364 SvREFCNT_inc_simple_void_NN(retval);
367 /* we don't want anyone modifying the cache entry but us,
368 and we do so by replacing it completely */
369 SvREADONLY_on(retval);
371 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
372 MUTABLE_SV(retval)));
376 =for apidoc mro_get_linear_isa
378 Returns either C<mro_get_linear_isa_c3> or
379 C<mro_get_linear_isa_dfs> for the given stash,
380 dependant upon which MRO is in effect
381 for that stash. The return value is a
384 You are responsible for C<SvREFCNT_inc()> on the
385 return value if you plan to store it anywhere
386 semi-permanently (otherwise it might be deleted
387 out from under you the next time the cache is
393 Perl_mro_get_linear_isa(pTHX_ HV *stash)
395 struct mro_meta* meta;
397 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
399 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
401 meta = HvMROMETA(stash);
402 if (!meta->mro_which)
403 Perl_croak(aTHX_ "panic: invalid MRO!");
404 return meta->mro_which->resolve(aTHX_ stash, 0);
408 =for apidoc mro_isa_changed_in
410 Takes the necessary steps (cache invalidations, mostly)
411 when the @ISA of the given package has changed. Invoked
412 by the C<setisa> magic, should not need to invoke directly.
417 Perl_mro_isa_changed_in(pTHX_ HV* stash)
426 struct mro_meta * meta;
428 const char * const stashname = HvNAME_get(stash);
429 const STRLEN stashname_len = HvNAMELEN_get(stash);
431 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
434 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
436 /* wipe out the cached linearizations for this stash */
437 meta = HvMROMETA(stash);
438 if (meta->mro_linear_dfs) {
439 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
440 meta->mro_linear_dfs = NULL;
441 /* This is just acting as a shortcut pointer. */
442 meta->mro_linear_current = NULL;
443 } else if (meta->mro_linear_current) {
444 /* Only the current MRO is stored, so this owns the data. */
445 SvREFCNT_dec(meta->mro_linear_current);
446 meta->mro_linear_current = NULL;
449 SvREFCNT_dec(meta->isa);
453 /* Inc the package generation, since our @ISA changed */
456 /* Wipe the global method cache if this package
457 is UNIVERSAL or one of its parents */
459 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
460 isarev = svp ? MUTABLE_HV(*svp) : NULL;
462 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
463 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
467 else { /* Wipe the local method cache otherwise */
469 is_universal = FALSE;
472 /* wipe next::method cache too */
473 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
475 /* Iterate the isarev (classes that are our children),
476 wiping out their linearization and method caches */
479 while((iter = hv_iternext(isarev))) {
481 const char* const revkey = hv_iterkey(iter, &len);
482 HV* revstash = gv_stashpvn(revkey, len, 0);
483 struct mro_meta* revmeta;
485 if(!revstash) continue;
486 revmeta = HvMROMETA(revstash);
487 if (revmeta->mro_linear_dfs) {
488 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
489 revmeta->mro_linear_dfs = NULL;
490 /* This is just acting as a shortcut pointer. */
491 revmeta->mro_linear_current = NULL;
492 } else if (revmeta->mro_linear_current) {
493 /* Only the current MRO is stored, so this owns the data. */
494 SvREFCNT_dec(revmeta->mro_linear_current);
495 revmeta->mro_linear_current = NULL;
498 revmeta->cache_gen++;
499 if(revmeta->mro_nextmethod)
500 hv_clear(revmeta->mro_nextmethod);
504 /* Now iterate our MRO (parents), and do a few things:
505 1) instantiate with the "fake" flag if they don't exist
506 2) flag them as universal if we are universal
507 3) Add everything from our isarev to their isarev
510 /* We're starting at the 2nd element, skipping ourselves here */
511 linear_mro = mro_get_linear_isa(stash);
512 svp = AvARRAY(linear_mro) + 1;
513 items = AvFILLp(linear_mro);
516 SV* const sv = *svp++;
519 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
521 /* That fetch should not fail. But if it had to create a new SV for
522 us, then will need to upgrade it to an HV (which sv_upgrade() can
525 mroisarev = MUTABLE_HV(HeVAL(he));
527 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
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 (void)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 (void)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 ? MUTABLE_HV(*svp) : NULL;
586 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
589 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
591 /* Inc the package generation, since a local method changed */
592 HvMROMETA(stash)->pkg_gen++;
594 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
595 invalidate all method caches globally */
596 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
597 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
602 /* else, invalidate the method caches of all child classes,
608 while((iter = hv_iternext(isarev))) {
610 const char* const revkey = hv_iterkey(iter, &len);
611 HV* const revstash = gv_stashpvn(revkey, len, 0);
612 struct mro_meta* mrometa;
614 if(!revstash) continue;
615 mrometa = HvMROMETA(revstash);
616 mrometa->cache_gen++;
617 if(mrometa->mro_nextmethod)
618 hv_clear(mrometa->mro_nextmethod);
624 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
626 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
628 PERL_ARGS_ASSERT_MRO_SET_MRO;
631 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
633 if(meta->mro_which != which) {
634 if (meta->mro_linear_current && !meta->mro_linear_dfs) {
635 /* If we were storing something directly, put it in the hash before
637 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
638 MUTABLE_SV(meta->mro_linear_current));
640 meta->mro_which = which;
641 /* Scrub our cached pointer to the private data. */
642 meta->mro_linear_current = NULL;
643 /* Only affects local method cache, not
644 even child classes */
646 if(meta->mro_nextmethod)
647 hv_clear(meta->mro_nextmethod);
653 XS(XS_mro_get_linear_isa);
656 XS(XS_mro_get_isarev);
657 XS(XS_mro_is_universal);
658 XS(XS_mro_invalidate_method_caches);
659 XS(XS_mro_method_changed_in);
660 XS(XS_mro_get_pkg_gen);
663 Perl_boot_core_mro(pTHX)
666 static const char file[] = __FILE__;
668 Perl_mro_register(aTHX_ &dfs_alg);
670 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
671 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
672 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
673 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
674 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
675 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
676 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
677 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
680 XS(XS_mro_get_linear_isa) {
687 if(items < 1 || items > 2)
688 croak_xs_usage(cv, "classname [, type ]");
691 class_stash = gv_stashsv(classname, 0);
694 /* No stash exists yet, give them just the classname */
695 AV* isalin = newAV();
696 av_push(isalin, newSVsv(classname));
697 ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
701 const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
703 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
704 RETVAL = algo->resolve(aTHX_ class_stash, 0);
707 RETVAL = mro_get_linear_isa(class_stash);
710 ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
721 struct mro_meta* meta;
724 croak_xs_usage(cv, "classname, type");
727 class_stash = gv_stashsv(classname, GV_ADD);
728 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
729 meta = HvMROMETA(class_stash);
731 Perl_mro_set_mro(aTHX_ meta, ST(1));
745 croak_xs_usage(cv, "classname");
748 class_stash = gv_stashsv(classname, 0);
750 ST(0) = sv_2mortal(newSVpv(class_stash
751 ? HvMROMETA(class_stash)->mro_which->name
756 XS(XS_mro_get_isarev)
766 croak_xs_usage(cv, "classname");
773 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
774 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
780 while((iter = hv_iternext(isarev)))
781 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
783 mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
789 XS(XS_mro_is_universal)
796 STRLEN classname_len;
800 croak_xs_usage(cv, "classname");
804 classname_pv = SvPV(classname,classname_len);
806 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
807 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
809 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
810 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
816 XS(XS_mro_invalidate_method_caches)
822 croak_xs_usage(cv, "");
829 XS(XS_mro_method_changed_in)
837 croak_xs_usage(cv, "classname");
841 class_stash = gv_stashsv(classname, 0);
842 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
844 mro_method_changed_in(class_stash);
849 XS(XS_mro_get_pkg_gen)
857 croak_xs_usage(cv, "classname");
861 class_stash = gv_stashsv(classname, 0);
865 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
873 * c-indentation-style: bsd
875 * indent-tabs-mode: t
878 * ex: set ts=8 sts=4 sw=4 noet: