This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Memory-management macros evaluate their arguments multiple times
[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
d056e33c
FC
573Call this function to signal to a stash that it has been assigned to
574another spot in the stash hierarchy. C<stash> is the stash that has been
575assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
576that is actually being assigned to. C<newname> and C<newname_len> are the
577full name of the GV. If these last two arguments are omitted, they can be
578inferred from C<oldstash> or C<gv>.
579
580This can also be called with a null first argument and a null C<gv>, to
581indicate that C<oldstash> has been deleted.
582
583This function invalidates isa caches on the old stash, on all subpackages
584nested inside it, and on the subclasses of all those, including
585non-existent packages that have corresponding entries in C<stash>.
c8bbf675
FC
586
587=cut
588*/
589void
d056e33c
FC
590Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash,
591 const GV * const gv, const char *newname,
62c1e33f 592 I32 newname_len)
c8bbf675
FC
593{
594 register XPVHV* xhv;
595 register HE *entry;
596 I32 riter = -1;
d056e33c 597 HV *seen = NULL;
62c1e33f
FC
598 /* If newname_len is negative, it is actually the call depth (negated).
599 */
600 const I32 level = newname_len < 0 ? newname_len : 0;
c8bbf675 601
d056e33c
FC
602 assert(stash || oldstash);
603 assert(oldstash || gv || newname);
c8bbf675 604
62c1e33f
FC
605 if(level < -100) return;
606
d056e33c
FC
607 if(!newname && oldstash) {
608 newname = HvNAME_get(oldstash);
609 newname_len = HvNAMELEN_get(oldstash);
610 }
611 if(!newname && gv) {
612 SV * const namesv = sv_newmortal();
62c1e33f 613 STRLEN len;
d056e33c 614 gv_fullname4(namesv, gv, NULL, 0);
62c1e33f
FC
615 newname = SvPV_const(namesv, len);
616 newname_len = len - 2; /* skip trailing :: */
d056e33c 617 }
62c1e33f
FC
618 /* XXX This relies on the fact that package names cannot contain nulls.
619 */
620 if(newname_len < 0) newname_len = strlen(newname);
c8bbf675 621
d056e33c
FC
622 mro_isa_changed_in3((HV *)oldstash, newname, newname_len);
623
624 if(
625 (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
626 ) return;
c8bbf675
FC
627
628 /* This is partly based on code in hv_iternext_flags. We are not call-
629 ing that here, as we want to avoid resetting the hash iterator. */
630
d056e33c
FC
631 /* Skip the entire loop if the hash is empty. */
632 if(oldstash && HvUSEDKEYS(oldstash)) {
633 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 634 seen = (HV *) sv_2mortal((SV *)newHV());
d056e33c
FC
635
636 /* Iterate through entries in the oldstash, calling
637 mro_package_moved(
638 corresponding_entry_in_new_stash, current_entry, ...
639 )
640 meanwhile doing the equivalent of $seen{$key} = 1.
641 */
642
643 while (++riter <= (I32)xhv->xhv_max) {
644 entry = (HvARRAY(oldstash))[riter];
645
646 /* Iterate through the entries in this list */
647 for(; entry; entry = HeNEXT(entry)) {
648 const char* key;
649 I32 len;
650
651 /* If this entry is not a glob, ignore it.
652 Try the next. */
653 if (!isGV(HeVAL(entry))) continue;
654
655 key = hv_iterkey(entry, &len);
656 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
657 HV * const oldsubstash = GvHV(HeVAL(entry));
658 SV ** const stashentry
659 = stash ? hv_fetch(stash, key, len, 0) : NULL;
660 HV *substash;
62c1e33f
FC
661
662 /* Avoid main::main::main::... */
663 if(oldsubstash == oldstash) continue;
664
d056e33c
FC
665 if(
666 stashentry && *stashentry
667 && (substash = GvHV(*stashentry))
668 && HvNAME(substash)
669 )
670 mro_package_moved(
62c1e33f 671 substash, oldsubstash, NULL, NULL, level-1
d056e33c
FC
672 );
673 else if(oldsubstash && HvNAME(oldsubstash))
4f6b8b29
FC
674 mro_package_moved(
675 NULL, oldsubstash, NULL, NULL, level-1
676 );
d056e33c
FC
677
678 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
679 }
680 }
681 }
682 }
c8bbf675
FC
683
684 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
685 if (stash && HvUSEDKEYS(stash)) {
686 xhv = (XPVHV*)SvANY(stash);
687
688 /* Iterate through the new stash, skipping $seen{$key} items,
689 calling mro_package_moved(entry, NULL, ...). */
c8bbf675
FC
690 while (++riter <= (I32)xhv->xhv_max) {
691 entry = (HvARRAY(stash))[riter];
692
693 /* Iterate through the entries in this list */
694 for(; entry; entry = HeNEXT(entry)) {
695 const char* key;
696 I32 len;
697
698 /* If this entry is not a glob, ignore it.
699 Try the next. */
700 if (!isGV(HeVAL(entry))) continue;
701
702 key = hv_iterkey(entry, &len);
703 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
d056e33c
FC
704 HV *substash;
705
706 /* If this entry was seen when we iterated through the
707 oldstash, skip it. */
708 if(seen && hv_exists(seen, key, len)) continue;
709
710 /* We get here only if this stash has no corresponding
711 entry in the stash being replaced. */
712
713 substash = GvHV(HeVAL(entry));
714 if(substash && HvNAME(substash)) {
62c1e33f
FC
715 SV *namesv;
716
717 /* Avoid checking main::main::main::... */
718 if(substash == stash) continue;
719
d056e33c
FC
720 /* Add :: and the key (minus the trailing ::)
721 to newname. */
62c1e33f 722 namesv
d056e33c
FC
723 = newSVpvn_flags(newname, newname_len, SVs_TEMP);
724 sv_catpvs(namesv, "::");
725 sv_catpvn(namesv, key, len-2);
726 mro_package_moved(
727 substash, NULL, NULL,
62c1e33f
FC
728 SvPV_nolen_const(namesv),
729 level-1
d056e33c
FC
730 );
731 }
c8bbf675
FC
732 }
733 }
734 }
735 }
d056e33c 736
c8bbf675
FC
737}
738
739/*
e1a479c5
BB
740=for apidoc mro_method_changed_in
741
47c9dd14
BB
742Invalidates method caching on any child classes
743of the given stash, so that they might notice
744the changes in this one.
e1a479c5
BB
745
746Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
747perl source outside of C<mro.c> should be
748replaced by calls to this.
749
750Perl automatically handles most of the common
751ways a method might be redefined. However, there
752are a few ways you could change a method in a stash
753without the cache code noticing, in which case you
754need to call this method afterwards:
e1a479c5 755
dd69841b
BB
7561) Directly manipulating the stash HV entries from
757XS code.
e1a479c5 758
dd69841b
BB
7592) Assigning a reference to a readonly scalar
760constant into a stash entry in order to create
761a constant subroutine (like constant.pm
762does).
763
764This same method is available from pure perl
765via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
766
767=cut
768*/
769void
770Perl_mro_method_changed_in(pTHX_ HV *stash)
771{
1e05feb3
AL
772 const char * const stashname = HvNAME_get(stash);
773 const STRLEN stashname_len = HvNAMELEN_get(stash);
dd69841b 774
1e05feb3 775 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 776 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 777
7918f24d
NC
778 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
779
2c7f4b87
BB
780 if(!stashname)
781 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
782
70cd14a1
CB
783 /* Inc the package generation, since a local method changed */
784 HvMROMETA(stash)->pkg_gen++;
785
e1a479c5
BB
786 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
787 invalidate all method caches globally */
dd69841b
BB
788 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
789 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
790 PL_sub_generation++;
791 return;
792 }
793
794 /* else, invalidate the method caches of all child classes,
795 but not itself */
dd69841b 796 if(isarev) {
1e05feb3
AL
797 HE* iter;
798
e1a479c5
BB
799 hv_iterinit(isarev);
800 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
801 I32 len;
802 const char* const revkey = hv_iterkey(iter, &len);
803 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
804 struct mro_meta* mrometa;
805
806 if(!revstash) continue;
807 mrometa = HvMROMETA(revstash);
dd69841b 808 mrometa->cache_gen++;
e1a479c5
BB
809 if(mrometa->mro_nextmethod)
810 hv_clear(mrometa->mro_nextmethod);
811 }
812 }
813}
814
31b9005d
NC
815void
816Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
817{
818 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
819
820 PERL_ARGS_ASSERT_MRO_SET_MRO;
821
822 if (!which)
823 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
824
825 if(meta->mro_which != which) {
9953ff72 826 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
827 /* If we were storing something directly, put it in the hash before
828 we lose it. */
829 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 830 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
831 }
832 meta->mro_which = which;
833 /* Scrub our cached pointer to the private data. */
3a6fa573 834 meta->mro_linear_current = NULL;
31b9005d
NC
835 /* Only affects local method cache, not
836 even child classes */
837 meta->cache_gen++;
838 if(meta->mro_nextmethod)
839 hv_clear(meta->mro_nextmethod);
840 }
841}
842
e1a479c5
BB
843#include "XSUB.h"
844
e1a479c5 845XS(XS_mro_method_changed_in);
e1a479c5
BB
846
847void
848Perl_boot_core_mro(pTHX)
849{
850 dVAR;
851 static const char file[] = __FILE__;
852
a3e6e81e 853 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 854
e1a479c5 855 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
856}
857
e1a479c5
BB
858XS(XS_mro_method_changed_in)
859{
860 dVAR;
861 dXSARGS;
862 SV* classname;
863 HV* class_stash;
864
e1a479c5 865 if(items != 1)
afa74d42 866 croak_xs_usage(cv, "classname");
e1a479c5
BB
867
868 classname = ST(0);
869
870 class_stash = gv_stashsv(classname, 0);
871 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
872
873 mro_method_changed_in(class_stash);
874
875 XSRETURN_EMPTY;
876}
877
e1a479c5
BB
878/*
879 * Local variables:
880 * c-indentation-style: bsd
881 * c-basic-offset: 4
882 * indent-tabs-mode: t
883 * End:
884 *
885 * ex: set ts=8 sts=4 sw=4 noet:
886 */