This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Optimisation of the use of the meta structure - don't create a hash if all we
[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
e1a479c5
BB
622#include "XSUB.h"
623
624XS(XS_mro_get_linear_isa);
625XS(XS_mro_set_mro);
626XS(XS_mro_get_mro);
627XS(XS_mro_get_isarev);
628XS(XS_mro_is_universal);
c5860d66 629XS(XS_mro_invalidate_method_caches);
e1a479c5 630XS(XS_mro_method_changed_in);
70cd14a1 631XS(XS_mro_get_pkg_gen);
e1a479c5
BB
632
633void
634Perl_boot_core_mro(pTHX)
635{
636 dVAR;
637 static const char file[] = __FILE__;
638
a3e6e81e 639 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 640
e1a479c5
BB
641 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
642 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
643 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
644 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
645 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
c5860d66 646 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
e1a479c5 647 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
70cd14a1 648 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
e1a479c5
BB
649}
650
651XS(XS_mro_get_linear_isa) {
652 dVAR;
653 dXSARGS;
654 AV* RETVAL;
655 HV* class_stash;
656 SV* classname;
657
e1a479c5 658 if(items < 1 || items > 2)
afa74d42 659 croak_xs_usage(cv, "classname [, type ]");
e1a479c5
BB
660
661 classname = ST(0);
662 class_stash = gv_stashsv(classname, 0);
e1a479c5 663
70cd14a1
CB
664 if(!class_stash) {
665 /* No stash exists yet, give them just the classname */
666 AV* isalin = newAV();
667 av_push(isalin, newSVsv(classname));
ad64d0ec 668 ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
70cd14a1
CB
669 XSRETURN(1);
670 }
671 else if(items > 1) {
a3e6e81e 672 const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
3d76853f 673 if (!algo)
a3e6e81e 674 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
84dccb35 675 RETVAL = algo->resolve(aTHX_ class_stash, 0);
e1a479c5
BB
676 }
677 else {
678 RETVAL = mro_get_linear_isa(class_stash);
679 }
680
ad64d0ec 681 ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
e1a479c5
BB
682 sv_2mortal(ST(0));
683 XSRETURN(1);
684}
685
686XS(XS_mro_set_mro)
687{
688 dVAR;
689 dXSARGS;
690 SV* classname;
3d76853f 691 const struct mro_alg *which;
e1a479c5
BB
692 HV* class_stash;
693 struct mro_meta* meta;
694
e1a479c5 695 if (items != 2)
afa74d42 696 croak_xs_usage(cv, "classname, type");
e1a479c5
BB
697
698 classname = ST(0);
e1a479c5
BB
699 class_stash = gv_stashsv(classname, GV_ADD);
700 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
701 meta = HvMROMETA(class_stash);
702
a3e6e81e 703 which = Perl_mro_get_from_name(aTHX_ ST(1));
3d76853f 704 if (!which)
a3e6e81e 705 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
e1a479c5
BB
706
707 if(meta->mro_which != which) {
553e831a
NC
708 if (meta->mro_linear_c3 && !meta->mro_linear_dfs) {
709 /* If we were storing something directly, put it in the hash before
710 we lose it. */
711 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
712 MUTABLE_SV(meta->mro_linear_c3));
713 }
714 meta->mro_which = which;
fa60396f
NC
715 /* Scrub our cached pointer to the private data. */
716 meta->mro_linear_c3 = NULL;
e1a479c5
BB
717 /* Only affects local method cache, not
718 even child classes */
dd69841b 719 meta->cache_gen++;
e1a479c5
BB
720 if(meta->mro_nextmethod)
721 hv_clear(meta->mro_nextmethod);
722 }
723
724 XSRETURN_EMPTY;
725}
726
727
728XS(XS_mro_get_mro)
729{
730 dVAR;
731 dXSARGS;
732 SV* classname;
733 HV* class_stash;
e1a479c5 734
e1a479c5 735 if (items != 1)
afa74d42 736 croak_xs_usage(cv, "classname");
e1a479c5
BB
737
738 classname = ST(0);
739 class_stash = gv_stashsv(classname, 0);
e1a479c5 740
3d76853f
NC
741 ST(0) = sv_2mortal(newSVpv(class_stash
742 ? HvMROMETA(class_stash)->mro_which->name
743 : "dfs", 0));
e1a479c5
BB
744 XSRETURN(1);
745}
746
747XS(XS_mro_get_isarev)
748{
749 dVAR;
750 dXSARGS;
751 SV* classname;
73968c7a 752 HE* he;
e1a479c5 753 HV* isarev;
70cd14a1 754 AV* ret_array;
e1a479c5 755
e1a479c5 756 if (items != 1)
afa74d42 757 croak_xs_usage(cv, "classname");
e1a479c5
BB
758
759 classname = ST(0);
760
e1a479c5 761 SP -= items;
dd69841b 762
70cd14a1 763
73968c7a 764 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
85fbaab2 765 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
70cd14a1
CB
766
767 ret_array = newAV();
dd69841b 768 if(isarev) {
e1a479c5
BB
769 HE* iter;
770 hv_iterinit(isarev);
771 while((iter = hv_iternext(isarev)))
70cd14a1 772 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
e1a479c5 773 }
ad64d0ec 774 mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
e1a479c5
BB
775
776 PUTBACK;
777 return;
778}
779
780XS(XS_mro_is_universal)
781{
782 dVAR;
783 dXSARGS;
784 SV* classname;
dd69841b 785 HV* isarev;
70cd14a1
CB
786 char* classname_pv;
787 STRLEN classname_len;
73968c7a 788 HE* he;
e1a479c5 789
e1a479c5 790 if (items != 1)
afa74d42 791 croak_xs_usage(cv, "classname");
e1a479c5
BB
792
793 classname = ST(0);
e1a479c5 794
cfff9797 795 classname_pv = SvPV(classname,classname_len);
dd69841b 796
73968c7a 797 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
85fbaab2 798 isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
dd69841b 799
70cd14a1 800 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
dd69841b 801 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
9edc5bb8
RGS
802 XSRETURN_YES;
803 else
804 XSRETURN_NO;
e1a479c5
BB
805}
806
c5860d66 807XS(XS_mro_invalidate_method_caches)
e1a479c5
BB
808{
809 dVAR;
810 dXSARGS;
811
e1a479c5 812 if (items != 0)
afa74d42 813 croak_xs_usage(cv, "");
e1a479c5
BB
814
815 PL_sub_generation++;
816
817 XSRETURN_EMPTY;
818}
819
e1a479c5
BB
820XS(XS_mro_method_changed_in)
821{
822 dVAR;
823 dXSARGS;
824 SV* classname;
825 HV* class_stash;
826
e1a479c5 827 if(items != 1)
afa74d42 828 croak_xs_usage(cv, "classname");
e1a479c5
BB
829
830 classname = ST(0);
831
832 class_stash = gv_stashsv(classname, 0);
833 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
834
835 mro_method_changed_in(class_stash);
836
837 XSRETURN_EMPTY;
838}
839
70cd14a1
CB
840XS(XS_mro_get_pkg_gen)
841{
842 dVAR;
843 dXSARGS;
844 SV* classname;
845 HV* class_stash;
846
70cd14a1 847 if(items != 1)
afa74d42 848 croak_xs_usage(cv, "classname");
70cd14a1
CB
849
850 classname = ST(0);
851
852 class_stash = gv_stashsv(classname, 0);
853
854 SP -= items;
855
6e449a3a 856 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
70cd14a1
CB
857
858 PUTBACK;
859 return;
860}
861
e1a479c5
BB
862/*
863 * Local variables:
864 * c-indentation-style: bsd
865 * c-basic-offset: 4
866 * indent-tabs-mode: t
867 * End:
868 *
869 * ex: set ts=8 sts=4 sw=4 noet:
870 */