This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Perl_newHVhv() should copy immortal values as-is, such as PL_sv_undef
[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
165 = MUTABLE_HV(SvREFCNT_inc(sv_dup((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
NC
171 newmeta->mro_linear_current
172 = SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_current,
173 param));
553e831a
NC
174 }
175
33e12d9d
NC
176 if (newmeta->mro_nextmethod)
177 newmeta->mro_nextmethod
ad64d0ec 178 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
a49ba3fc
NC
179 if (newmeta->isa)
180 newmeta->isa
ad64d0ec 181 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
e1a479c5
BB
182
183 return newmeta;
184}
185
186#endif /* USE_ITHREADS */
187
188/*
189=for apidoc mro_get_linear_isa_dfs
190
191Returns the Depth-First Search linearization of @ISA
192the given stash. The return value is a read-only AV*.
193C<level> should be 0 (it is used internally in this
194function's recursion).
195
1c908217
RGS
196You are responsible for C<SvREFCNT_inc()> on the
197return value if you plan to store it anywhere
198semi-permanently (otherwise it might be deleted
199out from under you the next time the cache is
200invalidated).
201
e1a479c5
BB
202=cut
203*/
4befac30 204static AV*
94d1e706 205S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
e1a479c5
BB
206{
207 AV* retval;
208 GV** gvp;
209 GV* gv;
210 AV* av;
190d0b22 211 const HEK* stashhek;
e1a479c5 212 struct mro_meta* meta;
a49ba3fc
NC
213 SV *our_name;
214 HV *stored;
e1a479c5 215
7918f24d 216 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
e1a479c5
BB
217 assert(HvAUX(stash));
218
190d0b22
NC
219 stashhek = HvNAME_HEK(stash);
220 if (!stashhek)
1e05feb3 221 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
222
223 if (level > 100)
224 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 225 HEK_KEY(stashhek));
e1a479c5
BB
226
227 meta = HvMROMETA(stash);
1c908217
RGS
228
229 /* return cache if valid */
a3e6e81e 230 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
e1a479c5
BB
231 return retval;
232 }
233
234 /* not in cache, make a new one */
1c908217 235
ad64d0ec 236 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
a49ba3fc
NC
237 /* We use this later in this function, but don't need a reference to it
238 beyond the end of this function, so reference count is fine. */
239 our_name = newSVhek(stashhek);
240 av_push(retval, our_name); /* add ourselves at the top */
e1a479c5 241
1c908217 242 /* fetch our @ISA */
e1a479c5
BB
243 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
244 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
245
a49ba3fc
NC
246 /* "stored" is used to keep track of all of the classnames we have added to
247 the MRO so far, so we can do a quick exists check and avoid adding
248 duplicate classnames to the MRO as we go.
249 It's then retained to be re-used as a fast lookup for ->isa(), by adding
250 our own name and "UNIVERSAL" to it. */
251
ad64d0ec 252 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
1c908217 253
a49ba3fc 254 if(av && AvFILLp(av) >= 0) {
1c908217 255
ffd8da72
NC
256 SV **svp = AvARRAY(av);
257 I32 items = AvFILLp(av) + 1;
1c908217
RGS
258
259 /* foreach(@ISA) */
e1a479c5
BB
260 while (items--) {
261 SV* const sv = *svp++;
262 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
263 SV *const *subrv_p;
264 I32 subrv_items;
e1a479c5
BB
265
266 if (!basestash) {
1c908217
RGS
267 /* if no stash exists for this @ISA member,
268 simply add it to the MRO and move on */
ffd8da72
NC
269 subrv_p = &sv;
270 subrv_items = 1;
e1a479c5
BB
271 }
272 else {
1c908217 273 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
274 of this @ISA member, and append their MRO to ours.
275 The recursive call could throw an exception, which
276 has memory management implications here, hence the use of
277 the mortal. */
ffd8da72
NC
278 const AV *const subrv
279 = mro_get_linear_isa_dfs(basestash, level + 1);
280
281 subrv_p = AvARRAY(subrv);
282 subrv_items = AvFILLp(subrv) + 1;
283 }
284 while(subrv_items--) {
285 SV *const subsv = *subrv_p++;
8e45cc2b
NC
286 /* LVALUE fetch will create a new undefined SV if necessary
287 */
288 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
289 assert(he);
290 if(HeVAL(he) != &PL_sv_undef) {
291 /* It was newly created. Steal it for our new SV, and
292 replace it in the hash with the "real" thing. */
293 SV *const val = HeVAL(he);
f46ee248 294 HEK *const key = HeKEY_hek(he);
8e45cc2b
NC
295
296 HeVAL(he) = &PL_sv_undef;
f46ee248
NC
297 /* Save copying by making a shared hash key scalar. We
298 inline this here rather than calling Perl_newSVpvn_share
299 because we already have the scalar, and we already have
300 the hash key. */
301 assert(SvTYPE(val) == SVt_NULL);
302 sv_upgrade(val, SVt_PV);
303 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
304 SvCUR_set(val, HEK_LEN(key));
305 SvREADONLY_on(val);
306 SvFAKE_on(val);
307 SvPOK_on(val);
308 if (HEK_UTF8(key))
309 SvUTF8_on(val);
310
8e45cc2b 311 av_push(retval, val);
ffd8da72 312 }
e1a479c5
BB
313 }
314 }
315 }
316
ed09b296
NC
317 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
318 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
319
320 SvREFCNT_inc_simple_void_NN(stored);
321 SvTEMP_off(stored);
322 SvREADONLY_on(stored);
323
324 meta->isa = stored;
325
0fd7ece8
NC
326 /* now that we're past the exception dangers, grab our own reference to
327 the AV we're about to use for the result. The reference owned by the
328 mortals' stack will be released soon, so everything will balance. */
329 SvREFCNT_inc_simple_void_NN(retval);
330 SvTEMP_off(retval);
fdef73f9 331
1c908217
RGS
332 /* we don't want anyone modifying the cache entry but us,
333 and we do so by replacing it completely */
e1a479c5 334 SvREADONLY_on(retval);
1c908217 335
a3e6e81e 336 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
fa60396f 337 MUTABLE_SV(retval)));
e1a479c5
BB
338}
339
340/*
e1a479c5
BB
341=for apidoc mro_get_linear_isa
342
343Returns either C<mro_get_linear_isa_c3> or
344C<mro_get_linear_isa_dfs> for the given stash,
345dependant upon which MRO is in effect
346for that stash. The return value is a
347read-only AV*.
348
1c908217
RGS
349You are responsible for C<SvREFCNT_inc()> on the
350return value if you plan to store it anywhere
351semi-permanently (otherwise it might be deleted
352out from under you the next time the cache is
353invalidated).
354
e1a479c5
BB
355=cut
356*/
357AV*
358Perl_mro_get_linear_isa(pTHX_ HV *stash)
359{
360 struct mro_meta* meta;
2c7f4b87 361
7918f24d 362 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
363 if(!SvOOK(stash))
364 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
365
366 meta = HvMROMETA(stash);
3d76853f 367 if (!meta->mro_which)
14f97ce6 368 Perl_croak(aTHX_ "panic: invalid MRO!");
3d76853f 369 return meta->mro_which->resolve(aTHX_ stash, 0);
e1a479c5
BB
370}
371
372/*
373=for apidoc mro_isa_changed_in
374
1c908217 375Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
376when the @ISA of the given package has changed. Invoked
377by the C<setisa> magic, should not need to invoke directly.
378
379=cut
380*/
381void
382Perl_mro_isa_changed_in(pTHX_ HV* stash)
383{
384 dVAR;
385 HV* isarev;
386 AV* linear_mro;
387 HE* iter;
388 SV** svp;
389 I32 items;
1e05feb3 390 bool is_universal;
2c7f4b87 391 struct mro_meta * meta;
e1a479c5 392
0fa56319
RGS
393 const char * const stashname = HvNAME_get(stash);
394 const STRLEN stashname_len = HvNAMELEN_get(stash);
e1a479c5 395
7918f24d
NC
396 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
397
2c7f4b87
BB
398 if(!stashname)
399 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
400
e1a479c5 401 /* wipe out the cached linearizations for this stash */
2c7f4b87 402 meta = HvMROMETA(stash);
9953ff72
NC
403 if (meta->mro_linear_all) {
404 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
405 meta->mro_linear_all = NULL;
553e831a 406 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
407 meta->mro_linear_current = NULL;
408 } else if (meta->mro_linear_current) {
553e831a 409 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
410 SvREFCNT_dec(meta->mro_linear_current);
411 meta->mro_linear_current = NULL;
553e831a 412 }
5782d502
NC
413 if (meta->isa) {
414 SvREFCNT_dec(meta->isa);
415 meta->isa = NULL;
416 }
e1a479c5 417
70cd14a1
CB
418 /* Inc the package generation, since our @ISA changed */
419 meta->pkg_gen++;
420
e1a479c5
BB
421 /* Wipe the global method cache if this package
422 is UNIVERSAL or one of its parents */
dd69841b
BB
423
424 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 425 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
426
427 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
428 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 429 PL_sub_generation++;
dd69841b
BB
430 is_universal = TRUE;
431 }
1e05feb3 432 else { /* Wipe the local method cache otherwise */
dd69841b 433 meta->cache_gen++;
1e05feb3
AL
434 is_universal = FALSE;
435 }
e1a479c5
BB
436
437 /* wipe next::method cache too */
438 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 439
e1a479c5 440 /* Iterate the isarev (classes that are our children),
1375cf1c 441 wiping out their linearization, method and isa caches */
dd69841b 442 if(isarev) {
e1a479c5
BB
443 hv_iterinit(isarev);
444 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
445 I32 len;
446 const char* const revkey = hv_iterkey(iter, &len);
447 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
448 struct mro_meta* revmeta;
449
450 if(!revstash) continue;
451 revmeta = HvMROMETA(revstash);
9953ff72
NC
452 if (revmeta->mro_linear_all) {
453 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
454 revmeta->mro_linear_all = NULL;
553e831a 455 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
456 revmeta->mro_linear_current = NULL;
457 } else if (revmeta->mro_linear_current) {
553e831a 458 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
459 SvREFCNT_dec(revmeta->mro_linear_current);
460 revmeta->mro_linear_current = NULL;
553e831a 461 }
dd69841b
BB
462 if(!is_universal)
463 revmeta->cache_gen++;
e1a479c5
BB
464 if(revmeta->mro_nextmethod)
465 hv_clear(revmeta->mro_nextmethod);
1375cf1c
NC
466 if (revmeta->isa) {
467 SvREFCNT_dec(revmeta->isa);
468 revmeta->isa = NULL;
469 }
e1a479c5
BB
470 }
471 }
472
1c908217
RGS
473 /* Now iterate our MRO (parents), and do a few things:
474 1) instantiate with the "fake" flag if they don't exist
475 2) flag them as universal if we are universal
476 3) Add everything from our isarev to their isarev
477 */
478
479 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
480 linear_mro = mro_get_linear_isa(stash);
481 svp = AvARRAY(linear_mro) + 1;
482 items = AvFILLp(linear_mro);
1c908217 483
e1a479c5
BB
484 while (items--) {
485 SV* const sv = *svp++;
e1a479c5
BB
486 HV* mroisarev;
487
117b69ca
NC
488 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
489
490 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
491 us, then will need to upgrade it to an HV (which sv_upgrade() can
492 now do for us. */
117b69ca 493
85fbaab2 494 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 495
ad64d0ec 496 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 497
25270bc0
NC
498 /* This hash only ever contains PL_sv_yes. Storing it over itself is
499 almost as cheap as calling hv_exists, so on aggregate we expect to
500 save time by not making two calls to the common HV code for the
501 case where it doesn't exist. */
502
04fe65b0 503 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
504
505 if(isarev) {
506 hv_iterinit(isarev);
507 while((iter = hv_iternext(isarev))) {
dd69841b 508 I32 revkeylen;
1e05feb3 509 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 510 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
511 }
512 }
513 }
514}
515
516/*
517=for apidoc mro_method_changed_in
518
47c9dd14
BB
519Invalidates method caching on any child classes
520of the given stash, so that they might notice
521the changes in this one.
e1a479c5
BB
522
523Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
524perl source outside of C<mro.c> should be
525replaced by calls to this.
526
527Perl automatically handles most of the common
528ways a method might be redefined. However, there
529are a few ways you could change a method in a stash
530without the cache code noticing, in which case you
531need to call this method afterwards:
e1a479c5 532
dd69841b
BB
5331) Directly manipulating the stash HV entries from
534XS code.
e1a479c5 535
dd69841b
BB
5362) Assigning a reference to a readonly scalar
537constant into a stash entry in order to create
538a constant subroutine (like constant.pm
539does).
540
541This same method is available from pure perl
542via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
543
544=cut
545*/
546void
547Perl_mro_method_changed_in(pTHX_ HV *stash)
548{
1e05feb3
AL
549 const char * const stashname = HvNAME_get(stash);
550 const STRLEN stashname_len = HvNAMELEN_get(stash);
dd69841b 551
1e05feb3 552 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 553 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 554
7918f24d
NC
555 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
556
2c7f4b87
BB
557 if(!stashname)
558 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
559
70cd14a1
CB
560 /* Inc the package generation, since a local method changed */
561 HvMROMETA(stash)->pkg_gen++;
562
e1a479c5
BB
563 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
564 invalidate all method caches globally */
dd69841b
BB
565 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
566 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
567 PL_sub_generation++;
568 return;
569 }
570
571 /* else, invalidate the method caches of all child classes,
572 but not itself */
dd69841b 573 if(isarev) {
1e05feb3
AL
574 HE* iter;
575
e1a479c5
BB
576 hv_iterinit(isarev);
577 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
578 I32 len;
579 const char* const revkey = hv_iterkey(iter, &len);
580 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
581 struct mro_meta* mrometa;
582
583 if(!revstash) continue;
584 mrometa = HvMROMETA(revstash);
dd69841b 585 mrometa->cache_gen++;
e1a479c5
BB
586 if(mrometa->mro_nextmethod)
587 hv_clear(mrometa->mro_nextmethod);
588 }
589 }
590}
591
31b9005d
NC
592void
593Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
594{
595 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
596
597 PERL_ARGS_ASSERT_MRO_SET_MRO;
598
599 if (!which)
600 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
601
602 if(meta->mro_which != which) {
9953ff72 603 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
604 /* If we were storing something directly, put it in the hash before
605 we lose it. */
606 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 607 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
608 }
609 meta->mro_which = which;
610 /* Scrub our cached pointer to the private data. */
3a6fa573 611 meta->mro_linear_current = NULL;
31b9005d
NC
612 /* Only affects local method cache, not
613 even child classes */
614 meta->cache_gen++;
615 if(meta->mro_nextmethod)
616 hv_clear(meta->mro_nextmethod);
617 }
618}
619
e1a479c5
BB
620#include "XSUB.h"
621
e1a479c5 622XS(XS_mro_method_changed_in);
e1a479c5
BB
623
624void
625Perl_boot_core_mro(pTHX)
626{
627 dVAR;
628 static const char file[] = __FILE__;
629
a3e6e81e 630 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 631
e1a479c5 632 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
633}
634
e1a479c5
BB
635XS(XS_mro_method_changed_in)
636{
637 dVAR;
638 dXSARGS;
639 SV* classname;
640 HV* class_stash;
641
e1a479c5 642 if(items != 1)
afa74d42 643 croak_xs_usage(cv, "classname");
e1a479c5
BB
644
645 classname = ST(0);
646
647 class_stash = gv_stashsv(classname, 0);
648 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
649
650 mro_method_changed_in(class_stash);
651
652 XSRETURN_EMPTY;
653}
654
e1a479c5
BB
655/*
656 * Local variables:
657 * c-indentation-style: bsd
658 * c-basic-offset: 4
659 * indent-tabs-mode: t
660 * End:
661 *
662 * ex: set ts=8 sts=4 sw=4 noet:
663 */