This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In APItest.xs, augment croak("fail") with the file name and line number.
[perl5.git] / mro.c
CommitLineData
e1a479c5
BB
1/* mro.c
2 *
3 * Copyright (c) 2007 Brandon L Black
1129b882 4 * Copyright (c) 2007, 2008 Larry Wall and others
e1a479c5
BB
5 *
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.
8 *
9 */
10
11/*
4ac71550
TC
12 * 'Which order shall we go in?' said Frodo. 'Eldest first, or quickest first?
13 * You'll be last either way, Master Peregrin.'
14 *
15 * [p.101 of _The Lord of the Rings_, I/iii: "A Conspiracy Unmasked"]
cac98860
RGS
16 */
17
18/*
e1a479c5
BB
19=head1 MRO Functions
20
21These functions are related to the method resolution order of perl classes
22
23=cut
24*/
25
26#include "EXTERN.h"
4befac30 27#define PERL_IN_MRO_C
e1a479c5
BB
28#include "perl.h"
29
a3e6e81e
NC
30static const struct mro_alg dfs_alg =
31 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
3d76853f 32
fa60396f
NC
33SV *
34Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
35 const struct mro_alg *const which)
36{
37 SV **data;
38 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
39
5844ac76
NC
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);
fa60396f
NC
43 if (!data)
44 return NULL;
45
46 /* If we've been asked to look up the private data for the current MRO, then
47 cache it. */
48 if (smeta->mro_which == which)
3a6fa573 49 smeta->mro_linear_current = *data;
fa60396f
NC
50
51 return *data;
52}
53
54SV *
55Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
56 const struct mro_alg *const which, SV *const data)
57{
58 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
59
9953ff72 60 if (!smeta->mro_linear_all) {
553e831a
NC
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. */
3a6fa573 65 smeta->mro_linear_current = data;
553e831a
NC
66 return data;
67 } else {
68 HV *const hv = newHV();
69 /* Start with 2 buckets. It's unlikely we'll need more. */
70 HvMAX(hv) = 1;
9953ff72 71 smeta->mro_linear_all = hv;
553e831a 72
3a6fa573 73 if (smeta->mro_linear_current) {
553e831a
NC
74 /* If we were storing something directly, put it in the hash
75 before we lose it. */
76 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
3a6fa573 77 smeta->mro_linear_current);
553e831a
NC
78 }
79 }
80 }
81
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. */
84
85 if (smeta->mro_which == which) {
86 /* If we've been asked to store the private data for the current MRO,
87 then cache it. */
3a6fa573 88 smeta->mro_linear_current = data;
fa60396f
NC
89 }
90
9953ff72 91 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
fa60396f
NC
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,
96 which->kflags);
97 }
98
99 return data;
100}
101
a3e6e81e
NC
102const struct mro_alg *
103Perl_mro_get_from_name(pTHX_ SV *name) {
104 SV **data;
105
106 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
107
5844ac76
NC
108 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109 HV_FETCH_JUST_SV, NULL, 0);
a3e6e81e
NC
110 if (!data)
111 return NULL;
112 assert(SvTYPE(*data) == SVt_IV);
113 assert(SvIOK(*data));
114 return INT2PTR(const struct mro_alg *, SvUVX(*data));
115}
116
117void
118Perl_mro_register(pTHX_ const struct mro_alg *mro) {
119 SV *wrapper = newSVuv(PTR2UV(mro));
120
121 PERL_ARGS_ASSERT_MRO_REGISTER;
122
123
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);
3d76853f 130 }
3d76853f
NC
131}
132
e1a479c5
BB
133struct mro_meta*
134Perl_mro_meta_init(pTHX_ HV* stash)
135{
9fe4aecf 136 struct mro_meta* newmeta;
e1a479c5 137
7918f24d 138 PERL_ARGS_ASSERT_MRO_META_INIT;
e1a479c5
BB
139 assert(HvAUX(stash));
140 assert(!(HvAUX(stash)->xhv_mro_meta));
183086be 141 Newxz(newmeta, 1, struct mro_meta);
9fe4aecf 142 HvAUX(stash)->xhv_mro_meta = newmeta;
dd69841b 143 newmeta->cache_gen = 1;
70cd14a1 144 newmeta->pkg_gen = 1;
a3e6e81e 145 newmeta->mro_which = &dfs_alg;
e1a479c5
BB
146
147 return newmeta;
148}
149
150#if defined(USE_ITHREADS)
151
152/* for sv_dup on new threads */
153struct mro_meta*
154Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
155{
e1a479c5
BB
156 struct mro_meta* newmeta;
157
7918f24d 158 PERL_ARGS_ASSERT_MRO_META_DUP;
e1a479c5 159
33e12d9d
NC
160 Newx(newmeta, 1, struct mro_meta);
161 Copy(smeta, newmeta, 1, struct mro_meta);
162
9953ff72
NC
163 if (newmeta->mro_linear_all) {
164 newmeta->mro_linear_all
a09252eb 165 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
553e831a
NC
166 /* This is just acting as a shortcut pointer, and will be automatically
167 updated on the first get. */
3a6fa573
NC
168 newmeta->mro_linear_current = NULL;
169 } else if (newmeta->mro_linear_current) {
553e831a 170 /* Only the current MRO is stored, so this owns the data. */
3a6fa573 171 newmeta->mro_linear_current
a09252eb 172 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
553e831a
NC
173 }
174
33e12d9d
NC
175 if (newmeta->mro_nextmethod)
176 newmeta->mro_nextmethod
a09252eb 177 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
a49ba3fc
NC
178 if (newmeta->isa)
179 newmeta->isa
a09252eb 180 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
e1a479c5
BB
181
182 return newmeta;
183}
184
185#endif /* USE_ITHREADS */
186
187/*
188=for apidoc mro_get_linear_isa_dfs
189
190Returns the Depth-First Search linearization of @ISA
191the given stash. The return value is a read-only AV*.
192C<level> should be 0 (it is used internally in this
193function's recursion).
194
1c908217
RGS
195You are responsible for C<SvREFCNT_inc()> on the
196return value if you plan to store it anywhere
197semi-permanently (otherwise it might be deleted
198out from under you the next time the cache is
199invalidated).
200
e1a479c5
BB
201=cut
202*/
4befac30 203static AV*
94d1e706 204S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
e1a479c5
BB
205{
206 AV* retval;
207 GV** gvp;
208 GV* gv;
209 AV* av;
190d0b22 210 const HEK* stashhek;
e1a479c5 211 struct mro_meta* meta;
a49ba3fc 212 SV *our_name;
73519bd0 213 HV *stored = NULL;
e1a479c5 214
7918f24d 215 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
e1a479c5
BB
216 assert(HvAUX(stash));
217
190d0b22
NC
218 stashhek = HvNAME_HEK(stash);
219 if (!stashhek)
1e05feb3 220 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
221
222 if (level > 100)
223 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 224 HEK_KEY(stashhek));
e1a479c5
BB
225
226 meta = HvMROMETA(stash);
1c908217
RGS
227
228 /* return cache if valid */
a3e6e81e 229 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
e1a479c5
BB
230 return retval;
231 }
232
233 /* not in cache, make a new one */
1c908217 234
ad64d0ec 235 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
a49ba3fc
NC
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 */
e1a479c5 240
1c908217 241 /* fetch our @ISA */
e1a479c5
BB
242 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
243 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
244
a49ba3fc
NC
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. */
250
a49ba3fc 251 if(av && AvFILLp(av) >= 0) {
1c908217 252
ffd8da72
NC
253 SV **svp = AvARRAY(av);
254 I32 items = AvFILLp(av) + 1;
1c908217
RGS
255
256 /* foreach(@ISA) */
e1a479c5
BB
257 while (items--) {
258 SV* const sv = *svp++;
259 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
260 SV *const *subrv_p;
261 I32 subrv_items;
e1a479c5
BB
262
263 if (!basestash) {
1c908217
RGS
264 /* if no stash exists for this @ISA member,
265 simply add it to the MRO and move on */
ffd8da72
NC
266 subrv_p = &sv;
267 subrv_items = 1;
e1a479c5
BB
268 }
269 else {
1c908217 270 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
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
274 the mortal. */
ffd8da72
NC
275 const AV *const subrv
276 = mro_get_linear_isa_dfs(basestash, level + 1);
277
278 subrv_p = AvARRAY(subrv);
279 subrv_items = AvFILLp(subrv) + 1;
280 }
73519bd0
NC
281 if (stored) {
282 while(subrv_items--) {
283 SV *const subsv = *subrv_p++;
284 /* LVALUE fetch will create a new undefined SV if necessary
285 */
286 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
287 assert(he);
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);
293
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));
303 SvREADONLY_on(val);
304 SvFAKE_on(val);
305 SvPOK_on(val);
306 if (HEK_UTF8(key))
307 SvUTF8_on(val);
308
309 av_push(retval, val);
310 }
ffd8da72 311 }
73519bd0
NC
312 } else {
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
323 with it. */
324 if (basestash) {
325 SV **svp;
17eef65c 326 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
73519bd0
NC
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)))
334 : newSVsv(val);
335 }
336 } else {
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);
341 av_push(retval,
342 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
343 &PL_sv_undef, 0))));
344 }
345 }
e1a479c5 346 }
73519bd0
NC
347 } else {
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);
e1a479c5
BB
351 }
352
ed09b296 353 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
ed09b296
NC
354
355 SvREFCNT_inc_simple_void_NN(stored);
356 SvTEMP_off(stored);
357 SvREADONLY_on(stored);
358
359 meta->isa = stored;
360
0fd7ece8
NC
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);
365 SvTEMP_off(retval);
fdef73f9 366
1c908217
RGS
367 /* we don't want anyone modifying the cache entry but us,
368 and we do so by replacing it completely */
e1a479c5 369 SvREADONLY_on(retval);
1c908217 370
a3e6e81e 371 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
fa60396f 372 MUTABLE_SV(retval)));
e1a479c5
BB
373}
374
375/*
e1a479c5
BB
376=for apidoc mro_get_linear_isa
377
378Returns either C<mro_get_linear_isa_c3> or
379C<mro_get_linear_isa_dfs> for the given stash,
380dependant upon which MRO is in effect
381for that stash. The return value is a
382read-only AV*.
383
1c908217
RGS
384You are responsible for C<SvREFCNT_inc()> on the
385return value if you plan to store it anywhere
386semi-permanently (otherwise it might be deleted
387out from under you the next time the cache is
388invalidated).
389
e1a479c5
BB
390=cut
391*/
392AV*
393Perl_mro_get_linear_isa(pTHX_ HV *stash)
394{
395 struct mro_meta* meta;
2c7f4b87 396
7918f24d 397 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
398 if(!SvOOK(stash))
399 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
400
401 meta = HvMROMETA(stash);
3d76853f 402 if (!meta->mro_which)
14f97ce6 403 Perl_croak(aTHX_ "panic: invalid MRO!");
3d76853f 404 return meta->mro_which->resolve(aTHX_ stash, 0);
e1a479c5
BB
405}
406
407/*
408=for apidoc mro_isa_changed_in
409
1c908217 410Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
411when the @ISA of the given package has changed. Invoked
412by the C<setisa> magic, should not need to invoke directly.
413
6f86b615
FC
414=for apidoc mro_isa_changed_in3
415
416Takes the necessary steps (cache invalidations, mostly)
417when the @ISA of the given package has changed. Invoked
418by the C<setisa> magic, should not need to invoke directly.
419
420The stash can be passed as the first argument, or its name and length as
421the second and third (or both). If just the name is passed and the stash
422does not exist, then only the subclasses' method and isa caches will be
423invalidated.
424
e1a479c5
BB
425=cut
426*/
427void
6f86b615
FC
428Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
429 STRLEN stashname_len)
e1a479c5
BB
430{
431 dVAR;
432 HV* isarev;
433 AV* linear_mro;
434 HE* iter;
435 SV** svp;
436 I32 items;
1e05feb3 437 bool is_universal;
6f86b615 438 struct mro_meta * meta = NULL;
e1a479c5 439
6f86b615
FC
440 if(!stashname && stash) {
441 stashname = HvNAME_get(stash);
442 stashname_len = HvNAMELEN_get(stash);
443 }
444 else if(!stash)
445 stash = gv_stashpvn(stashname, stashname_len, 0 /* don't add */);
7918f24d 446
2c7f4b87
BB
447 if(!stashname)
448 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
449
6f86b615
FC
450 if(stash) {
451 /* wipe out the cached linearizations for this stash */
452 meta = HvMROMETA(stash);
453 if (meta->mro_linear_all) {
9953ff72
NC
454 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
455 meta->mro_linear_all = NULL;
553e831a 456 /* This is just acting as a shortcut pointer. */
3a6fa573 457 meta->mro_linear_current = NULL;
6f86b615 458 } else if (meta->mro_linear_current) {
553e831a 459 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
460 SvREFCNT_dec(meta->mro_linear_current);
461 meta->mro_linear_current = NULL;
6f86b615
FC
462 }
463 if (meta->isa) {
5782d502
NC
464 SvREFCNT_dec(meta->isa);
465 meta->isa = NULL;
6f86b615 466 }
e1a479c5 467
6f86b615
FC
468 /* Inc the package generation, since our @ISA changed */
469 meta->pkg_gen++;
470 }
70cd14a1 471
e1a479c5
BB
472 /* Wipe the global method cache if this package
473 is UNIVERSAL or one of its parents */
dd69841b
BB
474
475 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 476 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
477
478 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
479 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 480 PL_sub_generation++;
dd69841b
BB
481 is_universal = TRUE;
482 }
1e05feb3 483 else { /* Wipe the local method cache otherwise */
6f86b615 484 if(meta) meta->cache_gen++;
1e05feb3
AL
485 is_universal = FALSE;
486 }
e1a479c5
BB
487
488 /* wipe next::method cache too */
6f86b615 489 if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 490
e1a479c5 491 /* Iterate the isarev (classes that are our children),
1375cf1c 492 wiping out their linearization, method and isa caches */
dd69841b 493 if(isarev) {
e1a479c5
BB
494 hv_iterinit(isarev);
495 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
496 I32 len;
497 const char* const revkey = hv_iterkey(iter, &len);
498 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
499 struct mro_meta* revmeta;
500
501 if(!revstash) continue;
502 revmeta = HvMROMETA(revstash);
9953ff72
NC
503 if (revmeta->mro_linear_all) {
504 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
505 revmeta->mro_linear_all = NULL;
553e831a 506 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
507 revmeta->mro_linear_current = NULL;
508 } else if (revmeta->mro_linear_current) {
553e831a 509 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
510 SvREFCNT_dec(revmeta->mro_linear_current);
511 revmeta->mro_linear_current = NULL;
553e831a 512 }
dd69841b
BB
513 if(!is_universal)
514 revmeta->cache_gen++;
e1a479c5
BB
515 if(revmeta->mro_nextmethod)
516 hv_clear(revmeta->mro_nextmethod);
1375cf1c
NC
517 if (revmeta->isa) {
518 SvREFCNT_dec(revmeta->isa);
519 revmeta->isa = NULL;
520 }
e1a479c5
BB
521 }
522 }
523
1c908217
RGS
524 /* Now iterate our MRO (parents), and do a few things:
525 1) instantiate with the "fake" flag if they don't exist
526 2) flag them as universal if we are universal
527 3) Add everything from our isarev to their isarev
528 */
529
6f86b615
FC
530 /* This only applies if the stash exists. */
531 if(!stash) return;
532
1c908217 533 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
534 linear_mro = mro_get_linear_isa(stash);
535 svp = AvARRAY(linear_mro) + 1;
536 items = AvFILLp(linear_mro);
1c908217 537
e1a479c5
BB
538 while (items--) {
539 SV* const sv = *svp++;
e1a479c5
BB
540 HV* mroisarev;
541
117b69ca
NC
542 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
543
544 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
545 us, then will need to upgrade it to an HV (which sv_upgrade() can
546 now do for us. */
117b69ca 547
85fbaab2 548 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 549
ad64d0ec 550 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 551
25270bc0
NC
552 /* This hash only ever contains PL_sv_yes. Storing it over itself is
553 almost as cheap as calling hv_exists, so on aggregate we expect to
554 save time by not making two calls to the common HV code for the
555 case where it doesn't exist. */
556
04fe65b0 557 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
558
559 if(isarev) {
560 hv_iterinit(isarev);
561 while((iter = hv_iternext(isarev))) {
dd69841b 562 I32 revkeylen;
1e05feb3 563 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 564 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
565 }
566 }
567 }
568}
569
570/*
c8bbf675
FC
571=for apidoc mro_package_moved
572
573Invalidates isa caches on this stash, on all subpackages nested inside it,
574and on the subclasses of all those.
575
576=cut
577*/
578void
579Perl_mro_package_moved(pTHX_ const HV *stash)
580{
581 register XPVHV* xhv;
582 register HE *entry;
583 I32 riter = -1;
584
585 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
586
587 mro_isa_changed_in((HV *)stash);
588
589 if(!HvARRAY(stash)) return;
590
591 /* This is partly based on code in hv_iternext_flags. We are not call-
592 ing that here, as we want to avoid resetting the hash iterator. */
593
594 xhv = (XPVHV*)SvANY(stash);
595
596 /* Skip the entire loop if the hash is empty. */
597 if (HvUSEDKEYS(stash)) {
598 while (++riter <= (I32)xhv->xhv_max) {
599 entry = (HvARRAY(stash))[riter];
600
601 /* Iterate through the entries in this list */
602 for(; entry; entry = HeNEXT(entry)) {
603 const char* key;
604 I32 len;
605
606 /* If this entry is not a glob, ignore it.
607 Try the next. */
608 if (!isGV(HeVAL(entry))) continue;
609
610 key = hv_iterkey(entry, &len);
611 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
612 const HV * const stash = GvHV(HeVAL(entry));
613 if(stash && HvNAME(stash)) mro_package_moved(stash);
614 }
615 }
616 }
617 }
618}
619
620/*
e1a479c5
BB
621=for apidoc mro_method_changed_in
622
47c9dd14
BB
623Invalidates method caching on any child classes
624of the given stash, so that they might notice
625the changes in this one.
e1a479c5
BB
626
627Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
628perl source outside of C<mro.c> should be
629replaced by calls to this.
630
631Perl automatically handles most of the common
632ways a method might be redefined. However, there
633are a few ways you could change a method in a stash
634without the cache code noticing, in which case you
635need to call this method afterwards:
e1a479c5 636
dd69841b
BB
6371) Directly manipulating the stash HV entries from
638XS code.
e1a479c5 639
dd69841b
BB
6402) Assigning a reference to a readonly scalar
641constant into a stash entry in order to create
642a constant subroutine (like constant.pm
643does).
644
645This same method is available from pure perl
646via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
647
648=cut
649*/
650void
651Perl_mro_method_changed_in(pTHX_ HV *stash)
652{
1e05feb3
AL
653 const char * const stashname = HvNAME_get(stash);
654 const STRLEN stashname_len = HvNAMELEN_get(stash);
dd69841b 655
1e05feb3 656 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 657 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 658
7918f24d
NC
659 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
660
2c7f4b87
BB
661 if(!stashname)
662 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
663
70cd14a1
CB
664 /* Inc the package generation, since a local method changed */
665 HvMROMETA(stash)->pkg_gen++;
666
e1a479c5
BB
667 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
668 invalidate all method caches globally */
dd69841b
BB
669 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
670 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
671 PL_sub_generation++;
672 return;
673 }
674
675 /* else, invalidate the method caches of all child classes,
676 but not itself */
dd69841b 677 if(isarev) {
1e05feb3
AL
678 HE* iter;
679
e1a479c5
BB
680 hv_iterinit(isarev);
681 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
682 I32 len;
683 const char* const revkey = hv_iterkey(iter, &len);
684 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
685 struct mro_meta* mrometa;
686
687 if(!revstash) continue;
688 mrometa = HvMROMETA(revstash);
dd69841b 689 mrometa->cache_gen++;
e1a479c5
BB
690 if(mrometa->mro_nextmethod)
691 hv_clear(mrometa->mro_nextmethod);
692 }
693 }
694}
695
31b9005d
NC
696void
697Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
698{
699 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
700
701 PERL_ARGS_ASSERT_MRO_SET_MRO;
702
703 if (!which)
704 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
705
706 if(meta->mro_which != which) {
9953ff72 707 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
708 /* If we were storing something directly, put it in the hash before
709 we lose it. */
710 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 711 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
712 }
713 meta->mro_which = which;
714 /* Scrub our cached pointer to the private data. */
3a6fa573 715 meta->mro_linear_current = NULL;
31b9005d
NC
716 /* Only affects local method cache, not
717 even child classes */
718 meta->cache_gen++;
719 if(meta->mro_nextmethod)
720 hv_clear(meta->mro_nextmethod);
721 }
722}
723
e1a479c5
BB
724#include "XSUB.h"
725
e1a479c5 726XS(XS_mro_method_changed_in);
e1a479c5
BB
727
728void
729Perl_boot_core_mro(pTHX)
730{
731 dVAR;
732 static const char file[] = __FILE__;
733
a3e6e81e 734 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 735
e1a479c5 736 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
737}
738
e1a479c5
BB
739XS(XS_mro_method_changed_in)
740{
741 dVAR;
742 dXSARGS;
743 SV* classname;
744 HV* class_stash;
745
e1a479c5 746 if(items != 1)
afa74d42 747 croak_xs_usage(cv, "classname");
e1a479c5
BB
748
749 classname = ST(0);
750
751 class_stash = gv_stashsv(classname, 0);
752 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
753
754 mro_method_changed_in(class_stash);
755
756 XSRETURN_EMPTY;
757}
758
e1a479c5
BB
759/*
760 * Local variables:
761 * c-indentation-style: bsd
762 * c-basic-offset: 4
763 * indent-tabs-mode: t
764 * End:
765 *
766 * ex: set ts=8 sts=4 sw=4 noet:
767 */