This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Make the new perl5db.t taint test work on VMS.
[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
414=cut
415*/
416void
417Perl_mro_isa_changed_in(pTHX_ HV* stash)
418{
419 dVAR;
420 HV* isarev;
421 AV* linear_mro;
422 HE* iter;
423 SV** svp;
424 I32 items;
1e05feb3 425 bool is_universal;
2c7f4b87 426 struct mro_meta * meta;
e1a479c5 427
0fa56319
RGS
428 const char * const stashname = HvNAME_get(stash);
429 const STRLEN stashname_len = HvNAMELEN_get(stash);
e1a479c5 430
7918f24d
NC
431 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
432
2c7f4b87
BB
433 if(!stashname)
434 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
435
e1a479c5 436 /* wipe out the cached linearizations for this stash */
2c7f4b87 437 meta = HvMROMETA(stash);
9953ff72
NC
438 if (meta->mro_linear_all) {
439 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
440 meta->mro_linear_all = NULL;
553e831a 441 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
442 meta->mro_linear_current = NULL;
443 } else if (meta->mro_linear_current) {
553e831a 444 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
445 SvREFCNT_dec(meta->mro_linear_current);
446 meta->mro_linear_current = NULL;
553e831a 447 }
5782d502
NC
448 if (meta->isa) {
449 SvREFCNT_dec(meta->isa);
450 meta->isa = NULL;
451 }
e1a479c5 452
70cd14a1
CB
453 /* Inc the package generation, since our @ISA changed */
454 meta->pkg_gen++;
455
e1a479c5
BB
456 /* Wipe the global method cache if this package
457 is UNIVERSAL or one of its parents */
dd69841b
BB
458
459 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 460 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
461
462 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
463 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 464 PL_sub_generation++;
dd69841b
BB
465 is_universal = TRUE;
466 }
1e05feb3 467 else { /* Wipe the local method cache otherwise */
dd69841b 468 meta->cache_gen++;
1e05feb3
AL
469 is_universal = FALSE;
470 }
e1a479c5
BB
471
472 /* wipe next::method cache too */
473 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 474
e1a479c5 475 /* Iterate the isarev (classes that are our children),
1375cf1c 476 wiping out their linearization, method and isa caches */
dd69841b 477 if(isarev) {
e1a479c5
BB
478 hv_iterinit(isarev);
479 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
480 I32 len;
481 const char* const revkey = hv_iterkey(iter, &len);
482 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
483 struct mro_meta* revmeta;
484
485 if(!revstash) continue;
486 revmeta = HvMROMETA(revstash);
9953ff72
NC
487 if (revmeta->mro_linear_all) {
488 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
489 revmeta->mro_linear_all = NULL;
553e831a 490 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
491 revmeta->mro_linear_current = NULL;
492 } else if (revmeta->mro_linear_current) {
553e831a 493 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
494 SvREFCNT_dec(revmeta->mro_linear_current);
495 revmeta->mro_linear_current = NULL;
553e831a 496 }
dd69841b
BB
497 if(!is_universal)
498 revmeta->cache_gen++;
e1a479c5
BB
499 if(revmeta->mro_nextmethod)
500 hv_clear(revmeta->mro_nextmethod);
1375cf1c
NC
501 if (revmeta->isa) {
502 SvREFCNT_dec(revmeta->isa);
503 revmeta->isa = NULL;
504 }
e1a479c5
BB
505 }
506 }
507
1c908217
RGS
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
512 */
513
514 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
515 linear_mro = mro_get_linear_isa(stash);
516 svp = AvARRAY(linear_mro) + 1;
517 items = AvFILLp(linear_mro);
1c908217 518
e1a479c5
BB
519 while (items--) {
520 SV* const sv = *svp++;
e1a479c5
BB
521 HV* mroisarev;
522
117b69ca
NC
523 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
524
525 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
526 us, then will need to upgrade it to an HV (which sv_upgrade() can
527 now do for us. */
117b69ca 528
85fbaab2 529 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 530
ad64d0ec 531 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 532
25270bc0
NC
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. */
537
04fe65b0 538 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
539
540 if(isarev) {
541 hv_iterinit(isarev);
542 while((iter = hv_iternext(isarev))) {
dd69841b 543 I32 revkeylen;
1e05feb3 544 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 545 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
546 }
547 }
548 }
549}
550
551/*
552=for apidoc mro_method_changed_in
553
47c9dd14
BB
554Invalidates method caching on any child classes
555of the given stash, so that they might notice
556the changes in this one.
e1a479c5
BB
557
558Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
559perl source outside of C<mro.c> should be
560replaced by calls to this.
561
562Perl automatically handles most of the common
563ways a method might be redefined. However, there
564are a few ways you could change a method in a stash
565without the cache code noticing, in which case you
566need to call this method afterwards:
e1a479c5 567
dd69841b
BB
5681) Directly manipulating the stash HV entries from
569XS code.
e1a479c5 570
dd69841b
BB
5712) Assigning a reference to a readonly scalar
572constant into a stash entry in order to create
573a constant subroutine (like constant.pm
574does).
575
576This same method is available from pure perl
577via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
578
579=cut
580*/
581void
582Perl_mro_method_changed_in(pTHX_ HV *stash)
583{
1e05feb3
AL
584 const char * const stashname = HvNAME_get(stash);
585 const STRLEN stashname_len = HvNAMELEN_get(stash);
dd69841b 586
1e05feb3 587 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 588 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 589
7918f24d
NC
590 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
591
2c7f4b87
BB
592 if(!stashname)
593 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
594
70cd14a1
CB
595 /* Inc the package generation, since a local method changed */
596 HvMROMETA(stash)->pkg_gen++;
597
e1a479c5
BB
598 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
599 invalidate all method caches globally */
dd69841b
BB
600 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
601 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
602 PL_sub_generation++;
603 return;
604 }
605
606 /* else, invalidate the method caches of all child classes,
607 but not itself */
dd69841b 608 if(isarev) {
1e05feb3
AL
609 HE* iter;
610
e1a479c5
BB
611 hv_iterinit(isarev);
612 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
613 I32 len;
614 const char* const revkey = hv_iterkey(iter, &len);
615 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
616 struct mro_meta* mrometa;
617
618 if(!revstash) continue;
619 mrometa = HvMROMETA(revstash);
dd69841b 620 mrometa->cache_gen++;
e1a479c5
BB
621 if(mrometa->mro_nextmethod)
622 hv_clear(mrometa->mro_nextmethod);
623 }
624 }
625}
626
31b9005d
NC
627void
628Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
629{
630 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
631
632 PERL_ARGS_ASSERT_MRO_SET_MRO;
633
634 if (!which)
635 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
636
637 if(meta->mro_which != which) {
9953ff72 638 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
639 /* If we were storing something directly, put it in the hash before
640 we lose it. */
641 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 642 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
643 }
644 meta->mro_which = which;
645 /* Scrub our cached pointer to the private data. */
3a6fa573 646 meta->mro_linear_current = NULL;
31b9005d
NC
647 /* Only affects local method cache, not
648 even child classes */
649 meta->cache_gen++;
650 if(meta->mro_nextmethod)
651 hv_clear(meta->mro_nextmethod);
652 }
653}
654
e1a479c5
BB
655#include "XSUB.h"
656
e1a479c5 657XS(XS_mro_method_changed_in);
e1a479c5
BB
658
659void
660Perl_boot_core_mro(pTHX)
661{
662 dVAR;
663 static const char file[] = __FILE__;
664
a3e6e81e 665 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 666
e1a479c5 667 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
668}
669
e1a479c5
BB
670XS(XS_mro_method_changed_in)
671{
672 dVAR;
673 dXSARGS;
674 SV* classname;
675 HV* class_stash;
676
e1a479c5 677 if(items != 1)
afa74d42 678 croak_xs_usage(cv, "classname");
e1a479c5
BB
679
680 classname = ST(0);
681
682 class_stash = gv_stashsv(classname, 0);
683 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
684
685 mro_method_changed_in(class_stash);
686
687 XSRETURN_EMPTY;
688}
689
e1a479c5
BB
690/*
691 * Local variables:
692 * c-indentation-style: bsd
693 * c-basic-offset: 4
694 * indent-tabs-mode: t
695 * End:
696 *
697 * ex: set ts=8 sts=4 sw=4 noet:
698 */