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