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 = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, 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_all) {
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_all = 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_ smeta->mro_linear_all, 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 = (SV **)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_all) {
164 newmeta->mro_linear_all
165 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, 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 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
175 if (newmeta->mro_nextmethod)
176 newmeta->mro_nextmethod
177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
180 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
185 #endif /* USE_ITHREADS */
188 =for apidoc mro_get_linear_isa_dfs
190 Returns the Depth-First Search linearization of @ISA
191 the given stash. The return value is a read-only AV*.
192 C<level> should be 0 (it is used internally in this
193 function's recursion).
195 You are responsible for C<SvREFCNT_inc()> on the
196 return value if you plan to store it anywhere
197 semi-permanently (otherwise it might be deleted
198 out from under you the next time the cache is
204 S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
211 struct mro_meta* meta;
215 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
216 assert(HvAUX(stash));
218 stashhek = HvNAME_HEK(stash);
220 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
223 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
226 meta = HvMROMETA(stash);
228 /* return cache if valid */
229 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
233 /* not in cache, make a new one */
235 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
236 /* We use this later in this function, but don't need a reference to it
237 beyond the end of this function, so reference count is fine. */
238 our_name = newSVhek(stashhek);
239 av_push(retval, our_name); /* add ourselves at the top */
242 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
243 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
245 /* "stored" is used to keep track of all of the classnames we have added to
246 the MRO so far, so we can do a quick exists check and avoid adding
247 duplicate classnames to the MRO as we go.
248 It's then retained to be re-used as a fast lookup for ->isa(), by adding
249 our own name and "UNIVERSAL" to it. */
251 if(av && AvFILLp(av) >= 0) {
253 SV **svp = AvARRAY(av);
254 I32 items = AvFILLp(av) + 1;
258 SV* const sv = *svp++;
259 HV* const basestash = gv_stashsv(sv, 0);
264 /* if no stash exists for this @ISA member,
265 simply add it to the MRO and move on */
270 /* otherwise, recurse into ourselves for the MRO
271 of this @ISA member, and append their MRO to ours.
272 The recursive call could throw an exception, which
273 has memory management implications here, hence the use of
275 const AV *const subrv
276 = mro_get_linear_isa_dfs(basestash, level + 1);
278 subrv_p = AvARRAY(subrv);
279 subrv_items = AvFILLp(subrv) + 1;
282 while(subrv_items--) {
283 SV *const subsv = *subrv_p++;
284 /* LVALUE fetch will create a new undefined SV if necessary
286 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
288 if(HeVAL(he) != &PL_sv_undef) {
289 /* It was newly created. Steal it for our new SV, and
290 replace it in the hash with the "real" thing. */
291 SV *const val = HeVAL(he);
292 HEK *const key = HeKEY_hek(he);
294 HeVAL(he) = &PL_sv_undef;
295 /* Save copying by making a shared hash key scalar. We
296 inline this here rather than calling
297 Perl_newSVpvn_share because we already have the
298 scalar, and we already have the hash key. */
299 assert(SvTYPE(val) == SVt_NULL);
300 sv_upgrade(val, SVt_PV);
301 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
302 SvCUR_set(val, HEK_LEN(key));
309 av_push(retval, val);
313 /* We are the first (or only) parent. We can short cut the
314 complexity above, because our @ISA is simply us prepended
315 to our parent's @ISA, and our ->isa cache is simply our
316 parent's, with our name added. */
317 /* newSVsv() is slow. This code is only faster if we can avoid
318 it by ensuring that SVs in the arrays are shared hash key
319 scalar SVs, because we can "copy" them very efficiently.
320 Although to be fair, we can't *ensure* this, as a reference
321 to the internal array is returned by mro::get_linear_isa(),
322 so we'll have to be defensive just in case someone faffed
326 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
327 av_extend(retval, subrv_items);
328 AvFILLp(retval) = subrv_items;
329 svp = AvARRAY(retval);
330 while(subrv_items--) {
331 SV *const val = *subrv_p++;
332 *++svp = SvIsCOW_shared_hash(val)
333 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
337 /* They have no stash. So create ourselves an ->isa cache
338 as if we'd copied it from what theirs should be. */
339 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
340 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
342 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
348 /* We have no parents. */
349 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
350 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
353 (void) hv_store_ent(stored, our_name, &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_all) {
439 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
440 meta->mro_linear_all = 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, method and isa 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_all) {
488 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
489 revmeta->mro_linear_all = 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);
502 SvREFCNT_dec(revmeta->isa);
508 /* Now iterate our MRO (parents), and do a few things:
509 1) instantiate with the "fake" flag if they don't exist
510 2) flag them as universal if we are universal
511 3) Add everything from our isarev to their isarev
514 /* We're starting at the 2nd element, skipping ourselves here */
515 linear_mro = mro_get_linear_isa(stash);
516 svp = AvARRAY(linear_mro) + 1;
517 items = AvFILLp(linear_mro);
520 SV* const sv = *svp++;
523 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
525 /* That fetch should not fail. But if it had to create a new SV for
526 us, then will need to upgrade it to an HV (which sv_upgrade() can
529 mroisarev = MUTABLE_HV(HeVAL(he));
531 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
533 /* This hash only ever contains PL_sv_yes. Storing it over itself is
534 almost as cheap as calling hv_exists, so on aggregate we expect to
535 save time by not making two calls to the common HV code for the
536 case where it doesn't exist. */
538 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
542 while((iter = hv_iternext(isarev))) {
544 char* const revkey = hv_iterkey(iter, &revkeylen);
545 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
552 =for apidoc mro_method_changed_in
554 Invalidates method caching on any child classes
555 of the given stash, so that they might notice
556 the changes in this one.
558 Ideally, all instances of C<PL_sub_generation++> in
559 perl source outside of C<mro.c> should be
560 replaced by calls to this.
562 Perl automatically handles most of the common
563 ways a method might be redefined. However, there
564 are a few ways you could change a method in a stash
565 without the cache code noticing, in which case you
566 need to call this method afterwards:
568 1) Directly manipulating the stash HV entries from
571 2) Assigning a reference to a readonly scalar
572 constant into a stash entry in order to create
573 a constant subroutine (like constant.pm
576 This same method is available from pure perl
577 via, C<mro::method_changed_in(classname)>.
582 Perl_mro_method_changed_in(pTHX_ HV *stash)
584 const char * const stashname = HvNAME_get(stash);
585 const STRLEN stashname_len = HvNAMELEN_get(stash);
587 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
588 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
590 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
593 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
595 /* Inc the package generation, since a local method changed */
596 HvMROMETA(stash)->pkg_gen++;
598 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
599 invalidate all method caches globally */
600 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
601 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
606 /* else, invalidate the method caches of all child classes,
612 while((iter = hv_iternext(isarev))) {
614 const char* const revkey = hv_iterkey(iter, &len);
615 HV* const revstash = gv_stashpvn(revkey, len, 0);
616 struct mro_meta* mrometa;
618 if(!revstash) continue;
619 mrometa = HvMROMETA(revstash);
620 mrometa->cache_gen++;
621 if(mrometa->mro_nextmethod)
622 hv_clear(mrometa->mro_nextmethod);
628 Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
630 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
632 PERL_ARGS_ASSERT_MRO_SET_MRO;
635 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
637 if(meta->mro_which != which) {
638 if (meta->mro_linear_current && !meta->mro_linear_all) {
639 /* If we were storing something directly, put it in the hash before
641 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
642 MUTABLE_SV(meta->mro_linear_current));
644 meta->mro_which = which;
645 /* Scrub our cached pointer to the private data. */
646 meta->mro_linear_current = NULL;
647 /* Only affects local method cache, not
648 even child classes */
650 if(meta->mro_nextmethod)
651 hv_clear(meta->mro_nextmethod);
657 XS(XS_mro_method_changed_in);
660 Perl_boot_core_mro(pTHX)
663 static const char file[] = __FILE__;
665 Perl_mro_register(aTHX_ &dfs_alg);
667 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
670 XS(XS_mro_method_changed_in)
678 croak_xs_usage(cv, "classname");
682 class_stash = gv_stashsv(classname, 0);
683 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
685 mro_method_changed_in(class_stash);
692 * c-indentation-style: bsd
694 * indent-tabs-mode: t
697 * ex: set ts=8 sts=4 sw=4 noet: