This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Increase File::stat’s version
[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;
7311f41d 400 AV *isa;
2c7f4b87 401
7918f24d 402 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
403 if(!SvOOK(stash))
404 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
405
406 meta = HvMROMETA(stash);
3d76853f 407 if (!meta->mro_which)
14f97ce6 408 Perl_croak(aTHX_ "panic: invalid MRO!");
7311f41d
FC
409 isa = meta->mro_which->resolve(aTHX_ stash, 0);
410
411 if (!meta->isa) {
412 HV *const isa_hash = newHV();
413 /* Linearisation didn't build it for us, so do it here. */
414 SV *const *svp = AvARRAY(isa);
415 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
416 const HEK *canon_name = HvENAME_HEK(stash);
417 if (!canon_name) canon_name = HvNAME_HEK(stash);
418
419 while (svp < svp_end) {
420 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
421 }
422
423 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
424 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
425 HV_FETCH_ISSTORE, &PL_sv_undef,
426 HEK_HASH(canon_name));
427 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
428
429 SvREADONLY_on(isa_hash);
430
431 meta->isa = isa_hash;
432 }
433
434 return isa;
e1a479c5
BB
435}
436
437/*
438=for apidoc mro_isa_changed_in
439
1c908217 440Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
441when the @ISA of the given package has changed. Invoked
442by the C<setisa> magic, should not need to invoke directly.
443
6f86b615
FC
444=for apidoc mro_isa_changed_in3
445
446Takes the necessary steps (cache invalidations, mostly)
447when the @ISA of the given package has changed. Invoked
448by the C<setisa> magic, should not need to invoke directly.
449
450The stash can be passed as the first argument, or its name and length as
451the second and third (or both). If just the name is passed and the stash
452does not exist, then only the subclasses' method and isa caches will be
453invalidated.
454
e1a479c5
BB
455=cut
456*/
457void
6f86b615
FC
458Perl_mro_isa_changed_in3(pTHX_ HV* stash, const char *stashname,
459 STRLEN stashname_len)
e1a479c5
BB
460{
461 dVAR;
462 HV* isarev;
463 AV* linear_mro;
464 HE* iter;
465 SV** svp;
466 I32 items;
1e05feb3 467 bool is_universal;
6f86b615 468 struct mro_meta * meta = NULL;
80ebaca2 469 HV *isa = NULL;
e1a479c5 470
6f86b615 471 if(!stashname && stash) {
00169e2c
FC
472 stashname = HvENAME_get(stash);
473 stashname_len = HvENAMELEN_get(stash);
6f86b615
FC
474 }
475 else if(!stash)
476 stash = gv_stashpvn(stashname, stashname_len, 0 /* don't add */);
7918f24d 477
2c7f4b87
BB
478 if(!stashname)
479 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
480
6f86b615
FC
481 if(stash) {
482 /* wipe out the cached linearizations for this stash */
483 meta = HvMROMETA(stash);
484 if (meta->mro_linear_all) {
9953ff72
NC
485 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
486 meta->mro_linear_all = NULL;
553e831a 487 /* This is just acting as a shortcut pointer. */
3a6fa573 488 meta->mro_linear_current = NULL;
6f86b615 489 } else if (meta->mro_linear_current) {
553e831a 490 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
491 SvREFCNT_dec(meta->mro_linear_current);
492 meta->mro_linear_current = NULL;
6f86b615
FC
493 }
494 if (meta->isa) {
80ebaca2
FC
495 /* Steal it for our own purposes. */
496 isa = (HV *)sv_2mortal((SV *)meta->isa);
5782d502 497 meta->isa = NULL;
6f86b615 498 }
e1a479c5 499
6f86b615
FC
500 /* Inc the package generation, since our @ISA changed */
501 meta->pkg_gen++;
502 }
70cd14a1 503
e1a479c5
BB
504 /* Wipe the global method cache if this package
505 is UNIVERSAL or one of its parents */
dd69841b
BB
506
507 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 508 isarev = svp ? MUTABLE_HV(*svp) : NULL;
dd69841b
BB
509
510 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
511 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 512 PL_sub_generation++;
dd69841b
BB
513 is_universal = TRUE;
514 }
1e05feb3 515 else { /* Wipe the local method cache otherwise */
6f86b615 516 if(meta) meta->cache_gen++;
1e05feb3
AL
517 is_universal = FALSE;
518 }
e1a479c5
BB
519
520 /* wipe next::method cache too */
6f86b615 521 if(meta && meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 522
e1a479c5 523 /* Iterate the isarev (classes that are our children),
80ebaca2
FC
524 wiping out their linearization, method and isa caches
525 and upating PL_isarev. */
dd69841b 526 if(isarev) {
80ebaca2
FC
527 HV *isa_hashes = NULL;
528
529 /* We have to iterate through isarev twice to avoid a chicken and
530 * egg problem: if A inherits from B and both are in isarev, A might
531 * be processed before B and use B’s previous linearisation.
532 */
533
534 /* First iteration: Wipe everything, but stash away the isa hashes
535 * since we still need them for updating PL_isarev.
536 */
537
538 if(hv_iterinit(isarev)) {
539 /* Only create the hash if we need it; i.e., if isarev has
540 any elements. */
541 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
542 }
e1a479c5 543 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
544 I32 len;
545 const char* const revkey = hv_iterkey(iter, &len);
546 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
547 struct mro_meta* revmeta;
548
549 if(!revstash) continue;
550 revmeta = HvMROMETA(revstash);
9953ff72
NC
551 if (revmeta->mro_linear_all) {
552 SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_all));
553 revmeta->mro_linear_all = NULL;
553e831a 554 /* This is just acting as a shortcut pointer. */
3a6fa573
NC
555 revmeta->mro_linear_current = NULL;
556 } else if (revmeta->mro_linear_current) {
553e831a 557 /* Only the current MRO is stored, so this owns the data. */
3a6fa573
NC
558 SvREFCNT_dec(revmeta->mro_linear_current);
559 revmeta->mro_linear_current = NULL;
553e831a 560 }
dd69841b
BB
561 if(!is_universal)
562 revmeta->cache_gen++;
e1a479c5
BB
563 if(revmeta->mro_nextmethod)
564 hv_clear(revmeta->mro_nextmethod);
80ebaca2
FC
565
566 (void)
567 hv_store(
568 isa_hashes, (const char*)&revstash, sizeof(HV *),
569 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
570 );
571 revmeta->isa = NULL;
572 }
573
574 /* Second pass: Update PL_isarev. We can just use isa_hashes to
575 * avoid another round of stash lookups. */
576
577 /* isarev might be deleted from PL_isarev during this loop, so hang
578 * on to it. */
579 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
580
581 if(isa_hashes) {
582 hv_iterinit(isa_hashes);
583 while((iter = hv_iternext(isa_hashes))) {
584 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
585 HV * const isa = (HV *)HeVAL(iter);
586 const HEK *namehek;
587
588 /* Re-calculate the linearisation, unless a previous iter-
589 ation was for a subclass of this class. */
590 if(!HvMROMETA(revstash)->isa)
591 (void)mro_get_linear_isa(revstash);
592
593 /* We're starting at the 2nd element, skipping revstash */
594 linear_mro = mro_get_linear_isa(revstash);
595 svp = AvARRAY(linear_mro) + 1;
596 items = AvFILLp(linear_mro);
597
598 namehek = HvENAME_HEK(revstash);
599 if (!namehek) namehek = HvNAME_HEK(revstash);
600
601 while (items--) {
602 SV* const sv = *svp++;
603 HV* mroisarev;
604
605 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
606
607 /* That fetch should not fail. But if it had to create
608 a new SV for us, then will need to upgrade it to an
609 HV (which sv_upgrade() can now do for us). */
610
611 mroisarev = MUTABLE_HV(HeVAL(he));
612
613 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
614
615 /* This hash only ever contains PL_sv_yes. Storing it
616 over itself is almost as cheap as calling hv_exists,
617 so on aggregate we expect to save time by not making
618 two calls to the common HV code for the case where
619 it doesn't exist. */
620
621 (void)
622 hv_store(
623 mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
624 &PL_sv_yes, 0
625 );
626 }
627
628 if((SV *)isa != &PL_sv_undef)
629 mro_clean_isarev(
630 isa, HEK_KEY(namehek), HEK_LEN(namehek),
631 HvMROMETA(revstash)->isa
632 );
633 }
e1a479c5
BB
634 }
635 }
636
c9143745
FC
637 /* Now iterate our MRO (parents), adding ourselves and everything from
638 our isarev to their isarev.
1c908217
RGS
639 */
640
6f86b615 641 /* This only applies if the stash exists. */
80ebaca2 642 if(!stash) goto clean_up_isarev;
6f86b615 643
1c908217 644 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
645 linear_mro = mro_get_linear_isa(stash);
646 svp = AvARRAY(linear_mro) + 1;
647 items = AvFILLp(linear_mro);
1c908217 648
e1a479c5
BB
649 while (items--) {
650 SV* const sv = *svp++;
e1a479c5
BB
651 HV* mroisarev;
652
117b69ca
NC
653 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
654
655 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
656 us, then will need to upgrade it to an HV (which sv_upgrade() can
657 now do for us. */
117b69ca 658
85fbaab2 659 mroisarev = MUTABLE_HV(HeVAL(he));
e1a479c5 660
ad64d0ec 661 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
117b69ca 662
25270bc0
NC
663 /* This hash only ever contains PL_sv_yes. Storing it over itself is
664 almost as cheap as calling hv_exists, so on aggregate we expect to
665 save time by not making two calls to the common HV code for the
666 case where it doesn't exist. */
667
04fe65b0 668 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
80ebaca2
FC
669 }
670
671 clean_up_isarev:
672 /* Delete our name from our former parents’ isarevs. */
673 if(isa && HvARRAY(isa))
674 mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
675}
676
677/* Deletes name from all the isarev entries listed in isa */
678STATIC void
679S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
680 const STRLEN len, HV * const exceptions)
681{
682 HE* iter;
e1a479c5 683
80ebaca2
FC
684 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
685
686 /* Delete our name from our former parents’ isarevs. */
687 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
688 SV **svp;
689 while((iter = hv_iternext(isa))) {
690 I32 klen;
691 const char * const key = hv_iterkey(iter, &klen);
692 if(exceptions && hv_exists(exceptions, key, klen)) continue;
693 svp = hv_fetch(PL_isarev, key, klen, 0);
694 if(svp) {
695 HV * const isarev = (HV *)*svp;
696 (void)hv_delete(isarev, name, len, G_DISCARD);
697 if(!HvARRAY(isarev) || !HvKEYS(isarev))
698 (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
e1a479c5
BB
699 }
700 }
701 }
702}
703
704/*
c8bbf675
FC
705=for apidoc mro_package_moved
706
d056e33c
FC
707Call this function to signal to a stash that it has been assigned to
708another spot in the stash hierarchy. C<stash> is the stash that has been
709assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
710that is actually being assigned to. C<newname> and C<newname_len> are the
711full name of the GV. If these last two arguments are omitted, they can be
35759254 712inferred from C<gv>. C<gv> can be omitted if C<newname> is given.
d056e33c 713
35759254 714This can also be called with a null first argument to
d056e33c
FC
715indicate that C<oldstash> has been deleted.
716
717This function invalidates isa caches on the old stash, on all subpackages
718nested inside it, and on the subclasses of all those, including
719non-existent packages that have corresponding entries in C<stash>.
c8bbf675 720
80ebaca2
FC
721It also sets the effective names (C<HvENAME>) on all the stashes as
722appropriate.
723
c8bbf675
FC
724=cut
725*/
726void
35759254
FC
727Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
728 const GV *gv, const char *newname,
62c1e33f 729 I32 newname_len)
c8bbf675 730{
80ebaca2
FC
731 HV *stashes;
732 HE* iter;
62c1e33f 733
35759254 734 assert(stash || oldstash);
80ebaca2 735 assert(gv || newname);
35759254
FC
736
737 /* Determine the name of the location that stash was assigned to
738 * or from which oldstash was removed.
739 *
928eb066 740 * We cannot reliably use the name in oldstash, because it may have
35759254
FC
741 * been deleted from the location in the symbol table that its name
742 * suggests, as in this case:
743 *
744 * $globref = \*foo::bar::;
745 * Symbol::delete_package("foo");
746 * *$globref = \%baz::;
747 * *$globref = *frelp::;
748 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
749 *
750 * If newname is not null, then we trust that the caller gave us the
751 * right name. Otherwise, we get it from the gv. But if the gv is not
752 * in the symbol table, then we just return.
753 */
d056e33c
FC
754 if(!newname && gv) {
755 SV * const namesv = sv_newmortal();
62c1e33f 756 STRLEN len;
d056e33c 757 gv_fullname4(namesv, gv, NULL, 0);
35759254 758 if(gv_fetchsv(namesv, GV_NOADD_NOINIT, SVt_PVGV) != gv) return;
62c1e33f
FC
759 newname = SvPV_const(namesv, len);
760 newname_len = len - 2; /* skip trailing :: */
d056e33c 761 }
35759254 762 if(newname_len < 0) newname_len = -newname_len;
c8bbf675 763
80ebaca2
FC
764 /* Get a list of all the affected classes. */
765 /* We cannot simply pass them all to mro_isa_changed_in to avoid
766 the list, as that function assumes that only one package has
767 changed. It does not work with:
768
769 @foo::ISA = qw( B B::B );
770 *B:: = delete $::{"A::"};
771
772 as neither B nor B::B can be updated before the other, since they
773 will reset caches on foo, which will see either B or B::B with the
774 wrong name. The names must be set on *all* affected stashes before
775 we do anything else.
776 */
777 stashes = (HV *) sv_2mortal((SV *)newHV());
778 mro_gather_and_rename(stashes, stash, oldstash, newname, newname_len);
779
780 /* Iterate through the stashes, wiping isa linearisations, but leaving
781 the isa hash (which mro_isa_changed_in needs for adjusting the
782 isarev hashes belonging to parent classes). */
783 hv_iterinit(stashes);
784 while((iter = hv_iternext(stashes))) {
785 if(HeVAL(iter) != &PL_sv_yes && HvENAME(HeVAL(iter))) {
786 struct mro_meta* meta;
787 meta = HvMROMETA((HV *)HeVAL(iter));
788 if (meta->mro_linear_all) {
789 SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_all));
790 meta->mro_linear_all = NULL;
791 /* This is just acting as a shortcut pointer. */
792 meta->mro_linear_current = NULL;
793 } else if (meta->mro_linear_current) {
794 /* Only the current MRO is stored, so this owns the data. */
795 SvREFCNT_dec(meta->mro_linear_current);
796 meta->mro_linear_current = NULL;
797 }
798 }
799 }
800
801 /* Once the caches have been wiped on all the classes, call
802 mro_isa_changed_in on each. */
803 hv_iterinit(stashes);
804 while((iter = hv_iternext(stashes))) {
805 if(HeVAL(iter) != &PL_sv_yes && HvENAME(HeVAL(iter)))
806 mro_isa_changed_in((HV *)HeVAL(iter));
807 /* We are not holding a refcount, so eliminate the pointer before
808 * stashes is freed. */
809 HeVAL(iter) = NULL;
810 }
811}
812
813void
814S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *stash, HV *oldstash,
815 const char *name, I32 namlen)
816{
817 register XPVHV* xhv;
818 register HE *entry;
819 I32 riter = -1;
820 const bool stash_had_name = stash && HvENAME(stash);
821 HV *seen = NULL;
822 HV *isarev = NULL;
823 SV **svp;
824
825 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
826
827 if(oldstash) {
828 /* Add to the big list. */
829 HE * const entry
830 = (HE *)
831 hv_common(
832 stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
df5f182b 833 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2
FC
834 );
835 if(HeVAL(entry) == (SV *)oldstash) {
836 oldstash = NULL;
837 goto check_stash;
838 }
839 HeVAL(entry) = (SV *)oldstash;
840
841 /* Update the effective name. */
842 if(HvENAME_get(oldstash)) {
843 const HEK * const enamehek = HvENAME_HEK(oldstash);
844 if(PL_stashcache)
d7fbb1de 845 (void)
80ebaca2
FC
846 hv_delete(PL_stashcache, name, namlen, G_DISCARD);
847 hv_ename_delete(oldstash, name, namlen);
848
849 /* If the name deletion caused a name change, then we are not
850 * going to call mro_isa_changed_in with this name (and not at all
851 * if it has become anonymous) so we need to delete old isarev
852 * entries here, both those in the superclasses and this class’s
853 * own list of subclasses. We simply delete the latter from
854 * from PL_isarev, since we still need it. hv_delete mortifies it
855 * for us, so sv_2mortal is not necessary. */
856 if(HvENAME_HEK(oldstash) != enamehek) {
857 const struct mro_meta * meta = HvMROMETA(oldstash);
858 if(meta->isa && HvARRAY(meta->isa))
859 mro_clean_isarev(meta->isa, name, namlen, NULL);
860 isarev = (HV *)hv_delete(PL_isarev, name, namlen, 0);
861 }
862 }
d7fbb1de 863 }
80ebaca2 864 check_stash:
8b9e80a3 865 if(stash) {
80ebaca2
FC
866 hv_ename_add(stash, name, namlen);
867
868 /* Add it to the big list. We use the stash itself as the value if
869 * it needs mro_isa_changed_in called on it. Otherwise we just use
870 * &PL_sv_yes to indicate that we have seen it. */
871
872 /* The stash needs mro_isa_changed_in called on it if it was
873 * detached from the symbol table (so it had no HvENAME) before
874 * being assigned to the spot named by the ‘name’ variable, because
875 * its cached isa linerisation is now stale (the effective name
876 * having changed), and subclasses will then use that cache when
877 * mro_package_moved calls mro_isa_changed_in. (See
8b9e80a3 878 * [perl #77358].)
80ebaca2 879 *
8b9e80a3 880 * If it did have a name, then its previous name is still
80ebaca2
FC
881 * used in isa caches, and there is no need for
882 * mro_package_moved to call mro_isa_changed_in.
8b9e80a3 883 */
80ebaca2
FC
884
885 entry
886 = (HE *)
887 hv_common(
888 stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
df5f182b 889 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2
FC
890 );
891 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == (SV *)stash)
892 stash = NULL;
893 else HeVAL(entry) = stash_had_name ? &PL_sv_yes : (SV *)stash;
8b9e80a3 894 }
d7fbb1de 895
80ebaca2
FC
896 if(!stash && !oldstash)
897 /* Both stashes have been encountered already. */
898 return;
899
900 /* Add all the subclasses to the big list. */
901 if(
902 isarev
903 || (
904 (svp = hv_fetch(PL_isarev, name, namlen, 0))
905 && (isarev = MUTABLE_HV(*svp))
906 )
907 ) {
908 HE *iter;
909 hv_iterinit(isarev);
910 while((iter = hv_iternext(isarev))) {
911 I32 len;
912 const char* const revkey = hv_iterkey(iter, &len);
913 HV* revstash = gv_stashpvn(revkey, len, 0);
914
915 if(!revstash) continue;
916 entry
917 = (HE *)
918 hv_common(
919 stashes, NULL, (const char *)&revstash, sizeof(HV *), 0,
df5f182b 920 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
80ebaca2
FC
921 );
922 HeVAL(entry) = (SV *)revstash;
923
924 }
925 }
d056e33c
FC
926
927 if(
928 (!stash || !HvARRAY(stash)) && (!oldstash || !HvARRAY(oldstash))
d7fbb1de 929 ) return;
c8bbf675
FC
930
931 /* This is partly based on code in hv_iternext_flags. We are not call-
932 ing that here, as we want to avoid resetting the hash iterator. */
933
d056e33c
FC
934 /* Skip the entire loop if the hash is empty. */
935 if(oldstash && HvUSEDKEYS(oldstash)) {
936 xhv = (XPVHV*)SvANY(oldstash);
dbe2fffc 937 seen = (HV *) sv_2mortal((SV *)newHV());
d056e33c 938
80ebaca2
FC
939 /* Iterate through entries in the oldstash, adding them to the
940 list, meanwhile doing the equivalent of $seen{$key} = 1.
d056e33c
FC
941 */
942
943 while (++riter <= (I32)xhv->xhv_max) {
944 entry = (HvARRAY(oldstash))[riter];
945
946 /* Iterate through the entries in this list */
947 for(; entry; entry = HeNEXT(entry)) {
948 const char* key;
949 I32 len;
950
951 /* If this entry is not a glob, ignore it.
952 Try the next. */
953 if (!isGV(HeVAL(entry))) continue;
954
955 key = hv_iterkey(entry, &len);
956 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
957 HV * const oldsubstash = GvHV(HeVAL(entry));
958 SV ** const stashentry
959 = stash ? hv_fetch(stash, key, len, 0) : NULL;
35759254 960 HV *substash = NULL;
62c1e33f
FC
961
962 /* Avoid main::main::main::... */
963 if(oldsubstash == oldstash) continue;
964
d056e33c 965 if(
35759254
FC
966 (
967 stashentry && *stashentry
968 && (substash = GvHV(*stashentry))
969 )
00169e2c 970 || (oldsubstash && HvENAME_get(oldsubstash))
d056e33c 971 )
35759254
FC
972 {
973 /* Add :: and the key (minus the trailing ::)
974 to newname. */
975 SV *namesv
80ebaca2
FC
976 = newSVpvn_flags(name, namlen, SVs_TEMP);
977 {
978 const char *name;
979 STRLEN namlen;
980 sv_catpvs(namesv, "::");
981 sv_catpvn(namesv, key, len-2);
982 name = SvPV_const(namesv, namlen);
983 mro_gather_and_rename(
984 stashes, substash, oldsubstash, name, namlen
985 );
986 }
35759254 987 }
d056e33c
FC
988
989 (void)hv_store(seen, key, len, &PL_sv_yes, 0);
990 }
991 }
992 }
993 }
c8bbf675
FC
994
995 /* Skip the entire loop if the hash is empty. */
d056e33c
FC
996 if (stash && HvUSEDKEYS(stash)) {
997 xhv = (XPVHV*)SvANY(stash);
998
999 /* Iterate through the new stash, skipping $seen{$key} items,
80ebaca2 1000 calling mro_gather_and_rename(stashes, entry, NULL, ...). */
c8bbf675
FC
1001 while (++riter <= (I32)xhv->xhv_max) {
1002 entry = (HvARRAY(stash))[riter];
1003
1004 /* Iterate through the entries in this list */
1005 for(; entry; entry = HeNEXT(entry)) {
1006 const char* key;
1007 I32 len;
1008
1009 /* If this entry is not a glob, ignore it.
1010 Try the next. */
1011 if (!isGV(HeVAL(entry))) continue;
1012
1013 key = hv_iterkey(entry, &len);
1014 if(len > 1 && key[len-2] == ':' && key[len-1] == ':') {
d056e33c
FC
1015 HV *substash;
1016
1017 /* If this entry was seen when we iterated through the
1018 oldstash, skip it. */
1019 if(seen && hv_exists(seen, key, len)) continue;
1020
1021 /* We get here only if this stash has no corresponding
1022 entry in the stash being replaced. */
1023
1024 substash = GvHV(HeVAL(entry));
35759254 1025 if(substash) {
62c1e33f 1026 SV *namesv;
80ebaca2
FC
1027 const char *subname;
1028 STRLEN subnamlen;
62c1e33f
FC
1029
1030 /* Avoid checking main::main::main::... */
1031 if(substash == stash) continue;
1032
d056e33c
FC
1033 /* Add :: and the key (minus the trailing ::)
1034 to newname. */
62c1e33f 1035 namesv
80ebaca2 1036 = newSVpvn_flags(name, namlen, SVs_TEMP);
d056e33c
FC
1037 sv_catpvs(namesv, "::");
1038 sv_catpvn(namesv, key, len-2);
80ebaca2
FC
1039 subname = SvPV_const(namesv, subnamlen);
1040 mro_gather_and_rename(
1041 stashes, substash, NULL, subname, subnamlen
d056e33c
FC
1042 );
1043 }
c8bbf675
FC
1044 }
1045 }
1046 }
1047 }
1048}
1049
1050/*
e1a479c5
BB
1051=for apidoc mro_method_changed_in
1052
47c9dd14
BB
1053Invalidates method caching on any child classes
1054of the given stash, so that they might notice
1055the changes in this one.
e1a479c5
BB
1056
1057Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
1058perl source outside of C<mro.c> should be
1059replaced by calls to this.
1060
1061Perl automatically handles most of the common
1062ways a method might be redefined. However, there
1063are a few ways you could change a method in a stash
1064without the cache code noticing, in which case you
1065need to call this method afterwards:
e1a479c5 1066
dd69841b
BB
10671) Directly manipulating the stash HV entries from
1068XS code.
e1a479c5 1069
dd69841b
BB
10702) Assigning a reference to a readonly scalar
1071constant into a stash entry in order to create
1072a constant subroutine (like constant.pm
1073does).
1074
1075This same method is available from pure perl
1076via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
1077
1078=cut
1079*/
1080void
1081Perl_mro_method_changed_in(pTHX_ HV *stash)
1082{
00169e2c
FC
1083 const char * const stashname = HvENAME_get(stash);
1084 const STRLEN stashname_len = HvENAMELEN_get(stash);
dd69841b 1085
1e05feb3 1086 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
85fbaab2 1087 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
e1a479c5 1088
7918f24d
NC
1089 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1090
2c7f4b87
BB
1091 if(!stashname)
1092 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1093
70cd14a1
CB
1094 /* Inc the package generation, since a local method changed */
1095 HvMROMETA(stash)->pkg_gen++;
1096
e1a479c5
BB
1097 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1098 invalidate all method caches globally */
dd69841b
BB
1099 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1100 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
1101 PL_sub_generation++;
1102 return;
1103 }
1104
1105 /* else, invalidate the method caches of all child classes,
1106 but not itself */
dd69841b 1107 if(isarev) {
1e05feb3
AL
1108 HE* iter;
1109
e1a479c5
BB
1110 hv_iterinit(isarev);
1111 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
1112 I32 len;
1113 const char* const revkey = hv_iterkey(iter, &len);
1114 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
1115 struct mro_meta* mrometa;
1116
1117 if(!revstash) continue;
1118 mrometa = HvMROMETA(revstash);
dd69841b 1119 mrometa->cache_gen++;
e1a479c5
BB
1120 if(mrometa->mro_nextmethod)
1121 hv_clear(mrometa->mro_nextmethod);
1122 }
1123 }
1124}
1125
31b9005d
NC
1126void
1127Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1128{
1129 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1130
1131 PERL_ARGS_ASSERT_MRO_SET_MRO;
1132
1133 if (!which)
1134 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1135
1136 if(meta->mro_which != which) {
9953ff72 1137 if (meta->mro_linear_current && !meta->mro_linear_all) {
31b9005d
NC
1138 /* If we were storing something directly, put it in the hash before
1139 we lose it. */
1140 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
3a6fa573 1141 MUTABLE_SV(meta->mro_linear_current));
31b9005d
NC
1142 }
1143 meta->mro_which = which;
1144 /* Scrub our cached pointer to the private data. */
3a6fa573 1145 meta->mro_linear_current = NULL;
31b9005d
NC
1146 /* Only affects local method cache, not
1147 even child classes */
1148 meta->cache_gen++;
1149 if(meta->mro_nextmethod)
1150 hv_clear(meta->mro_nextmethod);
1151 }
1152}
1153
e1a479c5
BB
1154#include "XSUB.h"
1155
e1a479c5 1156XS(XS_mro_method_changed_in);
e1a479c5
BB
1157
1158void
1159Perl_boot_core_mro(pTHX)
1160{
1161 dVAR;
1162 static const char file[] = __FILE__;
1163
a3e6e81e 1164 Perl_mro_register(aTHX_ &dfs_alg);
a3e6e81e 1165
e1a479c5 1166 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
e1a479c5
BB
1167}
1168
e1a479c5
BB
1169XS(XS_mro_method_changed_in)
1170{
1171 dVAR;
1172 dXSARGS;
1173 SV* classname;
1174 HV* class_stash;
1175
e1a479c5 1176 if(items != 1)
afa74d42 1177 croak_xs_usage(cv, "classname");
e1a479c5
BB
1178
1179 classname = ST(0);
1180
1181 class_stash = gv_stashsv(classname, 0);
1182 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1183
1184 mro_method_changed_in(class_stash);
1185
1186 XSRETURN_EMPTY;
1187}
1188
e1a479c5
BB
1189/*
1190 * Local variables:
1191 * c-indentation-style: bsd
1192 * c-basic-offset: 4
1193 * indent-tabs-mode: t
1194 * End:
1195 *
1196 * ex: set ts=8 sts=4 sw=4 noet:
1197 */