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