This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Teach Deparse about coderefs in stashes
[perl5.git] / mro.c
... / ...
CommitLineData
1/* mro.c
2 *
3 * Copyright (c) 2007 Brandon L Black
4 * Copyright (c) 2007, 2008, 2009, 2010, 2011 Larry Wall and others
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/*
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"]
16 */
17
18/*
19=head1 MRO Functions
20These functions are related to the method resolution order of perl classes
21
22=cut
23*/
24
25#include "EXTERN.h"
26#define PERL_IN_MRO_C
27#include "perl.h"
28
29static const struct mro_alg dfs_alg =
30 {S_mro_get_linear_isa_dfs, "dfs", 3, 0, 0};
31
32SV *
33Perl_mro_get_private_data(pTHX_ struct mro_meta *const smeta,
34 const struct mro_alg *const which)
35{
36 SV **data;
37 PERL_ARGS_ASSERT_MRO_GET_PRIVATE_DATA;
38
39 data = (SV **)Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
40 which->name, which->length, which->kflags,
41 HV_FETCH_JUST_SV, NULL, which->hash);
42 if (!data)
43 return NULL;
44
45 /* If we've been asked to look up the private data for the current MRO, then
46 cache it. */
47 if (smeta->mro_which == which)
48 smeta->mro_linear_current = *data;
49
50 return *data;
51}
52
53SV *
54Perl_mro_set_private_data(pTHX_ struct mro_meta *const smeta,
55 const struct mro_alg *const which, SV *const data)
56{
57 PERL_ARGS_ASSERT_MRO_SET_PRIVATE_DATA;
58
59 if (!smeta->mro_linear_all) {
60 if (smeta->mro_which == which) {
61 /* If all we need to store is the current MRO's data, then don't use
62 memory on a hash with 1 element - store it direct, and signal
63 this by leaving the would-be-hash NULL. */
64 smeta->mro_linear_current = data;
65 return data;
66 } else {
67 HV *const hv = newHV();
68 /* Start with 2 buckets. It's unlikely we'll need more. */
69 HvMAX(hv) = 1;
70 smeta->mro_linear_all = hv;
71
72 if (smeta->mro_linear_current) {
73 /* If we were storing something directly, put it in the hash
74 before we lose it. */
75 Perl_mro_set_private_data(aTHX_ smeta, smeta->mro_which,
76 smeta->mro_linear_current);
77 }
78 }
79 }
80
81 /* We get here if we're storing more than one linearisation for this stash,
82 or the linearisation we are storing is not that if its current MRO. */
83
84 if (smeta->mro_which == which) {
85 /* If we've been asked to store the private data for the current MRO,
86 then cache it. */
87 smeta->mro_linear_current = data;
88 }
89
90 if (!Perl_hv_common(aTHX_ smeta->mro_linear_all, NULL,
91 which->name, which->length, which->kflags,
92 HV_FETCH_ISSTORE, data, which->hash)) {
93 Perl_croak(aTHX_ "panic: hv_store() failed in set_mro_private_data() "
94 "for '%.*s' %d", (int) which->length, which->name,
95 which->kflags);
96 }
97
98 return data;
99}
100
101const struct mro_alg *
102Perl_mro_get_from_name(pTHX_ SV *name) {
103 SV **data;
104
105 PERL_ARGS_ASSERT_MRO_GET_FROM_NAME;
106
107 data = (SV **)Perl_hv_common(aTHX_ PL_registered_mros, name, NULL, 0, 0,
108 HV_FETCH_JUST_SV, NULL, 0);
109 if (!data)
110 return NULL;
111 assert(SvTYPE(*data) == SVt_IV);
112 assert(SvIOK(*data));
113 return INT2PTR(const struct mro_alg *, SvUVX(*data));
114}
115
116/*
117=for apidoc mro_register
118Registers a custom mro plugin. See L<perlmroapi> for details.
119
120=cut
121*/
122
123void
124Perl_mro_register(pTHX_ const struct mro_alg *mro) {
125 SV *wrapper = newSVuv(PTR2UV(mro));
126
127 PERL_ARGS_ASSERT_MRO_REGISTER;
128
129
130 if (!Perl_hv_common(aTHX_ PL_registered_mros, NULL,
131 mro->name, mro->length, mro->kflags,
132 HV_FETCH_ISSTORE, wrapper, mro->hash)) {
133 SvREFCNT_dec_NN(wrapper);
134 Perl_croak(aTHX_ "panic: hv_store() failed in mro_register() "
135 "for '%.*s' %d", (int) mro->length, mro->name, mro->kflags);
136 }
137}
138
139struct mro_meta*
140Perl_mro_meta_init(pTHX_ HV* stash)
141{
142 struct mro_meta* newmeta;
143
144 PERL_ARGS_ASSERT_MRO_META_INIT;
145 PERL_UNUSED_CONTEXT;
146 assert(HvAUX(stash));
147 assert(!(HvAUX(stash)->xhv_mro_meta));
148 Newxz(newmeta, 1, struct mro_meta);
149 HvAUX(stash)->xhv_mro_meta = newmeta;
150 newmeta->cache_gen = 1;
151 newmeta->pkg_gen = 1;
152 newmeta->mro_which = &dfs_alg;
153
154 return newmeta;
155}
156
157#if defined(USE_ITHREADS)
158
159/* for sv_dup on new threads */
160struct mro_meta*
161Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
162{
163 struct mro_meta* newmeta;
164
165 PERL_ARGS_ASSERT_MRO_META_DUP;
166
167 Newx(newmeta, 1, struct mro_meta);
168 Copy(smeta, newmeta, 1, struct mro_meta);
169
170 if (newmeta->mro_linear_all) {
171 newmeta->mro_linear_all
172 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_linear_all, param));
173 /* This is just acting as a shortcut pointer, and will be automatically
174 updated on the first get. */
175 newmeta->mro_linear_current = NULL;
176 } else if (newmeta->mro_linear_current) {
177 /* Only the current MRO is stored, so this owns the data. */
178 newmeta->mro_linear_current
179 = sv_dup_inc((const SV *)newmeta->mro_linear_current, param);
180 }
181
182 if (newmeta->mro_nextmethod)
183 newmeta->mro_nextmethod
184 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->mro_nextmethod, param));
185 if (newmeta->isa)
186 newmeta->isa
187 = MUTABLE_HV(sv_dup_inc((const SV *)newmeta->isa, param));
188
189 newmeta->super = NULL;
190
191 return newmeta;
192}
193
194#endif /* USE_ITHREADS */
195
196/*
197=for apidoc mro_get_linear_isa_dfs
198
199Returns the Depth-First Search linearization of @ISA
200the given stash. The return value is a read-only AV*.
201C<level> should be 0 (it is used internally in this
202function's recursion).
203
204You are responsible for C<SvREFCNT_inc()> on the
205return value if you plan to store it anywhere
206semi-permanently (otherwise it might be deleted
207out from under you the next time the cache is
208invalidated).
209
210=cut
211*/
212static AV*
213S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
214{
215 AV* retval;
216 GV** gvp;
217 GV* gv;
218 AV* av;
219 const HEK* stashhek;
220 struct mro_meta* meta;
221 SV *our_name;
222 HV *stored = NULL;
223
224 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
225 assert(HvAUX(stash));
226
227 stashhek
228 = HvAUX(stash)->xhv_name_u.xhvnameu_name && HvENAME_HEK_NN(stash)
229 ? HvENAME_HEK_NN(stash)
230 : HvNAME_HEK(stash);
231
232 if (!stashhek)
233 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
234
235 if (level > 100)
236 Perl_croak(aTHX_
237 "Recursive inheritance detected in package '%"HEKf"'",
238 HEKfARG(stashhek));
239
240 meta = HvMROMETA(stash);
241
242 /* return cache if valid */
243 if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &dfs_alg)))) {
244 return retval;
245 }
246
247 /* not in cache, make a new one */
248
249 retval = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
250 /* We use this later in this function, but don't need a reference to it
251 beyond the end of this function, so reference count is fine. */
252 our_name = newSVhek(stashhek);
253 av_push(retval, our_name); /* add ourselves at the top */
254
255 /* fetch our @ISA */
256 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
257 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
258
259 /* "stored" is used to keep track of all of the classnames we have added to
260 the MRO so far, so we can do a quick exists check and avoid adding
261 duplicate classnames to the MRO as we go.
262 It's then retained to be re-used as a fast lookup for ->isa(), by adding
263 our own name and "UNIVERSAL" to it. */
264
265 if(av && AvFILLp(av) >= 0) {
266
267 SV **svp = AvARRAY(av);
268 I32 items = AvFILLp(av) + 1;
269
270 /* foreach(@ISA) */
271 while (items--) {
272 SV* const sv = *svp ? *svp : &PL_sv_undef;
273 HV* const basestash = gv_stashsv(sv, 0);
274 SV *const *subrv_p;
275 I32 subrv_items;
276 svp++;
277
278 if (!basestash) {
279 /* if no stash exists for this @ISA member,
280 simply add it to the MRO and move on */
281 subrv_p = &sv;
282 subrv_items = 1;
283 }
284 else {
285 /* otherwise, recurse into ourselves for the MRO
286 of this @ISA member, and append their MRO to ours.
287 The recursive call could throw an exception, which
288 has memory management implications here, hence the use of
289 the mortal. */
290 const AV *const subrv
291 = mro_get_linear_isa_dfs(basestash, level + 1);
292
293 subrv_p = AvARRAY(subrv);
294 subrv_items = AvFILLp(subrv) + 1;
295 }
296 if (stored) {
297 while(subrv_items--) {
298 SV *const subsv = *subrv_p++;
299 /* LVALUE fetch will create a new undefined SV if necessary
300 */
301 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
302 assert(he);
303 if(HeVAL(he) != &PL_sv_undef) {
304 /* It was newly created. Steal it for our new SV, and
305 replace it in the hash with the "real" thing. */
306 SV *const val = HeVAL(he);
307 HEK *const key = HeKEY_hek(he);
308
309 HeVAL(he) = &PL_sv_undef;
310 sv_sethek(val, key);
311 av_push(retval, val);
312 }
313 }
314 } else {
315 /* We are the first (or only) parent. We can short cut the
316 complexity above, because our @ISA is simply us prepended
317 to our parent's @ISA, and our ->isa cache is simply our
318 parent's, with our name added. */
319 /* newSVsv() is slow. This code is only faster if we can avoid
320 it by ensuring that SVs in the arrays are shared hash key
321 scalar SVs, because we can "copy" them very efficiently.
322 Although to be fair, we can't *ensure* this, as a reference
323 to the internal array is returned by mro::get_linear_isa(),
324 so we'll have to be defensive just in case someone faffed
325 with it. */
326 if (basestash) {
327 SV **svp;
328 stored = MUTABLE_HV(sv_2mortal((SV*)newHVhv(HvMROMETA(basestash)->isa)));
329 av_extend(retval, subrv_items);
330 AvFILLp(retval) = subrv_items;
331 svp = AvARRAY(retval);
332 while(subrv_items--) {
333 SV *const val = *subrv_p++;
334 *++svp = SvIsCOW_shared_hash(val)
335 ? newSVhek(SvSHARED_HEK_FROM_PV(SvPVX(val)))
336 : newSVsv(val);
337 }
338 } else {
339 /* They have no stash. So create ourselves an ->isa cache
340 as if we'd copied it from what theirs should be. */
341 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
342 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
343 av_push(retval,
344 newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
345 &PL_sv_undef, 0))));
346 }
347 }
348 }
349 } else {
350 /* We have no parents. */
351 stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
352 (void) hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
353 }
354
355 (void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
356
357 SvREFCNT_inc_simple_void_NN(stored);
358 SvTEMP_off(stored);
359 SvREADONLY_on(stored);
360
361 meta->isa = stored;
362
363 /* now that we're past the exception dangers, grab our own reference to
364 the AV we're about to use for the result. The reference owned by the
365 mortals' stack will be released soon, so everything will balance. */
366 SvREFCNT_inc_simple_void_NN(retval);
367 SvTEMP_off(retval);
368
369 /* we don't want anyone modifying the cache entry but us,
370 and we do so by replacing it completely */
371 SvREADONLY_on(retval);
372
373 return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &dfs_alg,
374 MUTABLE_SV(retval)));
375}
376
377/*
378=for apidoc mro_get_linear_isa
379
380Returns the mro linearisation for the given stash. By default, this
381will be whatever C<mro_get_linear_isa_dfs> returns unless some
382other MRO is in effect for the stash. The return value is a
383read-only AV*.
384
385You are responsible for C<SvREFCNT_inc()> on the
386return value if you plan to store it anywhere
387semi-permanently (otherwise it might be deleted
388out from under you the next time the cache is
389invalidated).
390
391=cut
392*/
393AV*
394Perl_mro_get_linear_isa(pTHX_ HV *stash)
395{
396 struct mro_meta* meta;
397 AV *isa;
398
399 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
400 if(!SvOOK(stash))
401 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
402
403 meta = HvMROMETA(stash);
404 if (!meta->mro_which)
405 Perl_croak(aTHX_ "panic: invalid MRO!");
406 isa = meta->mro_which->resolve(aTHX_ stash, 0);
407
408 if (meta->mro_which != &dfs_alg) { /* skip for dfs, for speed */
409 SV * const namesv =
410 (HvENAME(stash)||HvNAME(stash))
411 ? newSVhek(HvENAME_HEK(stash)
412 ? HvENAME_HEK(stash)
413 : HvNAME_HEK(stash))
414 : NULL;
415
416 if(namesv && (AvFILLp(isa) == -1 || !sv_eq(*AvARRAY(isa), namesv)))
417 {
418 AV * const old = isa;
419 SV **svp;
420 SV **ovp = AvARRAY(old);
421 SV * const * const oend = ovp + AvFILLp(old) + 1;
422 isa = (AV *)sv_2mortal((SV *)newAV());
423 av_extend(isa, AvFILLp(isa) = AvFILLp(old)+1);
424 *AvARRAY(isa) = namesv;
425 svp = AvARRAY(isa)+1;
426 while (ovp < oend) *svp++ = SvREFCNT_inc(*ovp++);
427 }
428 else SvREFCNT_dec(namesv);
429 }
430
431 if (!meta->isa) {
432 HV *const isa_hash = newHV();
433 /* Linearisation didn't build it for us, so do it here. */
434 SV *const *svp = AvARRAY(isa);
435 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
436 const HEK *canon_name = HvENAME_HEK(stash);
437 if (!canon_name) canon_name = HvNAME_HEK(stash);
438
439 while (svp < svp_end) {
440 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
441 }
442
443 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
444 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
445 HV_FETCH_ISSTORE, &PL_sv_undef,
446 HEK_HASH(canon_name));
447 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
448
449 SvREADONLY_on(isa_hash);
450
451 meta->isa = isa_hash;
452 }
453
454 return isa;
455}
456
457/*
458=for apidoc mro_isa_changed_in
459
460Takes the necessary steps (cache invalidations, mostly)
461when the @ISA of the given package has changed. Invoked
462by the C<setisa> magic, should not need to invoke directly.
463
464=cut
465*/
466
467/* Macro to avoid repeating the code five times. */
468#define CLEAR_LINEAR(mEta) \
469 if (mEta->mro_linear_all) { \
470 SvREFCNT_dec(MUTABLE_SV(mEta->mro_linear_all)); \
471 mEta->mro_linear_all = NULL; \
472 /* This is just acting as a shortcut pointer. */ \
473 mEta->mro_linear_current = NULL; \
474 } else if (mEta->mro_linear_current) { \
475 /* Only the current MRO is stored, so this owns the data. */ \
476 SvREFCNT_dec(mEta->mro_linear_current); \
477 mEta->mro_linear_current = NULL; \
478 }
479
480void
481Perl_mro_isa_changed_in(pTHX_ HV* stash)
482{
483 HV* isarev;
484 AV* linear_mro;
485 HE* iter;
486 SV** svp;
487 I32 items;
488 bool is_universal;
489 struct mro_meta * meta;
490 HV *isa = NULL;
491
492 const HEK * const stashhek = HvENAME_HEK(stash);
493 const char * const stashname = HvENAME_get(stash);
494 const STRLEN stashname_len = HvENAMELEN_get(stash);
495
496 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
497
498 if(!stashname)
499 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
500
501
502 /* wipe out the cached linearizations for this stash */
503 meta = HvMROMETA(stash);
504 CLEAR_LINEAR(meta);
505 if (meta->isa) {
506 /* Steal it for our own purposes. */
507 isa = (HV *)sv_2mortal((SV *)meta->isa);
508 meta->isa = NULL;
509 }
510
511 /* Inc the package generation, since our @ISA changed */
512 meta->pkg_gen++;
513
514 /* Wipe the global method cache if this package
515 is UNIVERSAL or one of its parents */
516
517 svp = hv_fetchhek(PL_isarev, stashhek, 0);
518 isarev = svp ? MUTABLE_HV(*svp) : NULL;
519
520 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
521 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
522 PL_sub_generation++;
523 is_universal = TRUE;
524 }
525 else { /* Wipe the local method cache otherwise */
526 meta->cache_gen++;
527 is_universal = FALSE;
528 }
529
530 /* wipe next::method cache too */
531 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
532
533 /* Changes to @ISA might turn overloading on */
534 HvAMAGIC_on(stash);
535 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
536 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
537
538 /* DESTROY can be cached in SvSTASH. */
539 if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
540
541 /* Iterate the isarev (classes that are our children),
542 wiping out their linearization, method and isa caches
543 and upating PL_isarev. */
544 if(isarev) {
545 HV *isa_hashes = NULL;
546
547 /* We have to iterate through isarev twice to avoid a chicken and
548 * egg problem: if A inherits from B and both are in isarev, A might
549 * be processed before B and use B's previous linearisation.
550 */
551
552 /* First iteration: Wipe everything, but stash away the isa hashes
553 * since we still need them for updating PL_isarev.
554 */
555
556 if(hv_iterinit(isarev)) {
557 /* Only create the hash if we need it; i.e., if isarev has
558 any elements. */
559 isa_hashes = (HV *)sv_2mortal((SV *)newHV());
560 }
561 while((iter = hv_iternext(isarev))) {
562 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
563 struct mro_meta* revmeta;
564
565 if(!revstash) continue;
566 revmeta = HvMROMETA(revstash);
567 CLEAR_LINEAR(revmeta);
568 if(!is_universal)
569 revmeta->cache_gen++;
570 if(revmeta->mro_nextmethod)
571 hv_clear(revmeta->mro_nextmethod);
572 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
573
574 (void)
575 hv_store(
576 isa_hashes, (const char*)&revstash, sizeof(HV *),
577 revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
578 );
579 revmeta->isa = NULL;
580 }
581
582 /* Second pass: Update PL_isarev. We can just use isa_hashes to
583 * avoid another round of stash lookups. */
584
585 /* isarev might be deleted from PL_isarev during this loop, so hang
586 * on to it. */
587 SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
588
589 if(isa_hashes) {
590 hv_iterinit(isa_hashes);
591 while((iter = hv_iternext(isa_hashes))) {
592 HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
593 HV * const isa = (HV *)HeVAL(iter);
594 const HEK *namehek;
595
596 /* We're starting at the 2nd element, skipping revstash */
597 linear_mro = mro_get_linear_isa(revstash);
598 svp = AvARRAY(linear_mro) + 1;
599 items = AvFILLp(linear_mro);
600
601 namehek = HvENAME_HEK(revstash);
602 if (!namehek) namehek = HvNAME_HEK(revstash);
603
604 while (items--) {
605 SV* const sv = *svp++;
606 HV* mroisarev;
607
608 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
609
610 /* That fetch should not fail. But if it had to create
611 a new SV for us, then will need to upgrade it to an
612 HV (which sv_upgrade() can now do for us). */
613
614 mroisarev = MUTABLE_HV(HeVAL(he));
615
616 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
617
618 /* This hash only ever contains PL_sv_yes. Storing it
619 over itself is almost as cheap as calling hv_exists,
620 so on aggregate we expect to save time by not making
621 two calls to the common HV code for the case where
622 it doesn't exist. */
623
624 (void)
625 hv_storehek(mroisarev, namehek, &PL_sv_yes);
626 }
627
628 if ((SV *)isa != &PL_sv_undef) {
629 assert(namehek);
630 mro_clean_isarev(
631 isa, HEK_KEY(namehek), HEK_LEN(namehek),
632 HvMROMETA(revstash)->isa, HEK_HASH(namehek),
633 HEK_UTF8(namehek)
634 );
635 }
636 }
637 }
638 }
639
640 /* Now iterate our MRO (parents), adding ourselves and everything from
641 our isarev to their isarev.
642 */
643
644 /* We're starting at the 2nd element, skipping ourselves here */
645 linear_mro = mro_get_linear_isa(stash);
646 svp = AvARRAY(linear_mro) + 1;
647 items = AvFILLp(linear_mro);
648
649 while (items--) {
650 SV* const sv = *svp++;
651 HV* mroisarev;
652
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
656 us, then will need to upgrade it to an HV (which sv_upgrade() can
657 now do for us. */
658
659 mroisarev = MUTABLE_HV(HeVAL(he));
660
661 SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
662
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
668 (void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
669 }
670
671 /* Delete our name from our former parents' isarevs. */
672 if(isa && HvARRAY(isa))
673 mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
674 HEK_HASH(stashhek), HEK_UTF8(stashhek));
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, U32 hash,
681 U32 flags)
682{
683 HE* iter;
684
685 PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV;
686
687 /* Delete our name from our former parents' isarevs. */
688 if(isa && HvARRAY(isa) && hv_iterinit(isa)) {
689 SV **svp;
690 while((iter = hv_iternext(isa))) {
691 I32 klen;
692 const char * const key = hv_iterkey(iter, &klen);
693 if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
694 continue;
695 svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
696 if(svp) {
697 HV * const isarev = (HV *)*svp;
698 (void)hv_common(isarev, NULL, name, len, flags,
699 G_DISCARD|HV_DELETE, NULL, hash);
700 if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
701 (void)hv_delete(PL_isarev, key,
702 HeKUTF8(iter) ? -klen : klen, G_DISCARD);
703 }
704 }
705 }
706}
707
708/*
709=for apidoc mro_package_moved
710
711Call this function to signal to a stash that it has been assigned to
712another spot in the stash hierarchy. C<stash> is the stash that has been
713assigned. C<oldstash> is the stash it replaces, if any. C<gv> is the glob
714that is actually being assigned to.
715
716This can also be called with a null first argument to
717indicate that C<oldstash> has been deleted.
718
719This function invalidates isa caches on the old stash, on all subpackages
720nested inside it, and on the subclasses of all those, including
721non-existent packages that have corresponding entries in C<stash>.
722
723It also sets the effective names (C<HvENAME>) on all the stashes as
724appropriate.
725
726If the C<gv> is present and is not in the symbol table, then this function
727simply returns. This checked will be skipped if C<flags & 1>.
728
729=cut
730*/
731void
732Perl_mro_package_moved(pTHX_ HV * const stash, HV * const oldstash,
733 const GV * const gv, U32 flags)
734{
735 SV *namesv;
736 HEK **namep;
737 I32 name_count;
738 HV *stashes;
739 HE* iter;
740
741 PERL_ARGS_ASSERT_MRO_PACKAGE_MOVED;
742 assert(stash || oldstash);
743
744 /* Determine the name(s) of the location that stash was assigned to
745 * or from which oldstash was removed.
746 *
747 * We cannot reliably use the name in oldstash, because it may have
748 * been deleted from the location in the symbol table that its name
749 * suggests, as in this case:
750 *
751 * $globref = \*foo::bar::;
752 * Symbol::delete_package("foo");
753 * *$globref = \%baz::;
754 * *$globref = *frelp::;
755 * # calls mro_package_moved(%frelp::, %baz::, *$globref, NULL, 0)
756 *
757 * So we get it from the gv. But, since the gv may no longer be in the
758 * symbol table, we check that first. The only reliable way to tell is
759 * to see whether its stash has an effective name and whether the gv
760 * resides in that stash under its name. That effective name may be
761 * different from what gv_fullname4 would use.
762 * If flags & 1, the caller has asked us to skip the check.
763 */
764 if(!(flags & 1)) {
765 SV **svp;
766 if(
767 !GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
768 !(svp = hv_fetchhek(GvSTASH(gv), GvNAME_HEK(gv), 0)) ||
769 *svp != (SV *)gv
770 ) return;
771 }
772 assert(SvOOK(GvSTASH(gv)));
773 assert(GvNAMELEN(gv));
774 assert(GvNAME(gv)[GvNAMELEN(gv) - 1] == ':');
775 assert(GvNAMELEN(gv) == 1 || GvNAME(gv)[GvNAMELEN(gv) - 2] == ':');
776 name_count = HvAUX(GvSTASH(gv))->xhv_name_count;
777 if (!name_count) {
778 name_count = 1;
779 namep = &HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_name;
780 }
781 else {
782 namep = HvAUX(GvSTASH(gv))->xhv_name_u.xhvnameu_names;
783 if (name_count < 0) ++namep, name_count = -name_count - 1;
784 }
785 if (name_count == 1) {
786 if (HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)) {
787 namesv = GvNAMELEN(gv) == 1
788 ? newSVpvs_flags(":", SVs_TEMP)
789 : newSVpvs_flags("", SVs_TEMP);
790 }
791 else {
792 namesv = sv_2mortal(newSVhek(*namep));
793 if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
794 else sv_catpvs(namesv, "::");
795 }
796 if (GvNAMELEN(gv) != 1) {
797 sv_catpvn_flags(
798 namesv, GvNAME(gv), GvNAMELEN(gv) - 2,
799 /* skip trailing :: */
800 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
801 );
802 }
803 }
804 else {
805 SV *aname;
806 namesv = sv_2mortal((SV *)newAV());
807 while (name_count--) {
808 if(HEK_LEN(*namep) == 4 && strnEQ(HEK_KEY(*namep), "main", 4)){
809 aname = GvNAMELEN(gv) == 1
810 ? newSVpvs(":")
811 : newSVpvs("");
812 namep++;
813 }
814 else {
815 aname = newSVhek(*namep++);
816 if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
817 else sv_catpvs(aname, "::");
818 }
819 if (GvNAMELEN(gv) != 1) {
820 sv_catpvn_flags(
821 aname, GvNAME(gv), GvNAMELEN(gv) - 2,
822 /* skip trailing :: */
823 GvNAMEUTF8(gv) ? SV_CATUTF8 : SV_CATBYTES
824 );
825 }
826 av_push((AV *)namesv, aname);
827 }
828 }
829
830 /* Get a list of all the affected classes. */
831 /* We cannot simply pass them all to mro_isa_changed_in to avoid
832 the list, as that function assumes that only one package has
833 changed. It does not work with:
834
835 @foo::ISA = qw( B B::B );
836 *B:: = delete $::{"A::"};
837
838 as neither B nor B::B can be updated before the other, since they
839 will reset caches on foo, which will see either B or B::B with the
840 wrong name. The names must be set on *all* affected stashes before
841 we do anything else. (And linearisations must be cleared, too.)
842 */
843 stashes = (HV *) sv_2mortal((SV *)newHV());
844 mro_gather_and_rename(
845 stashes, (HV *) sv_2mortal((SV *)newHV()),
846 stash, oldstash, namesv
847 );
848
849 /* Once the caches have been wiped on all the classes, call
850 mro_isa_changed_in on each. */
851 hv_iterinit(stashes);
852 while((iter = hv_iternext(stashes))) {
853 HV * const stash = *(HV **)HEK_KEY(HeKEY_hek(iter));
854 if(HvENAME(stash)) {
855 /* We have to restore the original meta->isa (that
856 mro_gather_and_rename set aside for us) this way, in case
857 one class in this list is a superclass of a another class
858 that we have already encountered. In such a case, meta->isa
859 will have been overwritten without old entries being deleted
860 from PL_isarev. */
861 struct mro_meta * const meta = HvMROMETA(stash);
862 if(meta->isa != (HV *)HeVAL(iter)){
863 SvREFCNT_dec(meta->isa);
864 meta->isa
865 = HeVAL(iter) == &PL_sv_yes
866 ? NULL
867 : (HV *)HeVAL(iter);
868 HeVAL(iter) = NULL; /* We donated our reference count. */
869 }
870 mro_isa_changed_in(stash);
871 }
872 }
873}
874
875STATIC void
876S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
877 HV *stash, HV *oldstash, SV *namesv)
878{
879 XPVHV* xhv;
880 HE *entry;
881 I32 riter = -1;
882 I32 items = 0;
883 const bool stash_had_name = stash && HvENAME(stash);
884 bool fetched_isarev = FALSE;
885 HV *seen = NULL;
886 HV *isarev = NULL;
887 SV **svp = NULL;
888
889 PERL_ARGS_ASSERT_MRO_GATHER_AND_RENAME;
890
891 /* We use the seen_stashes hash to keep track of which packages have
892 been encountered so far. This must be separate from the main list of
893 stashes, as we need to distinguish between stashes being assigned
894 and stashes being replaced/deleted. (A nested stash can be on both
895 sides of an assignment. We cannot simply skip iterating through a
896 stash on the right if we have seen it on the left, as it will not
897 get its ename assigned to it.)
898
899 To avoid allocating extra SVs, instead of a bitfield we can make
900 bizarre use of immortals:
901
902 &PL_sv_undef: seen on the left (oldstash)
903 &PL_sv_no : seen on the right (stash)
904 &PL_sv_yes : seen on both sides
905
906 */
907
908 if(oldstash) {
909 /* Add to the big list. */
910 struct mro_meta * meta;
911 HE * const entry
912 = (HE *)
913 hv_common(
914 seen_stashes, NULL, (const char *)&oldstash, sizeof(HV *), 0,
915 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
916 );
917 if(HeVAL(entry) == &PL_sv_undef || HeVAL(entry) == &PL_sv_yes) {
918 oldstash = NULL;
919 goto check_stash;
920 }
921 HeVAL(entry)
922 = HeVAL(entry) == &PL_sv_no ? &PL_sv_yes : &PL_sv_undef;
923 meta = HvMROMETA(oldstash);
924 (void)
925 hv_store(
926 stashes, (const char *)&oldstash, sizeof(HV *),
927 meta->isa
928 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
929 : &PL_sv_yes,
930 0
931 );
932 CLEAR_LINEAR(meta);
933
934 /* Update the effective name. */
935 if(HvENAME_get(oldstash)) {
936 const HEK * const enamehek = HvENAME_HEK(oldstash);
937 if(SvTYPE(namesv) == SVt_PVAV) {
938 items = AvFILLp((AV *)namesv) + 1;
939 svp = AvARRAY((AV *)namesv);
940 }
941 else {
942 items = 1;
943 svp = &namesv;
944 }
945 while (items--) {
946 const U32 name_utf8 = SvUTF8(*svp);
947 STRLEN len;
948 const char *name = SvPVx_const(*svp, len);
949 if(PL_stashcache) {
950 DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"SVf"'\n",
951 SVfARG(*svp)));
952 (void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
953 }
954 ++svp;
955 hv_ename_delete(oldstash, name, len, name_utf8);
956
957 if (!fetched_isarev) {
958 /* If the name deletion caused a name change, then we
959 * are not going to call mro_isa_changed_in with this
960 * name (and not at all if it has become anonymous) so
961 * we need to delete old isarev entries here, both
962 * those in the superclasses and this class's own list
963 * of subclasses. We simply delete the latter from
964 * PL_isarev, since we still need it. hv_delete morti-
965 * fies it for us, so sv_2mortal is not necessary. */
966 if(HvENAME_HEK(oldstash) != enamehek) {
967 if(meta->isa && HvARRAY(meta->isa))
968 mro_clean_isarev(meta->isa, name, len, 0, 0,
969 name_utf8 ? HVhek_UTF8 : 0);
970 isarev = (HV *)hv_delete(PL_isarev, name,
971 name_utf8 ? -(I32)len : (I32)len, 0);
972 fetched_isarev=TRUE;
973 }
974 }
975 }
976 }
977 }
978 check_stash:
979 if(stash) {
980 if(SvTYPE(namesv) == SVt_PVAV) {
981 items = AvFILLp((AV *)namesv) + 1;
982 svp = AvARRAY((AV *)namesv);
983 }
984 else {
985 items = 1;
986 svp = &namesv;
987 }
988 while (items--) {
989 const U32 name_utf8 = SvUTF8(*svp);
990 STRLEN len;
991 const char *name = SvPVx_const(*svp++, len);
992 hv_ename_add(stash, name, len, name_utf8);
993 }
994
995 /* Add it to the big list if it needs
996 * mro_isa_changed_in called on it. That happens if it was
997 * detached from the symbol table (so it had no HvENAME) before
998 * being assigned to the spot named by the 'name' variable, because
999 * its cached isa linearisation is now stale (the effective name
1000 * having changed), and subclasses will then use that cache when
1001 * mro_package_moved calls mro_isa_changed_in. (See
1002 * [perl #77358].)
1003 *
1004 * If it did have a name, then its previous name is still
1005 * used in isa caches, and there is no need for
1006 * mro_package_moved to call mro_isa_changed_in.
1007 */
1008
1009 entry
1010 = (HE *)
1011 hv_common(
1012 seen_stashes, NULL, (const char *)&stash, sizeof(HV *), 0,
1013 HV_FETCH_LVALUE|HV_FETCH_EMPTY_HE, NULL, 0
1014 );
1015 if(HeVAL(entry) == &PL_sv_yes || HeVAL(entry) == &PL_sv_no)
1016 stash = NULL;
1017 else {
1018 HeVAL(entry)
1019 = HeVAL(entry) == &PL_sv_undef ? &PL_sv_yes : &PL_sv_no;
1020 if(!stash_had_name)
1021 {
1022 struct mro_meta * const meta = HvMROMETA(stash);
1023 (void)
1024 hv_store(
1025 stashes, (const char *)&stash, sizeof(HV *),
1026 meta->isa
1027 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1028 : &PL_sv_yes,
1029 0
1030 );
1031 CLEAR_LINEAR(meta);
1032 }
1033 }
1034 }
1035
1036 if(!stash && !oldstash)
1037 /* Both stashes have been encountered already. */
1038 return;
1039
1040 /* Add all the subclasses to the big list. */
1041 if(!fetched_isarev) {
1042 /* If oldstash is not null, then we can use its HvENAME to look up
1043 the isarev hash, since all its subclasses will be listed there.
1044 It will always have an HvENAME. It the HvENAME was removed
1045 above, then fetch_isarev will be true, and this code will not be
1046 reached.
1047
1048 If oldstash is null, then this is an empty spot with no stash in
1049 it, so subclasses could be listed in isarev hashes belonging to
1050 any of the names, so we have to check all of them.
1051 */
1052 assert(!oldstash || HvENAME(oldstash));
1053 if (oldstash) {
1054 /* Extra variable to avoid a compiler warning */
1055 const HEK * const hvename = HvENAME_HEK(oldstash);
1056 fetched_isarev = TRUE;
1057 svp = hv_fetchhek(PL_isarev, hvename, 0);
1058 if (svp) isarev = MUTABLE_HV(*svp);
1059 }
1060 else if(SvTYPE(namesv) == SVt_PVAV) {
1061 items = AvFILLp((AV *)namesv) + 1;
1062 svp = AvARRAY((AV *)namesv);
1063 }
1064 else {
1065 items = 1;
1066 svp = &namesv;
1067 }
1068 }
1069 if(
1070 isarev || !fetched_isarev
1071 ) {
1072 while (fetched_isarev || items--) {
1073 HE *iter;
1074
1075 if (!fetched_isarev) {
1076 HE * const he = hv_fetch_ent(PL_isarev, *svp++, 0, 0);
1077 if (!he || !(isarev = MUTABLE_HV(HeVAL(he)))) continue;
1078 }
1079
1080 hv_iterinit(isarev);
1081 while((iter = hv_iternext(isarev))) {
1082 HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1083 struct mro_meta * meta;
1084
1085 if(!revstash) continue;
1086 meta = HvMROMETA(revstash);
1087 (void)
1088 hv_store(
1089 stashes, (const char *)&revstash, sizeof(HV *),
1090 meta->isa
1091 ? SvREFCNT_inc_simple_NN((SV *)meta->isa)
1092 : &PL_sv_yes,
1093 0
1094 );
1095 CLEAR_LINEAR(meta);
1096 }
1097
1098 if (fetched_isarev) break;
1099 }
1100 }
1101
1102 /* This is partly based on code in hv_iternext_flags. We are not call-
1103 ing that here, as we want to avoid resetting the hash iterator. */
1104
1105 /* Skip the entire loop if the hash is empty. */
1106 if(oldstash && HvUSEDKEYS(oldstash)) {
1107 xhv = (XPVHV*)SvANY(oldstash);
1108 seen = (HV *) sv_2mortal((SV *)newHV());
1109
1110 /* Iterate through entries in the oldstash, adding them to the
1111 list, meanwhile doing the equivalent of $seen{$key} = 1.
1112 */
1113
1114 while (++riter <= (I32)xhv->xhv_max) {
1115 entry = (HvARRAY(oldstash))[riter];
1116
1117 /* Iterate through the entries in this list */
1118 for(; entry; entry = HeNEXT(entry)) {
1119 const char* key;
1120 I32 len;
1121
1122 /* If this entry is not a glob, ignore it.
1123 Try the next. */
1124 if (!isGV(HeVAL(entry))) continue;
1125
1126 key = hv_iterkey(entry, &len);
1127 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1128 || (len == 1 && key[0] == ':')) {
1129 HV * const oldsubstash = GvHV(HeVAL(entry));
1130 SV ** const stashentry
1131 = stash ? hv_fetch(stash, key, HeUTF8(entry) ? -(I32)len : (I32)len, 0) : NULL;
1132 HV *substash = NULL;
1133
1134 /* Avoid main::main::main::... */
1135 if(oldsubstash == oldstash) continue;
1136
1137 if(
1138 (
1139 stashentry && *stashentry && isGV(*stashentry)
1140 && (substash = GvHV(*stashentry))
1141 )
1142 || (oldsubstash && HvENAME_get(oldsubstash))
1143 )
1144 {
1145 /* Add :: and the key (minus the trailing ::)
1146 to each name. */
1147 SV *subname;
1148 if(SvTYPE(namesv) == SVt_PVAV) {
1149 SV *aname;
1150 items = AvFILLp((AV *)namesv) + 1;
1151 svp = AvARRAY((AV *)namesv);
1152 subname = sv_2mortal((SV *)newAV());
1153 while (items--) {
1154 aname = newSVsv(*svp++);
1155 if (len == 1)
1156 sv_catpvs(aname, ":");
1157 else {
1158 sv_catpvs(aname, "::");
1159 sv_catpvn_flags(
1160 aname, key, len-2,
1161 HeUTF8(entry)
1162 ? SV_CATUTF8 : SV_CATBYTES
1163 );
1164 }
1165 av_push((AV *)subname, aname);
1166 }
1167 }
1168 else {
1169 subname = sv_2mortal(newSVsv(namesv));
1170 if (len == 1) sv_catpvs(subname, ":");
1171 else {
1172 sv_catpvs(subname, "::");
1173 sv_catpvn_flags(
1174 subname, key, len-2,
1175 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1176 );
1177 }
1178 }
1179 mro_gather_and_rename(
1180 stashes, seen_stashes,
1181 substash, oldsubstash, subname
1182 );
1183 }
1184
1185 (void)hv_store(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len, &PL_sv_yes, 0);
1186 }
1187 }
1188 }
1189 }
1190
1191 /* Skip the entire loop if the hash is empty. */
1192 if (stash && HvUSEDKEYS(stash)) {
1193 xhv = (XPVHV*)SvANY(stash);
1194 riter = -1;
1195
1196 /* Iterate through the new stash, skipping $seen{$key} items,
1197 calling mro_gather_and_rename(stashes,seen,entry,NULL, ...). */
1198 while (++riter <= (I32)xhv->xhv_max) {
1199 entry = (HvARRAY(stash))[riter];
1200
1201 /* Iterate through the entries in this list */
1202 for(; entry; entry = HeNEXT(entry)) {
1203 const char* key;
1204 I32 len;
1205
1206 /* If this entry is not a glob, ignore it.
1207 Try the next. */
1208 if (!isGV(HeVAL(entry))) continue;
1209
1210 key = hv_iterkey(entry, &len);
1211 if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
1212 || (len == 1 && key[0] == ':')) {
1213 HV *substash;
1214
1215 /* If this entry was seen when we iterated through the
1216 oldstash, skip it. */
1217 if(seen && hv_exists(seen, key, HeUTF8(entry) ? -(I32)len : (I32)len)) continue;
1218
1219 /* We get here only if this stash has no corresponding
1220 entry in the stash being replaced. */
1221
1222 substash = GvHV(HeVAL(entry));
1223 if(substash) {
1224 SV *subname;
1225
1226 /* Avoid checking main::main::main::... */
1227 if(substash == stash) continue;
1228
1229 /* Add :: and the key (minus the trailing ::)
1230 to each name. */
1231 if(SvTYPE(namesv) == SVt_PVAV) {
1232 SV *aname;
1233 items = AvFILLp((AV *)namesv) + 1;
1234 svp = AvARRAY((AV *)namesv);
1235 subname = sv_2mortal((SV *)newAV());
1236 while (items--) {
1237 aname = newSVsv(*svp++);
1238 if (len == 1)
1239 sv_catpvs(aname, ":");
1240 else {
1241 sv_catpvs(aname, "::");
1242 sv_catpvn_flags(
1243 aname, key, len-2,
1244 HeUTF8(entry)
1245 ? SV_CATUTF8 : SV_CATBYTES
1246 );
1247 }
1248 av_push((AV *)subname, aname);
1249 }
1250 }
1251 else {
1252 subname = sv_2mortal(newSVsv(namesv));
1253 if (len == 1) sv_catpvs(subname, ":");
1254 else {
1255 sv_catpvs(subname, "::");
1256 sv_catpvn_flags(
1257 subname, key, len-2,
1258 HeUTF8(entry) ? SV_CATUTF8 : SV_CATBYTES
1259 );
1260 }
1261 }
1262 mro_gather_and_rename(
1263 stashes, seen_stashes,
1264 substash, NULL, subname
1265 );
1266 }
1267 }
1268 }
1269 }
1270 }
1271}
1272
1273/*
1274=for apidoc mro_method_changed_in
1275
1276Invalidates method caching on any child classes
1277of the given stash, so that they might notice
1278the changes in this one.
1279
1280Ideally, all instances of C<PL_sub_generation++> in
1281perl source outside of F<mro.c> should be
1282replaced by calls to this.
1283
1284Perl automatically handles most of the common
1285ways a method might be redefined. However, there
1286are a few ways you could change a method in a stash
1287without the cache code noticing, in which case you
1288need to call this method afterwards:
1289
12901) Directly manipulating the stash HV entries from
1291XS code.
1292
12932) Assigning a reference to a readonly scalar
1294constant into a stash entry in order to create
1295a constant subroutine (like constant.pm
1296does).
1297
1298This same method is available from pure perl
1299via, C<mro::method_changed_in(classname)>.
1300
1301=cut
1302*/
1303void
1304Perl_mro_method_changed_in(pTHX_ HV *stash)
1305{
1306 const char * const stashname = HvENAME_get(stash);
1307 const STRLEN stashname_len = HvENAMELEN_get(stash);
1308
1309 SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
1310 HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
1311
1312 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
1313
1314 if(!stashname)
1315 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
1316
1317 /* Inc the package generation, since a local method changed */
1318 HvMROMETA(stash)->pkg_gen++;
1319
1320 /* DESTROY can be cached in SvSTASH. */
1321 if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
1322
1323 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
1324 invalidate all method caches globally */
1325 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
1326 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
1327 PL_sub_generation++;
1328 return;
1329 }
1330
1331 /* else, invalidate the method caches of all child classes,
1332 but not itself */
1333 if(isarev) {
1334 HE* iter;
1335
1336 hv_iterinit(isarev);
1337 while((iter = hv_iternext(isarev))) {
1338 HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
1339 struct mro_meta* mrometa;
1340
1341 if(!revstash) continue;
1342 mrometa = HvMROMETA(revstash);
1343 mrometa->cache_gen++;
1344 if(mrometa->mro_nextmethod)
1345 hv_clear(mrometa->mro_nextmethod);
1346 if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
1347 }
1348 }
1349
1350 /* The method change may be due to *{$package . "::()"} = \&nil; in
1351 overload.pm. */
1352 HvAMAGIC_on(stash);
1353 /* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
1354 HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
1355}
1356
1357void
1358Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
1359{
1360 const struct mro_alg *const which = Perl_mro_get_from_name(aTHX_ name);
1361
1362 PERL_ARGS_ASSERT_MRO_SET_MRO;
1363
1364 if (!which)
1365 Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", name);
1366
1367 if(meta->mro_which != which) {
1368 if (meta->mro_linear_current && !meta->mro_linear_all) {
1369 /* If we were storing something directly, put it in the hash before
1370 we lose it. */
1371 Perl_mro_set_private_data(aTHX_ meta, meta->mro_which,
1372 MUTABLE_SV(meta->mro_linear_current));
1373 }
1374 meta->mro_which = which;
1375 /* Scrub our cached pointer to the private data. */
1376 meta->mro_linear_current = NULL;
1377 /* Only affects local method cache, not
1378 even child classes */
1379 meta->cache_gen++;
1380 if(meta->mro_nextmethod)
1381 hv_clear(meta->mro_nextmethod);
1382 }
1383}
1384
1385#include "XSUB.h"
1386
1387XS(XS_mro_method_changed_in);
1388
1389void
1390Perl_boot_core_mro(pTHX)
1391{
1392 static const char file[] = __FILE__;
1393
1394 Perl_mro_register(aTHX_ &dfs_alg);
1395
1396 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
1397}
1398
1399XS(XS_mro_method_changed_in)
1400{
1401 dXSARGS;
1402 SV* classname;
1403 HV* class_stash;
1404
1405 if(items != 1)
1406 croak_xs_usage(cv, "classname");
1407
1408 classname = ST(0);
1409
1410 class_stash = gv_stashsv(classname, 0);
1411 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1412
1413 mro_method_changed_in(class_stash);
1414
1415 XSRETURN_EMPTY;
1416}
1417
1418/*
1419 * Local variables:
1420 * c-indentation-style: bsd
1421 * c-basic-offset: 4
1422 * indent-tabs-mode: nil
1423 * End:
1424 *
1425 * ex: set ts=8 sts=4 sw=4 et:
1426 */