This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Merge B::GV::{STASH,GvFLAGS} into the common accessor.
[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
00169e2c
FC
218 stashhek
219 = HvAUX(stash)->xhv_name && HvENAME_HEK_NN(stash)
220 ? HvENAME_HEK_NN(stash)
221 : HvNAME_HEK(stash);
222
190d0b22 223 if (!stashhek)
1e05feb3 224 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
225
226 if (level > 100)
227 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 228 HEK_KEY(stashhek));
e1a479c5
BB
229
230 meta = HvMROMETA(stash);
1c908217
RGS
231
232 /* return cache if valid */
a3e6e81e 233 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
e1a479c5
BB
234 return retval;
235 }
236
237 /* not in cache, make a new one */
1c908217 238
ad64d0ec 239 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
a49ba3fc
NC
240 /* We use this later in this function, but don't need a reference to it
241 beyond the end of this function, so reference count is fine. */
242 our_name = newSVhek(stashhek);
243 av_push(retval, our_name); /* add ourselves at the top */
e1a479c5 244
1c908217 245 /* fetch our @ISA */
e1a479c5
BB
246 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
247 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
248
a49ba3fc
NC
249 /* "stored" is used to keep track of all of the classnames we have added to
250 the MRO so far, so we can do a quick exists check and avoid adding
251 duplicate classnames to the MRO as we go.
252 It's then retained to be re-used as a fast lookup for ->isa(), by adding
253 our own name and "UNIVERSAL" to it. */
254
a49ba3fc 255 if(av && AvFILLp(av) >= 0) {
1c908217 256
ffd8da72
NC
257 SV **svp = AvARRAY(av);
258 I32 items = AvFILLp(av) + 1;
1c908217
RGS
259
260 /* foreach(@ISA) */
e1a479c5
BB
261 while (items--) {
262 SV* const sv = *svp++;
263 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
264 SV *const *subrv_p;
265 I32 subrv_items;
e1a479c5
BB
266
267 if (!basestash) {
1c908217
RGS
268 /* if no stash exists for this @ISA member,
269 simply add it to the MRO and move on */
ffd8da72
NC
270 subrv_p = &sv;
271 subrv_items = 1;
e1a479c5
BB
272 }
273 else {
1c908217 274 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
275 of this @ISA member, and append their MRO to ours.
276 The recursive call could throw an exception, which
277 has memory management implications here, hence the use of
278 the mortal. */
ffd8da72
NC
279 const AV *const subrv
280 = mro_get_linear_isa_dfs(basestash, level + 1);
281
282 subrv_p = AvARRAY(subrv);
283 subrv_items = AvFILLp(subrv) + 1;
284 }
73519bd0
NC
285 if (stored) {
286 while(subrv_items--) {
287 SV *const subsv = *subrv_p++;
288 /* LVALUE fetch will create a new undefined SV if necessary
289 */
290 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
291 assert(he);
292 if(HeVAL(he) != &PL_sv_undef) {
293 /* It was newly created. Steal it for our new SV, and
294 replace it in the hash with the "real" thing. */
295 SV *const val = HeVAL(he);
296 HEK *const key = HeKEY_hek(he);
297
298 HeVAL(he) = &PL_sv_undef;
299 /* Save copying by making a shared hash key scalar. We
300 inline this here rather than calling
301 Perl_newSVpvn_share because we already have the
302 scalar, and we already have the hash key. */
303 assert(SvTYPE(val) == SVt_NULL);
304 sv_upgrade(val, SVt_PV);
305 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
306 SvCUR_set(val, HEK_LEN(key));
307 SvREADONLY_on(val);
308 SvFAKE_on(val);
309 SvPOK_on(val);
310 if (HEK_UTF8(key))
311 SvUTF8_on(val);
312
313 av_push(retval, val);
314 }
ffd8da72 315 }
73519bd0
NC
316 } else {
317 /* We are the first (or only) parent. We can short cut the
318 complexity above, because our @ISA is simply us prepended
319 to our parent's @ISA, and our ->isa cache is simply our
320 parent's, with our name added. */
321 /* newSVsv() is slow. This code is only faster if we can avoid
322 it by ensuring that SVs in the arrays are shared hash key
323 scalar SVs, because we can "copy" them very efficiently.
324 Although to be fair, we can't *ensure* this, as a reference
325 to the internal array is returned by mro::get_linear_isa(),
326 so we'll have to be defensive just in case someone faffed
327 with it. */
328 if (basestash) {
329 SV **svp;
17eef65c 330 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
73519bd0
NC
331 av_extend(retval, subrv_items);
332 AvFILLp(retval) = subrv_items;
333 svp = AvARRAY(retval);
334 while(subrv_items--) {
335 SV *const val = *subrv_p++;
336 *++svp = SvIsCOW_shared_hash(val)
337 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
338 : newSVsv(val);
339 }
340 } else {
341 /* They have no stash. So create ourselves an ->isa cache
342 as if we'd copied it from what theirs should be. */
343 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
344 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
345 av_push(retval,
346 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
347 &PL_sv_undef, 0))));
348 }
349 }
e1a479c5 350 }
73519bd0
NC
351 } else {
352 /* We have no parents. */
353 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
354 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
e1a479c5
BB
355 }
356
ed09b296 357 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
ed09b296
NC
358
359 SvREFCNT_inc_simple_void_NN(stored);
360 SvTEMP_off(stored);
361 SvREADONLY_on(stored);
362
363 meta->isa = stored;
364
0fd7ece8
NC
365 /* now that we're past the exception dangers, grab our own reference to
366 the AV we're about to use for the result. The reference owned by the
367 mortals' stack will be released soon, so everything will balance. */
368 SvREFCNT_inc_simple_void_NN(retval);
369 SvTEMP_off(retval);
fdef73f9 370
1c908217
RGS
371 /* we don't want anyone modifying the cache entry but us,
372 and we do so by replacing it completely */
e1a479c5 373 SvREADONLY_on(retval);
1c908217 374
a3e6e81e 375 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
fa60396f 376 MUTABLE_SV(retval)));
e1a479c5
BB
377}
378
379/*
e1a479c5
BB
380=for apidoc mro_get_linear_isa
381
382Returns either C<mro_get_linear_isa_c3> or
383C<mro_get_linear_isa_dfs> for the given stash,
384dependant upon which MRO is in effect
385for that stash. The return value is a
386read-only AV*.
387
1c908217
RGS
388You are responsible for C<SvREFCNT_inc()> on the
389return value if you plan to store it anywhere
390semi-permanently (otherwise it might be deleted
391out from under you the next time the cache is
392invalidated).
393
e1a479c5
BB
394=cut
395*/
396AV*
397Perl_mro_get_linear_isa(pTHX_ HV *stash)
398{
399 struct mro_meta* meta;
2c7f4b87 400
7918f24d 401 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
402 if(!SvOOK(stash))
403 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
404
405 meta = HvMROMETA(stash);
3d76853f 406 if (!meta->mro_which)
14f97ce6 407 Perl_croak(aTHX_ "panic: invalid MRO!");
3d76853f 408 return meta->mro_which->resolve(aTHX_ stash, 0);
e1a479c5
BB
409}
410
411/*
412=for apidoc mro_isa_changed_in
413
1c908217 414Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
415when the @ISA of the given package has changed. Invoked
416by the C<setisa> magic, should not need to invoke directly.
417
6f86b615
FC
418=for apidoc mro_isa_changed_in3
419
420Takes the necessary steps (cache invalidations, mostly)
421when the @ISA of the given package has changed. Invoked
422by the C<setisa> magic, should not need to invoke directly.
423
424The stash can be passed as the first argument, or its name and length as
425the second and third (or both). If just the name is passed and the stash
426does not exist, then only the subclasses' method and isa caches will be
427invalidated.
428
e1a479c5
BB
429=cut
430*/
431void
6f86b615
FC
432Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
433 STRLEN stashname_len)
e1a479c5
BB
434{
435 dVAR;
436 HV* isarev;
437 AV* linear_mro;
438 HE* iter;
439 SV** svp;
440 I32 items;
1e05feb3 441 bool is_universal;
6f86b615 442 struct mro_meta * meta = NULL;
e1a479c5 443
6f86b615 444 if(!stashname && stash) {
00169e2c
FC
445 stashname = HvENAME_get(stash);
446 stashname_len = HvENAMELEN_get(stash);
6f86b615
FC
447 }
448 else if(!stash)
449 stash = gv_stashpvn(stashname, stashname_len, 0 /* don't add */);
7918f24d 450
2c7f4b87
BB
451 if(!stashname)
452 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
453
6f86b615
FC
454 if(stash) {
455 /* wipe out the cached linearizations for this stash */
456 meta = HvMROMETA(stash);
457 if (meta->mro_linear_all) {
9953ff72
NC
458 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
459 meta->mro_linear_all = NULL;
553e831a 460 /* This is just acting as a shortcut pointer. */
3a6fa573 461 meta->mro_linear_current = NULL;
6f86b615 462 } else if (meta->mro_linear_current) {
553e831a 463 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
464 SvREFCNT_dec(meta->mro_linear_current);
465 meta->mro_linear_current = NULL;
6f86b615
FC
466 }
467 if (meta->isa) {
5782d502
NC
468 SvREFCNT_dec(meta->isa);
469 meta->isa = NULL;
6f86b615 470 }
e1a479c5 471
6f86b615
FC
472 /* Inc the package generation, since our @ISA changed */
473 meta->pkg_gen++;
474 }
70cd14a1 475
e1a479c5
BB
476 /* Wipe the global method cache if this package
477 is UNIVERSAL or one of its parents */
dd69841b
BB
478
479 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 480 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
481
482 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
483 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 484 PL_sub_generation++;
dd69841b
BB
485 is_universal = TRUE;
486 }
1e05feb3 487 else { /* Wipe the local method cache otherwise */
6f86b615 488 if(meta) meta->cache_gen++;
1e05feb3
AL
489 is_universal = FALSE;
490 }
e1a479c5
BB
491
492 /* wipe next::method cache too */
6f86b615 493 if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 494
e1a479c5 495 /* Iterate the isarev (classes that are our children),
1375cf1c 496 wiping out their linearization, method and isa caches */
dd69841b 497 if(isarev) {
e1a479c5
BB
498 hv_iterinit(isarev);
499 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
500 I32 len;
501 const char* const revkey = hv_iterkey(iter, &len);
502 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
503 struct mro_meta* revmeta;
504
505 if(!revstash) continue;
506 revmeta = HvMROMETA(revstash);
9953ff72
NC
507 if (revmeta->mro_linear_all) {
508 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
509 revmeta->mro_linear_all = NULL;
553e831a 510 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
511 revmeta->mro_linear_current = NULL;
512 } else if (revmeta->mro_linear_current) {
553e831a 513 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
514 SvREFCNT_dec(revmeta->mro_linear_current);
515 revmeta->mro_linear_current = NULL;
553e831a 516 }
dd69841b
BB
517 if(!is_universal)
518 revmeta->cache_gen++;
e1a479c5
BB
519 if(revmeta->mro_nextmethod)
520 hv_clear(revmeta->mro_nextmethod);
1375cf1c
NC
521 if (revmeta->isa) {
522 SvREFCNT_dec(revmeta->isa);
523 revmeta->isa = NULL;
524 }
e1a479c5
BB
525 }
526 }
527
1c908217
RGS
528 /* Now iterate our MRO (parents), and do a few things:
529 1) instantiate with the "fake" flag if they don't exist
530 2) flag them as universal if we are universal
531 3) Add everything from our isarev to their isarev
532 */
533
6f86b615
FC
534 /* This only applies if the stash exists. */
535 if(!stash) return;
536
1c908217 537 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
538 linear_mro = mro_get_linear_isa(stash);
539 svp = AvARRAY(linear_mro) + 1;
540 items = AvFILLp(linear_mro);
1c908217 541
e1a479c5
BB
542 while (items--) {
543 SV* const sv = *svp++;
e1a479c5
BB
544 HV* mroisarev;
545
117b69ca
NC
546 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
547
548 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
549 us, then will need to upgrade it to an HV (which sv_upgrade() can
550 now do for us. */
117b69ca 551
85fbaab2 552 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 553
ad64d0ec 554 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 555
25270bc0
NC
556 /* This hash only ever contains PL_sv_yes. Storing it over itself is
557 almost as cheap as calling hv_exists, so on aggregate we expect to
558 save time by not making two calls to the common HV code for the
559 case where it doesn't exist. */
560
04fe65b0 561 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
562
563 if(isarev) {
564 hv_iterinit(isarev);
565 while((iter = hv_iternext(isarev))) {
dd69841b 566 I32 revkeylen;
1e05feb3 567 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 568 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
569 }
570 }
571 }
572}
573
574/*
c8bbf675
FC
575=for apidoc mro_package_moved
576
d056e33c
FC
577Call this function to signal to a stash that it has been assigned to
578another spot in the stash hierarchy. C<stash> is the stash that has been
579assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
580that is actually being assigned to. C<newname> and C<newname_len> are the
581full name of the GV. If these last two arguments are omitted, they can be
35759254 582inferred from C<gv>. C<gv> can be omitted if C<newname> is given.
d056e33c 583
35759254 584This can also be called with a null first argument to
d056e33c
FC
585indicate that C<oldstash> has been deleted.
586
587This function invalidates isa caches on the old stash, on all subpackages
588nested inside it, and on the subclasses of all those, including
589non-existent packages that have corresponding entries in C<stash>.
c8bbf675
FC
590
591=cut
592*/
593void
35759254
FC
594Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
595 const GV *gv, const char *newname,
62c1e33f 596 I32 newname_len)
c8bbf675
FC
597{
598 register XPVHV* xhv;
599 register HE *entry;
600 I32 riter = -1;
d056e33c 601 HV *seen = NULL;
35759254 602 HV *seen_stashes = NULL;
c8bbf675 603
35759254
FC
604 /* If newname_len is negative, then gv is actually the caller’s hash of
605 stashes that have been seen so far. */
62c1e33f 606
35759254
FC
607 assert(stash || oldstash);
608 assert((gv && newname_len >= 0) || newname);
609
610 if(newname_len < 0) seen_stashes = (HV *)gv, gv = NULL;
611
612 /* Determine the name of the location that stash was assigned to
613 * or from which oldstash was removed.
614 *
615 * We cannot reliable use the name in oldstash, because it may have
616 * been deleted from the location in the symbol table that its name
617 * suggests, as in this case:
618 *
619 * $globref = \*foo::bar::;
620 * Symbol::delete_package("foo");
621 * *$globref = \%baz::;
622 * *$globref = *frelp::;
623 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
624 *
625 * If newname is not null, then we trust that the caller gave us the
626 * right name. Otherwise, we get it from the gv. But if the gv is not
627 * in the symbol table, then we just return.
628 */
d056e33c
FC
629 if(!newname && gv) {
630 SV * const namesv = sv_newmortal();
62c1e33f 631 STRLEN len;
d056e33c 632 gv_fullname4(namesv, gv, NULL, 0);
35759254 633 if(gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv) return;
62c1e33f
FC
634 newname = SvPV_const(namesv, len);
635 newname_len = len - 2; /* skip trailing :: */
d056e33c 636 }
35759254 637 if(newname_len < 0) newname_len = -newname_len;
c8bbf675 638
d056e33c
FC
639 mro_isa_changed_in3((HV *)oldstash, newname, newname_len);
640
641 if(
642 (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
35759254 643 ) goto set_names;
c8bbf675
FC
644
645 /* This is partly based on code in hv_iternext_flags. We are not call-
646 ing that here, as we want to avoid resetting the hash iterator. */
647
d056e33c
FC
648 /* Skip the entire loop if the hash is empty. */
649 if(oldstash && HvUSEDKEYS(oldstash)) {
650 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 651 seen = (HV *) sv_2mortal((SV *)newHV());
35759254 652 if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
d056e33c
FC
653
654 /* Iterate through entries in the oldstash, calling
655 mro_package_moved(
656 corresponding_entry_in_new_stash, current_entry, ...
657 )
658 meanwhile doing the equivalent of $seen{$key} = 1.
659 */
660
661 while (++riter <= (I32)xhv->xhv_max) {
662 entry = (HvARRAY(oldstash))[riter];
663
664 /* Iterate through the entries in this list */
665 for(; entry; entry = HeNEXT(entry)) {
666 const char* key;
667 I32 len;
668
669 /* If this entry is not a glob, ignore it.
670 Try the next. */
671 if (!isGV(HeVAL(entry))) continue;
672
673 key = hv_iterkey(entry, &len);
674 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
675 HV * const oldsubstash = GvHV(HeVAL(entry));
676 SV ** const stashentry
677 = stash ? hv_fetch(stash, key, len, 0) : NULL;
35759254 678 HV *substash = NULL;
62c1e33f
FC
679
680 /* Avoid main::main::main::... */
681 if(oldsubstash == oldstash) continue;
35759254
FC
682 if(oldsubstash) {
683 HE * const entry
684 = (HE *)
685 hv_common(
686 seen_stashes, NULL,
687 (const char *)&oldsubstash, sizeof(HV *), 0,
688 HV_FETCH_LVALUE, NULL, 0
689 );
690 if(HeVAL(entry) == &PL_sv_yes) continue;
691 HeVAL(entry) = &PL_sv_yes;
692 }
62c1e33f 693
d056e33c 694 if(
35759254
FC
695 (
696 stashentry && *stashentry
697 && (substash = GvHV(*stashentry))
698 )
00169e2c 699 || (oldsubstash && HvENAME_get(oldsubstash))
d056e33c 700 )
35759254
FC
701 {
702 /* Add :: and the key (minus the trailing ::)
703 to newname. */
704 SV *namesv
705 = newSVpvn_flags(newname, newname_len, SVs_TEMP);
706 const char *name;
707 STRLEN namlen;
708 sv_catpvs(namesv, "::");
709 sv_catpvn(namesv, key, len-2);
710 name = SvPV_const(namesv, namlen);
d056e33c 711 mro_package_moved(
35759254
FC
712 substash, oldsubstash,
713 (GV *)seen_stashes, name, -namlen
4f6b8b29 714 );
35759254 715 }
d056e33c
FC
716
717 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
718 }
719 }
720 }
721 }
c8bbf675
FC
722
723 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
724 if (stash && HvUSEDKEYS(stash)) {
725 xhv = (XPVHV*)SvANY(stash);
35759254 726 if(!seen_stashes) seen_stashes = (HV *) sv_2mortal((SV *)newHV());
d056e33c
FC
727
728 /* Iterate through the new stash, skipping $seen{$key} items,
729 calling mro_package_moved(entry, NULL, ...). */
c8bbf675
FC
730 while (++riter <= (I32)xhv->xhv_max) {
731 entry = (HvARRAY(stash))[riter];
732
733 /* Iterate through the entries in this list */
734 for(; entry; entry = HeNEXT(entry)) {
735 const char* key;
736 I32 len;
737
738 /* If this entry is not a glob, ignore it.
739 Try the next. */
740 if (!isGV(HeVAL(entry))) continue;
741
742 key = hv_iterkey(entry, &len);
743 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
d056e33c
FC
744 HV *substash;
745
746 /* If this entry was seen when we iterated through the
747 oldstash, skip it. */
748 if(seen && hv_exists(seen, key, len)) continue;
749
750 /* We get here only if this stash has no corresponding
751 entry in the stash being replaced. */
752
753 substash = GvHV(HeVAL(entry));
35759254 754 if(substash) {
62c1e33f 755 SV *namesv;
35759254
FC
756 const char *name;
757 STRLEN namlen;
758 HE *entry;
62c1e33f
FC
759
760 /* Avoid checking main::main::main::... */
761 if(substash == stash) continue;
35759254
FC
762 entry
763 = (HE *)
764 hv_common(
765 seen_stashes, NULL,
766 (const char *)&substash, sizeof(HV *), 0,
767 HV_FETCH_LVALUE, NULL, 0
768 );
769 if(HeVAL(entry) == &PL_sv_yes) continue;
770 HeVAL(entry) = &PL_sv_yes;
62c1e33f 771
d056e33c
FC
772 /* Add :: and the key (minus the trailing ::)
773 to newname. */
62c1e33f 774 namesv
d056e33c
FC
775 = newSVpvn_flags(newname, newname_len, SVs_TEMP);
776 sv_catpvs(namesv, "::");
777 sv_catpvn(namesv, key, len-2);
35759254 778 name = SvPV_const(namesv, namlen);
d056e33c 779 mro_package_moved(
35759254 780 substash, NULL, (GV *)seen_stashes, name, -namlen
d056e33c
FC
781 );
782 }
c8bbf675
FC
783 }
784 }
785 }
786 }
d056e33c 787
35759254 788 set_names:
00169e2c 789 if(oldstash && HvENAME_get(oldstash)) {
35759254
FC
790 if(PL_stashcache)
791 (void)
792 hv_delete(PL_stashcache, newname, newname_len, G_DISCARD);
78b79c77 793 hv_ename_delete(oldstash, newname, newname_len);
35759254 794 }
78b79c77 795 if(stash) hv_ename_add(stash, newname, newname_len);
c8bbf675
FC
796}
797
798/*
e1a479c5
BB
799=for apidoc mro_method_changed_in
800
47c9dd14
BB
801Invalidates method caching on any child classes
802of the given stash, so that they might notice
803the changes in this one.
e1a479c5
BB
804
805Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
806perl source outside of C<mro.c> should be
807replaced by calls to this.
808
809Perl automatically handles most of the common
810ways a method might be redefined. However, there
811are a few ways you could change a method in a stash
812without the cache code noticing, in which case you
813need to call this method afterwards:
e1a479c5 814
dd69841b
BB
8151) Directly manipulating the stash HV entries from
816XS code.
e1a479c5 817
dd69841b
BB
8182) Assigning a reference to a readonly scalar
819constant into a stash entry in order to create
820a constant subroutine (like constant.pm
821does).
822
823This same method is available from pure perl
824via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
825
826=cut
827*/
828void
829Perl_mro_method_changed_in(pTHX_ HV *stash)
830{
00169e2c
FC
831 const char * const stashname = HvENAME_get(stash);
832 const STRLEN stashname_len = HvENAMELEN_get(stash);
dd69841b 833
1e05feb3 834 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 835 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 836
7918f24d
NC
837 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
838
2c7f4b87
BB
839 if(!stashname)
840 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
841
70cd14a1
CB
842 /* Inc the package generation, since a local method changed */
843 HvMROMETA(stash)->pkg_gen++;
844
e1a479c5
BB
845 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
846 invalidate all method caches globally */
dd69841b
BB
847 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
848 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
849 PL_sub_generation++;
850 return;
851 }
852
853 /* else, invalidate the method caches of all child classes,
854 but not itself */
dd69841b 855 if(isarev) {
1e05feb3
AL
856 HE* iter;
857
e1a479c5
BB
858 hv_iterinit(isarev);
859 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
860 I32 len;
861 const char* const revkey = hv_iterkey(iter, &len);
862 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
863 struct mro_meta* mrometa;
864
865 if(!revstash) continue;
866 mrometa = HvMROMETA(revstash);
dd69841b 867 mrometa->cache_gen++;
e1a479c5
BB
868 if(mrometa->mro_nextmethod)
869 hv_clear(mrometa->mro_nextmethod);
870 }
871 }
872}
873
31b9005d
NC
874void
875Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
876{
877 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
878
879 PERL_ARGS_ASSERT_MRO_SET_MRO;
880
881 if (!which)
882 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
883
884 if(meta->mro_which != which) {
9953ff72 885 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
886 /* If we were storing something directly, put it in the hash before
887 we lose it. */
888 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 889 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
890 }
891 meta->mro_which = which;
892 /* Scrub our cached pointer to the private data. */
3a6fa573 893 meta->mro_linear_current = NULL;
31b9005d
NC
894 /* Only affects local method cache, not
895 even child classes */
896 meta->cache_gen++;
897 if(meta->mro_nextmethod)
898 hv_clear(meta->mro_nextmethod);
899 }
900}
901
e1a479c5
BB
902#include "XSUB.h"
903
e1a479c5 904XS(XS_mro_method_changed_in);
e1a479c5
BB
905
906void
907Perl_boot_core_mro(pTHX)
908{
909 dVAR;
910 static const char file[] = __FILE__;
911
a3e6e81e 912 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 913
e1a479c5 914 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
915}
916
e1a479c5
BB
917XS(XS_mro_method_changed_in)
918{
919 dVAR;
920 dXSARGS;
921 SV* classname;
922 HV* class_stash;
923
e1a479c5 924 if(items != 1)
afa74d42 925 croak_xs_usage(cv, "classname");
e1a479c5
BB
926
927 classname = ST(0);
928
929 class_stash = gv_stashsv(classname, 0);
930 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
931
932 mro_method_changed_in(class_stash);
933
934 XSRETURN_EMPTY;
935}
936
e1a479c5
BB
937/*
938 * Local variables:
939 * c-indentation-style: bsd
940 * c-basic-offset: 4
941 * indent-tabs-mode: t
942 * End:
943 *
944 * ex: set ts=8 sts=4 sw=4 noet:
945 */