This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Break out the set-the-MRO logic from the XS_mro_set_mro into Perl_mro_set_mro(),
[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
40 data = Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
41 which->name, which->length, which->kflags,
42 HV_FETCH_JUST_SV, NULL, which->hash);
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)
49 smeta->mro_linear_c3 = MUTABLE_AV(*data);
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
fa60396f 60 if (!smeta->mro_linear_dfs) {
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. */
65 smeta->mro_linear_c3 = MUTABLE_AV(data);
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;
71 smeta->mro_linear_dfs = MUTABLE_AV(hv);
72
73 if (smeta->mro_linear_c3) {
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,
77 MUTABLE_SV(smeta->mro_linear_c3));
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. */
88 smeta->mro_linear_c3 = MUTABLE_AV(data);
fa60396f
NC
89 }
90
91 if (!Perl_hv_common(aTHX_ MUTABLE_HV(smeta->mro_linear_dfs), NULL,
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
108 data = Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
109 HV_FETCH_JUST_SV, NULL, 0);
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
553e831a 163 if (newmeta->mro_linear_dfs) {
33e12d9d 164 newmeta->mro_linear_dfs
ad64d0ec 165 = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_dfs, param)));
553e831a
NC
166 /* This is just acting as a shortcut pointer, and will be automatically
167 updated on the first get. */
168 newmeta->mro_linear_c3 = NULL;
169 } else if (newmeta->mro_linear_c3) {
170 /* Only the current MRO is stored, so this owns the data. */
171 newmeta->mro_linear_c3
172 = MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_linear_c3, param)));
173 }
174
33e12d9d
NC
175 if (newmeta->mro_nextmethod)
176 newmeta->mro_nextmethod
ad64d0ec 177 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->mro_nextmethod, param)));
a49ba3fc
NC
178 if (newmeta->isa)
179 newmeta->isa
ad64d0ec 180 = MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)newmeta->isa, param)));
e1a479c5
BB
181
182 return newmeta;
183}
184
185#endif /* USE_ITHREADS */
186
a49ba3fc
NC
187HV *
188Perl_get_isa_hash(pTHX_ HV *const stash)
189{
190 dVAR;
191 struct mro_meta *const meta = HvMROMETA(stash);
192
193 PERL_ARGS_ASSERT_GET_ISA_HASH;
194
6e4aef59
NC
195 if (!meta->isa) {
196 AV *const isa = mro_get_linear_isa(stash);
197 if (!meta->isa) {
198 HV *const isa_hash = newHV();
199 /* Linearisation didn't build it for us, so do it here. */
200 SV *const *svp = AvARRAY(isa);
201 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
202 const HEK *const canon_name = HvNAME_HEK(stash);
203
204 while (svp < svp_end) {
205 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
206 }
207
208 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
209 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
210 HV_FETCH_ISSTORE, &PL_sv_undef,
211 HEK_HASH(canon_name));
212 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
213
ed09b296
NC
214 SvREADONLY_on(isa_hash);
215
6e4aef59
NC
216 meta->isa = isa_hash;
217 }
218 }
a49ba3fc
NC
219 return meta->isa;
220}
221
e1a479c5
BB
222/*
223=for apidoc mro_get_linear_isa_dfs
224
225Returns the Depth-First Search linearization of @ISA
226the given stash. The return value is a read-only AV*.
227C<level> should be 0 (it is used internally in this
228function's recursion).
229
1c908217
RGS
230You are responsible for C<SvREFCNT_inc()> on the
231return value if you plan to store it anywhere
232semi-permanently (otherwise it might be deleted
233out from under you the next time the cache is
234invalidated).
235
e1a479c5
BB
236=cut
237*/
4befac30 238static AV*
94d1e706 239S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
e1a479c5
BB
240{
241 AV* retval;
242 GV** gvp;
243 GV* gv;
244 AV* av;
190d0b22 245 const HEK* stashhek;
e1a479c5 246 struct mro_meta* meta;
a49ba3fc
NC
247 SV *our_name;
248 HV *stored;
e1a479c5 249
7918f24d 250 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
e1a479c5
BB
251 assert(HvAUX(stash));
252
190d0b22
NC
253 stashhek = HvNAME_HEK(stash);
254 if (!stashhek)
1e05feb3 255 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
256
257 if (level > 100)
258 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 259 HEK_KEY(stashhek));
e1a479c5
BB
260
261 meta = HvMROMETA(stash);
1c908217
RGS
262
263 /* return cache if valid */
a3e6e81e 264 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
e1a479c5
BB
265 return retval;
266 }
267
268 /* not in cache, make a new one */
1c908217 269
ad64d0ec 270 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
a49ba3fc
NC
271 /* We use this later in this function, but don't need a reference to it
272 beyond the end of this function, so reference count is fine. */
273 our_name = newSVhek(stashhek);
274 av_push(retval, our_name); /* add ourselves at the top */
e1a479c5 275
1c908217 276 /* fetch our @ISA */
e1a479c5
BB
277 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
278 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
279
a49ba3fc
NC
280 /* "stored" is used to keep track of all of the classnames we have added to
281 the MRO so far, so we can do a quick exists check and avoid adding
282 duplicate classnames to the MRO as we go.
283 It's then retained to be re-used as a fast lookup for ->isa(), by adding
284 our own name and "UNIVERSAL" to it. */
285
ad64d0ec 286 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
1c908217 287
a49ba3fc 288 if(av && AvFILLp(av) >= 0) {
1c908217 289
ffd8da72
NC
290 SV **svp = AvARRAY(av);
291 I32 items = AvFILLp(av) + 1;
1c908217
RGS
292
293 /* foreach(@ISA) */
e1a479c5
BB
294 while (items--) {
295 SV* const sv = *svp++;
296 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
297 SV *const *subrv_p;
298 I32 subrv_items;
e1a479c5
BB
299
300 if (!basestash) {
1c908217
RGS
301 /* if no stash exists for this @ISA member,
302 simply add it to the MRO and move on */
ffd8da72
NC
303 subrv_p = &sv;
304 subrv_items = 1;
e1a479c5
BB
305 }
306 else {
1c908217 307 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
308 of this @ISA member, and append their MRO to ours.
309 The recursive call could throw an exception, which
310 has memory management implications here, hence the use of
311 the mortal. */
ffd8da72
NC
312 const AV *const subrv
313 = mro_get_linear_isa_dfs(basestash, level + 1);
314
315 subrv_p = AvARRAY(subrv);
316 subrv_items = AvFILLp(subrv) + 1;
317 }
318 while(subrv_items--) {
319 SV *const subsv = *subrv_p++;
8e45cc2b
NC
320 /* LVALUE fetch will create a new undefined SV if necessary
321 */
322 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
323 assert(he);
324 if(HeVAL(he) != &PL_sv_undef) {
325 /* It was newly created. Steal it for our new SV, and
326 replace it in the hash with the "real" thing. */
327 SV *const val = HeVAL(he);
f46ee248 328 HEK *const key = HeKEY_hek(he);
8e45cc2b
NC
329
330 HeVAL(he) = &PL_sv_undef;
f46ee248
NC
331 /* Save copying by making a shared hash key scalar. We
332 inline this here rather than calling Perl_newSVpvn_share
333 because we already have the scalar, and we already have
334 the hash key. */
335 assert(SvTYPE(val) == SVt_NULL);
336 sv_upgrade(val, SVt_PV);
337 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
338 SvCUR_set(val, HEK_LEN(key));
339 SvREADONLY_on(val);
340 SvFAKE_on(val);
341 SvPOK_on(val);
342 if (HEK_UTF8(key))
343 SvUTF8_on(val);
344
8e45cc2b 345 av_push(retval, val);
ffd8da72 346 }
e1a479c5
BB
347 }
348 }
349 }
350
ed09b296
NC
351 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
352 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
353
354 SvREFCNT_inc_simple_void_NN(stored);
355 SvTEMP_off(stored);
356 SvREADONLY_on(stored);
357
358 meta->isa = stored;
359
0fd7ece8
NC
360 /* now that we're past the exception dangers, grab our own reference to
361 the AV we're about to use for the result. The reference owned by the
362 mortals' stack will be released soon, so everything will balance. */
363 SvREFCNT_inc_simple_void_NN(retval);
364 SvTEMP_off(retval);
fdef73f9 365
1c908217
RGS
366 /* we don't want anyone modifying the cache entry but us,
367 and we do so by replacing it completely */
e1a479c5 368 SvREADONLY_on(retval);
1c908217 369
a3e6e81e 370 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
fa60396f 371 MUTABLE_SV(retval)));
e1a479c5
BB
372}
373
374/*
e1a479c5
BB
375=for apidoc mro_get_linear_isa
376
377Returns either C<mro_get_linear_isa_c3> or
378C<mro_get_linear_isa_dfs> for the given stash,
379dependant upon which MRO is in effect
380for that stash. The return value is a
381read-only AV*.
382
1c908217
RGS
383You are responsible for C<SvREFCNT_inc()> on the
384return value if you plan to store it anywhere
385semi-permanently (otherwise it might be deleted
386out from under you the next time the cache is
387invalidated).
388
e1a479c5
BB
389=cut
390*/
391AV*
392Perl_mro_get_linear_isa(pTHX_ HV *stash)
393{
394 struct mro_meta* meta;
2c7f4b87 395
7918f24d 396 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
397 if(!SvOOK(stash))
398 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
399
400 meta = HvMROMETA(stash);
3d76853f 401 if (!meta->mro_which)
14f97ce6 402 Perl_croak(aTHX_ "panic: invalid MRO!");
3d76853f 403 return meta->mro_which->resolve(aTHX_ stash, 0);
e1a479c5
BB
404}
405
406/*
407=for apidoc mro_isa_changed_in
408
1c908217 409Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
410when the @ISA of the given package has changed. Invoked
411by the C<setisa> magic, should not need to invoke directly.
412
413=cut
414*/
415void
416Perl_mro_isa_changed_in(pTHX_ HV* stash)
417{
418 dVAR;
419 HV* isarev;
420 AV* linear_mro;
421 HE* iter;
422 SV** svp;
423 I32 items;
1e05feb3 424 bool is_universal;
2c7f4b87 425 struct mro_meta * meta;
e1a479c5 426
0fa56319
RGS
427 const char * const stashname = HvNAME_get(stash);
428 const STRLEN stashname_len = HvNAMELEN_get(stash);
e1a479c5 429
7918f24d
NC
430 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
431
2c7f4b87
BB
432 if(!stashname)
433 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
434
e1a479c5 435 /* wipe out the cached linearizations for this stash */
2c7f4b87 436 meta = HvMROMETA(stash);
553e831a
NC
437 if (meta->mro_linear_dfs) {
438 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_dfs));
439 meta->mro_linear_dfs = NULL;
440 /* This is just acting as a shortcut pointer. */
441 meta->mro_linear_c3 = NULL;
442 } else if (meta->mro_linear_c3) {
443 /* Only the current MRO is stored, so this owns the data. */
444 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
445 meta->mro_linear_c3 = NULL;
446 }
5782d502
NC
447 if (meta->isa) {
448 SvREFCNT_dec(meta->isa);
449 meta->isa = NULL;
450 }
e1a479c5 451
70cd14a1
CB
452 /* Inc the package generation, since our @ISA changed */
453 meta->pkg_gen++;
454
e1a479c5
BB
455 /* Wipe the global method cache if this package
456 is UNIVERSAL or one of its parents */
dd69841b
BB
457
458 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 459 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
460
461 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
462 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 463 PL_sub_generation++;
dd69841b
BB
464 is_universal = TRUE;
465 }
1e05feb3 466 else { /* Wipe the local method cache otherwise */
dd69841b 467 meta->cache_gen++;
1e05feb3
AL
468 is_universal = FALSE;
469 }
e1a479c5
BB
470
471 /* wipe next::method cache too */
472 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 473
e1a479c5
BB
474 /* Iterate the isarev (classes that are our children),
475 wiping out their linearization and method caches */
dd69841b 476 if(isarev) {
e1a479c5
BB
477 hv_iterinit(isarev);
478 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
479 I32 len;
480 const char* const revkey = hv_iterkey(iter, &len);
481 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
482 struct mro_meta* revmeta;
483
484 if(!revstash) continue;
485 revmeta = HvMROMETA(revstash);
553e831a
NC
486 if (revmeta->mro_linear_dfs) {
487 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_dfs));
488 revmeta->mro_linear_dfs = NULL;
489 /* This is just acting as a shortcut pointer. */
490 revmeta->mro_linear_c3 = NULL;
491 } else if (revmeta->mro_linear_c3) {
492 /* Only the current MRO is stored, so this owns the data. */
493 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
494 revmeta->mro_linear_c3 = NULL;
495 }
dd69841b
BB
496 if(!is_universal)
497 revmeta->cache_gen++;
e1a479c5
BB
498 if(revmeta->mro_nextmethod)
499 hv_clear(revmeta->mro_nextmethod);
500 }
501 }
502
1c908217
RGS
503 /* Now iterate our MRO (parents), and do a few things:
504 1) instantiate with the "fake" flag if they don't exist
505 2) flag them as universal if we are universal
506 3) Add everything from our isarev to their isarev
507 */
508
509 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
510 linear_mro = mro_get_linear_isa(stash);
511 svp = AvARRAY(linear_mro) + 1;
512 items = AvFILLp(linear_mro);
1c908217 513
e1a479c5
BB
514 while (items--) {
515 SV* const sv = *svp++;
e1a479c5
BB
516 HV* mroisarev;
517
117b69ca
NC
518 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
519
520 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
521 us, then will need to upgrade it to an HV (which sv_upgrade() can
522 now do for us. */
117b69ca 523
85fbaab2 524 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 525
ad64d0ec 526 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 527
25270bc0
NC
528 /* This hash only ever contains PL_sv_yes. Storing it over itself is
529 almost as cheap as calling hv_exists, so on aggregate we expect to
530 save time by not making two calls to the common HV code for the
531 case where it doesn't exist. */
532
04fe65b0 533 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
534
535 if(isarev) {
536 hv_iterinit(isarev);
537 while((iter = hv_iternext(isarev))) {
dd69841b 538 I32 revkeylen;
1e05feb3 539 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 540 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
541 }
542 }
543 }
544}
545
546/*
547=for apidoc mro_method_changed_in
548
47c9dd14
BB
549Invalidates method caching on any child classes
550of the given stash, so that they might notice
551the changes in this one.
e1a479c5
BB
552
553Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
554perl source outside of C<mro.c> should be
555replaced by calls to this.
556
557Perl automatically handles most of the common
558ways a method might be redefined. However, there
559are a few ways you could change a method in a stash
560without the cache code noticing, in which case you
561need to call this method afterwards:
e1a479c5 562
dd69841b
BB
5631) Directly manipulating the stash HV entries from
564XS code.
e1a479c5 565
dd69841b
BB
5662) Assigning a reference to a readonly scalar
567constant into a stash entry in order to create
568a constant subroutine (like constant.pm
569does).
570
571This same method is available from pure perl
572via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
573
574=cut
575*/
576void
577Perl_mro_method_changed_in(pTHX_ HV *stash)
578{
1e05feb3
AL
579 const char * const stashname = HvNAME_get(stash);
580 const STRLEN stashname_len = HvNAMELEN_get(stash);
dd69841b 581
1e05feb3 582 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 583 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 584
7918f24d
NC
585 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
586
2c7f4b87
BB
587 if(!stashname)
588 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
589
70cd14a1
CB
590 /* Inc the package generation, since a local method changed */
591 HvMROMETA(stash)->pkg_gen++;
592
e1a479c5
BB
593 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
594 invalidate all method caches globally */
dd69841b
BB
595 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
596 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
597 PL_sub_generation++;
598 return;
599 }
600
601 /* else, invalidate the method caches of all child classes,
602 but not itself */
dd69841b 603 if(isarev) {
1e05feb3
AL
604 HE* iter;
605
e1a479c5
BB
606 hv_iterinit(isarev);
607 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
608 I32 len;
609 const char* const revkey = hv_iterkey(iter, &len);
610 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
611 struct mro_meta* mrometa;
612
613 if(!revstash) continue;
614 mrometa = HvMROMETA(revstash);
dd69841b 615 mrometa->cache_gen++;
e1a479c5
BB
616 if(mrometa->mro_nextmethod)
617 hv_clear(mrometa->mro_nextmethod);
618 }
619 }
620}
621
31b9005d
NC
622void
623Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
624{
625 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
626
627 PERL_ARGS_ASSERT_MRO_SET_MRO;
628
629 if (!which)
630 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
631
632 if(meta->mro_which != which) {
633 if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
634 /* If we were storing something directly, put it in the hash before
635 we lose it. */
636 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
637 MUTABLE_SV(meta->mro_linear_c3));
638 }
639 meta->mro_which = which;
640 /* Scrub our cached pointer to the private data. */
641 meta->mro_linear_c3 = NULL;
642 /* Only affects local method cache, not
643 even child classes */
644 meta->cache_gen++;
645 if(meta->mro_nextmethod)
646 hv_clear(meta->mro_nextmethod);
647 }
648}
649
e1a479c5
BB
650#include "XSUB.h"
651
652XS(XS_mro_get_linear_isa);
653XS(XS_mro_set_mro);
654XS(XS_mro_get_mro);
655XS(XS_mro_get_isarev);
656XS(XS_mro_is_universal);
c5860d66 657XS(XS_mro_invalidate_method_caches);
e1a479c5 658XS(XS_mro_method_changed_in);
70cd14a1 659XS(XS_mro_get_pkg_gen);
e1a479c5
BB
660
661void
662Perl_boot_core_mro(pTHX)
663{
664 dVAR;
665 static const char file[] = __FILE__;
666
a3e6e81e 667 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 668
e1a479c5
BB
669 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
670 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
671 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
672 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
673 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
c5860d66 674 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
e1a479c5 675 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
70cd14a1 676 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
e1a479c5
BB
677}
678
679XS(XS_mro_get_linear_isa) {
680 dVAR;
681 dXSARGS;
682 AV* RETVAL;
683 HV* class_stash;
684 SV* classname;
685
e1a479c5 686 if(items < 1 || items > 2)
afa74d42 687 croak_xs_usage(cv, "classname [, type ]");
e1a479c5
BB
688
689 classname = ST(0);
690 class_stash = gv_stashsv(classname, 0);
e1a479c5 691
70cd14a1
CB
692 if(!class_stash) {
693 /* No stash exists yet, give them just the classname */
694 AV* isalin = newAV();
695 av_push(isalin, newSVsv(classname));
ad64d0ec 696 ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
70cd14a1
CB
697 XSRETURN(1);
698 }
699 else if(items > 1) {
a3e6e81e 700 const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
3d76853f 701 if (!algo)
a3e6e81e 702 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
84dccb35 703 RETVAL = algo->resolve(aTHX_ class_stash, 0);
e1a479c5
BB
704 }
705 else {
706 RETVAL = mro_get_linear_isa(class_stash);
707 }
708
ad64d0ec 709 ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
e1a479c5
BB
710 sv_2mortal(ST(0));
711 XSRETURN(1);
712}
713
714XS(XS_mro_set_mro)
715{
716 dVAR;
717 dXSARGS;
718 SV* classname;
e1a479c5
BB
719 HV* class_stash;
720 struct mro_meta* meta;
721
e1a479c5 722 if (items != 2)
afa74d42 723 croak_xs_usage(cv, "classname, type");
e1a479c5
BB
724
725 classname = ST(0);
e1a479c5
BB
726 class_stash = gv_stashsv(classname, GV_ADD);
727 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
728 meta = HvMROMETA(class_stash);
729
31b9005d 730 Perl_mro_set_mro(aTHX_ meta, ST(1));
e1a479c5
BB
731
732 XSRETURN_EMPTY;
733}
734
735
736XS(XS_mro_get_mro)
737{
738 dVAR;
739 dXSARGS;
740 SV* classname;
741 HV* class_stash;
e1a479c5 742
e1a479c5 743 if (items != 1)
afa74d42 744 croak_xs_usage(cv, "classname");
e1a479c5
BB
745
746 classname = ST(0);
747 class_stash = gv_stashsv(classname, 0);
e1a479c5 748
3d76853f
NC
749 ST(0) = sv_2mortal(newSVpv(class_stash
750 ? HvMROMETA(class_stash)->mro_which->name
751 : "dfs", 0));
e1a479c5
BB
752 XSRETURN(1);
753}
754
755XS(XS_mro_get_isarev)
756{
757 dVAR;
758 dXSARGS;
759 SV* classname;
73968c7a 760 HE* he;
e1a479c5 761 HV* isarev;
70cd14a1 762 AV* ret_array;
e1a479c5 763
e1a479c5 764 if (items != 1)
afa74d42 765 croak_xs_usage(cv, "classname");
e1a479c5
BB
766
767 classname = ST(0);
768
e1a479c5 769 SP -= items;
dd69841b 770
70cd14a1 771
73968c7a 772 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
85fbaab2 773 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
70cd14a1
CB
774
775 ret_array = newAV();
dd69841b 776 if(isarev) {
e1a479c5
BB
777 HE* iter;
778 hv_iterinit(isarev);
779 while((iter = hv_iternext(isarev)))
70cd14a1 780 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
e1a479c5 781 }
ad64d0ec 782 mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
e1a479c5
BB
783
784 PUTBACK;
785 return;
786}
787
788XS(XS_mro_is_universal)
789{
790 dVAR;
791 dXSARGS;
792 SV* classname;
dd69841b 793 HV* isarev;
70cd14a1
CB
794 char* classname_pv;
795 STRLEN classname_len;
73968c7a 796 HE* he;
e1a479c5 797
e1a479c5 798 if (items != 1)
afa74d42 799 croak_xs_usage(cv, "classname");
e1a479c5
BB
800
801 classname = ST(0);
e1a479c5 802
cfff9797 803 classname_pv = SvPV(classname,classname_len);
dd69841b 804
73968c7a 805 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
85fbaab2 806 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
dd69841b 807
70cd14a1 808 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
dd69841b 809 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
9edc5bb8
RGS
810 XSRETURN_YES;
811 else
812 XSRETURN_NO;
e1a479c5
BB
813}
814
c5860d66 815XS(XS_mro_invalidate_method_caches)
e1a479c5
BB
816{
817 dVAR;
818 dXSARGS;
819
e1a479c5 820 if (items != 0)
afa74d42 821 croak_xs_usage(cv, "");
e1a479c5
BB
822
823 PL_sub_generation++;
824
825 XSRETURN_EMPTY;
826}
827
e1a479c5
BB
828XS(XS_mro_method_changed_in)
829{
830 dVAR;
831 dXSARGS;
832 SV* classname;
833 HV* class_stash;
834
e1a479c5 835 if(items != 1)
afa74d42 836 croak_xs_usage(cv, "classname");
e1a479c5
BB
837
838 classname = ST(0);
839
840 class_stash = gv_stashsv(classname, 0);
841 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
842
843 mro_method_changed_in(class_stash);
844
845 XSRETURN_EMPTY;
846}
847
70cd14a1
CB
848XS(XS_mro_get_pkg_gen)
849{
850 dVAR;
851 dXSARGS;
852 SV* classname;
853 HV* class_stash;
854
70cd14a1 855 if(items != 1)
afa74d42 856 croak_xs_usage(cv, "classname");
70cd14a1
CB
857
858 classname = ST(0);
859
860 class_stash = gv_stashsv(classname, 0);
861
862 SP -= items;
863
6e449a3a 864 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
70cd14a1
CB
865
866 PUTBACK;
867 return;
868}
869
e1a479c5
BB
870/*
871 * Local variables:
872 * c-indentation-style: bsd
873 * c-basic-offset: 4
874 * indent-tabs-mode: t
875 * End:
876 *
877 * ex: set ts=8 sts=4 sw=4 noet:
878 */