This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Build the isa cache from any linear ISA, rather than forcing the use
[perl5.git] / mro.c
CommitLineData
e1a479c5
BB
1/* mro.c
2 *
3 * Copyright (c) 2007 Brandon L Black
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
10/*
cac98860
RGS
11 * "Which order shall we go in?" said Frodo. "Eldest first, or quickest first?
12 * You'll be last either way, Master Peregrin."
13 */
14
15/*
e1a479c5
BB
16=head1 MRO Functions
17
18These functions are related to the method resolution order of perl classes
19
20=cut
21*/
22
23#include "EXTERN.h"
4befac30 24#define PERL_IN_MRO_C
e1a479c5
BB
25#include "perl.h"
26
3d76853f
NC
27struct mro_alg {
28 const char *name;
29 AV *(*resolve)(pTHX_ HV* stash, I32 level);
30};
31
32/* First one is the default */
33static struct mro_alg mros[] = {
34 {"dfs", S_mro_get_linear_isa_dfs},
35 {"c3", S_mro_get_linear_isa_c3}
36};
37
38#define NUMBER_OF_MROS (sizeof(mros)/sizeof(struct mro_alg))
39
40static const struct mro_alg *
41S_get_mro_from_name(pTHX_ const char *const name) {
42 const struct mro_alg *algo = mros;
43 const struct mro_alg *const end = mros + NUMBER_OF_MROS;
44 while (algo < end) {
45 if(strEQ(name, algo->name))
46 return algo;
47 ++algo;
48 }
49 return NULL;
50}
51
e1a479c5
BB
52struct mro_meta*
53Perl_mro_meta_init(pTHX_ HV* stash)
54{
9fe4aecf 55 struct mro_meta* newmeta;
e1a479c5 56
7918f24d 57 PERL_ARGS_ASSERT_MRO_META_INIT;
e1a479c5
BB
58 assert(HvAUX(stash));
59 assert(!(HvAUX(stash)->xhv_mro_meta));
183086be 60 Newxz(newmeta, 1, struct mro_meta);
9fe4aecf 61 HvAUX(stash)->xhv_mro_meta = newmeta;
dd69841b 62 newmeta->cache_gen = 1;
70cd14a1 63 newmeta->pkg_gen = 1;
edf2cad7 64 newmeta->mro_which = mros;
e1a479c5
BB
65
66 return newmeta;
67}
68
69#if defined(USE_ITHREADS)
70
71/* for sv_dup on new threads */
72struct mro_meta*
73Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
74{
e1a479c5
BB
75 struct mro_meta* newmeta;
76
7918f24d 77 PERL_ARGS_ASSERT_MRO_META_DUP;
e1a479c5 78
33e12d9d
NC
79 Newx(newmeta, 1, struct mro_meta);
80 Copy(smeta, newmeta, 1, struct mro_meta);
81
82 if (newmeta->mro_linear_dfs)
83 newmeta->mro_linear_dfs
84 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_dfs, param));
85 if (newmeta->mro_linear_c3)
86 newmeta->mro_linear_c3
87 = (AV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_linear_c3, param));
33e12d9d
NC
88 if (newmeta->mro_nextmethod)
89 newmeta->mro_nextmethod
90 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
a49ba3fc
NC
91 if (newmeta->isa)
92 newmeta->isa
93 = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->isa, param));
e1a479c5
BB
94
95 return newmeta;
96}
97
98#endif /* USE_ITHREADS */
99
a49ba3fc
NC
100HV *
101Perl_get_isa_hash(pTHX_ HV *const stash)
102{
103 dVAR;
104 struct mro_meta *const meta = HvMROMETA(stash);
105
106 PERL_ARGS_ASSERT_GET_ISA_HASH;
107
6e4aef59
NC
108 if (!meta->isa) {
109 AV *const isa = mro_get_linear_isa(stash);
110 if (!meta->isa) {
111 HV *const isa_hash = newHV();
112 /* Linearisation didn't build it for us, so do it here. */
113 SV *const *svp = AvARRAY(isa);
114 SV *const *const svp_end = svp + AvFILLp(isa) + 1;
115 const HEK *const canon_name = HvNAME_HEK(stash);
116
117 while (svp < svp_end) {
118 (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0);
119 }
120
121 (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name),
122 HEK_LEN(canon_name), HEK_FLAGS(canon_name),
123 HV_FETCH_ISSTORE, &PL_sv_undef,
124 HEK_HASH(canon_name));
125 (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0);
126
127 meta->isa = isa_hash;
128 }
129 }
a49ba3fc
NC
130 return meta->isa;
131}
132
e1a479c5
BB
133/*
134=for apidoc mro_get_linear_isa_dfs
135
136Returns the Depth-First Search linearization of @ISA
137the given stash. The return value is a read-only AV*.
138C<level> should be 0 (it is used internally in this
139function's recursion).
140
1c908217
RGS
141You are responsible for C<SvREFCNT_inc()> on the
142return value if you plan to store it anywhere
143semi-permanently (otherwise it might be deleted
144out from under you the next time the cache is
145invalidated).
146
e1a479c5
BB
147=cut
148*/
4befac30
NC
149static AV*
150S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
e1a479c5
BB
151{
152 AV* retval;
153 GV** gvp;
154 GV* gv;
155 AV* av;
190d0b22 156 const HEK* stashhek;
e1a479c5 157 struct mro_meta* meta;
a49ba3fc
NC
158 SV *our_name;
159 HV *stored;
e1a479c5 160
7918f24d 161 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_DFS;
e1a479c5
BB
162 assert(HvAUX(stash));
163
190d0b22
NC
164 stashhek = HvNAME_HEK(stash);
165 if (!stashhek)
1e05feb3 166 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
167
168 if (level > 100)
169 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 170 HEK_KEY(stashhek));
e1a479c5
BB
171
172 meta = HvMROMETA(stash);
1c908217
RGS
173
174 /* return cache if valid */
e1a479c5 175 if((retval = meta->mro_linear_dfs)) {
e1a479c5
BB
176 return retval;
177 }
178
179 /* not in cache, make a new one */
1c908217 180
0fd7ece8 181 retval = (AV*)sv_2mortal((SV *)newAV());
a49ba3fc
NC
182 /* We use this later in this function, but don't need a reference to it
183 beyond the end of this function, so reference count is fine. */
184 our_name = newSVhek(stashhek);
185 av_push(retval, our_name); /* add ourselves at the top */
e1a479c5 186
1c908217 187 /* fetch our @ISA */
e1a479c5
BB
188 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
189 av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
190
a49ba3fc
NC
191 /* "stored" is used to keep track of all of the classnames we have added to
192 the MRO so far, so we can do a quick exists check and avoid adding
193 duplicate classnames to the MRO as we go.
194 It's then retained to be re-used as a fast lookup for ->isa(), by adding
195 our own name and "UNIVERSAL" to it. */
196
197 stored = (HV*)sv_2mortal((SV*)newHV());
1c908217 198
a49ba3fc 199 if(av && AvFILLp(av) >= 0) {
1c908217 200
ffd8da72
NC
201 SV **svp = AvARRAY(av);
202 I32 items = AvFILLp(av) + 1;
1c908217
RGS
203
204 /* foreach(@ISA) */
e1a479c5
BB
205 while (items--) {
206 SV* const sv = *svp++;
207 HV* const basestash = gv_stashsv(sv, 0);
ffd8da72
NC
208 SV *const *subrv_p;
209 I32 subrv_items;
e1a479c5
BB
210
211 if (!basestash) {
1c908217
RGS
212 /* if no stash exists for this @ISA member,
213 simply add it to the MRO and move on */
ffd8da72
NC
214 subrv_p = &sv;
215 subrv_items = 1;
e1a479c5
BB
216 }
217 else {
1c908217 218 /* otherwise, recurse into ourselves for the MRO
b1d0c68a
NC
219 of this @ISA member, and append their MRO to ours.
220 The recursive call could throw an exception, which
221 has memory management implications here, hence the use of
222 the mortal. */
ffd8da72
NC
223 const AV *const subrv
224 = mro_get_linear_isa_dfs(basestash, level + 1);
225
226 subrv_p = AvARRAY(subrv);
227 subrv_items = AvFILLp(subrv) + 1;
228 }
229 while(subrv_items--) {
230 SV *const subsv = *subrv_p++;
8e45cc2b
NC
231 /* LVALUE fetch will create a new undefined SV if necessary
232 */
233 HE *const he = hv_fetch_ent(stored, subsv, 1, 0);
234 assert(he);
235 if(HeVAL(he) != &PL_sv_undef) {
236 /* It was newly created. Steal it for our new SV, and
237 replace it in the hash with the "real" thing. */
238 SV *const val = HeVAL(he);
f46ee248 239 HEK *const key = HeKEY_hek(he);
8e45cc2b
NC
240
241 HeVAL(he) = &PL_sv_undef;
f46ee248
NC
242 /* Save copying by making a shared hash key scalar. We
243 inline this here rather than calling Perl_newSVpvn_share
244 because we already have the scalar, and we already have
245 the hash key. */
246 assert(SvTYPE(val) == SVt_NULL);
247 sv_upgrade(val, SVt_PV);
248 SvPV_set(val, HEK_KEY(share_hek_hek(key)));
249 SvCUR_set(val, HEK_LEN(key));
250 SvREADONLY_on(val);
251 SvFAKE_on(val);
252 SvPOK_on(val);
253 if (HEK_UTF8(key))
254 SvUTF8_on(val);
255
8e45cc2b 256 av_push(retval, val);
ffd8da72 257 }
e1a479c5
BB
258 }
259 }
260 }
261
0fd7ece8
NC
262 /* now that we're past the exception dangers, grab our own reference to
263 the AV we're about to use for the result. The reference owned by the
264 mortals' stack will be released soon, so everything will balance. */
265 SvREFCNT_inc_simple_void_NN(retval);
266 SvTEMP_off(retval);
a49ba3fc
NC
267 SvREFCNT_inc_simple_void_NN(stored);
268 SvTEMP_off(stored);
269
270 hv_store_ent(stored, our_name, &PL_sv_undef, 0);
271 hv_store(stored, "UNIVERSAL", 9, &PL_sv_undef, 0);
fdef73f9 272
1c908217
RGS
273 /* we don't want anyone modifying the cache entry but us,
274 and we do so by replacing it completely */
e1a479c5 275 SvREADONLY_on(retval);
a49ba3fc 276 SvREADONLY_on(stored);
1c908217 277
e1a479c5 278 meta->mro_linear_dfs = retval;
a49ba3fc 279 meta->isa = stored;
e1a479c5
BB
280 return retval;
281}
282
283/*
284=for apidoc mro_get_linear_isa_c3
285
286Returns the C3 linearization of @ISA
287the given stash. The return value is a read-only AV*.
288C<level> should be 0 (it is used internally in this
289function's recursion).
290
1c908217
RGS
291You are responsible for C<SvREFCNT_inc()> on the
292return value if you plan to store it anywhere
293semi-permanently (otherwise it might be deleted
294out from under you the next time the cache is
295invalidated).
296
e1a479c5
BB
297=cut
298*/
299
4befac30
NC
300static AV*
301S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
e1a479c5
BB
302{
303 AV* retval;
304 GV** gvp;
305 GV* gv;
306 AV* isa;
190d0b22 307 const HEK* stashhek;
e1a479c5
BB
308 struct mro_meta* meta;
309
7918f24d 310 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
e1a479c5
BB
311 assert(HvAUX(stash));
312
190d0b22
NC
313 stashhek = HvNAME_HEK(stash);
314 if (!stashhek)
1e05feb3 315 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
316
317 if (level > 100)
318 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
190d0b22 319 HEK_KEY(stashhek));
e1a479c5
BB
320
321 meta = HvMROMETA(stash);
1c908217
RGS
322
323 /* return cache if valid */
e1a479c5 324 if((retval = meta->mro_linear_c3)) {
e1a479c5
BB
325 return retval;
326 }
327
328 /* not in cache, make a new one */
329
e1a479c5
BB
330 gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
331 isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
332
1c908217
RGS
333 /* For a better idea how the rest of this works, see the much clearer
334 pure perl version in Algorithm::C3 0.01:
335 http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
336 (later versions go about it differently than this code for speed reasons)
337 */
8638e433 338
e1a479c5
BB
339 if(isa && AvFILLp(isa) >= 0) {
340 SV** seqs_ptr;
341 I32 seqs_items;
1e05feb3
AL
342 HV* const tails = (HV*)sv_2mortal((SV*)newHV());
343 AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
8638e433
RGS
344 I32* heads;
345
346 /* This builds @seqs, which is an array of arrays.
347 The members of @seqs are the MROs of
348 the members of @ISA, followed by @ISA itself.
349 */
e1a479c5
BB
350 I32 items = AvFILLp(isa) + 1;
351 SV** isa_ptr = AvARRAY(isa);
352 while(items--) {
1e05feb3
AL
353 SV* const isa_item = *isa_ptr++;
354 HV* const isa_item_stash = gv_stashsv(isa_item, 0);
e1a479c5 355 if(!isa_item_stash) {
8638e433
RGS
356 /* if no stash, make a temporary fake MRO
357 containing just itself */
70cd14a1 358 AV* const isa_lin = newAV();
e1a479c5 359 av_push(isa_lin, newSVsv(isa_item));
70cd14a1 360 av_push(seqs, (SV*)isa_lin);
e1a479c5
BB
361 }
362 else {
70cd14a1
CB
363 /* recursion */
364 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
365 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
e1a479c5 366 }
e1a479c5 367 }
1dcae283 368 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
8638e433
RGS
369
370 /* This builds "heads", which as an array of integer array
371 indices, one per seq, which point at the virtual "head"
372 of the seq (initially zero) */
373 Newxz(heads, AvFILLp(seqs)+1, I32);
374
375 /* This builds %tails, which has one key for every class
376 mentioned in the tail of any sequence in @seqs (tail meaning
377 everything after the first class, the "head"). The value
378 is how many times this key appears in the tails of @seqs.
379 */
e1a479c5
BB
380 seqs_ptr = AvARRAY(seqs);
381 seqs_items = AvFILLp(seqs) + 1;
382 while(seqs_items--) {
1e05feb3 383 AV* const seq = (AV*)*seqs_ptr++;
e1a479c5
BB
384 I32 seq_items = AvFILLp(seq);
385 if(seq_items > 0) {
386 SV** seq_ptr = AvARRAY(seq) + 1;
387 while(seq_items--) {
1e05feb3 388 SV* const seqitem = *seq_ptr++;
694168e2
NC
389 /* LVALUE fetch will create a new undefined SV if necessary
390 */
391 HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
392 if(he) {
1e05feb3 393 SV* const val = HeVAL(he);
694168e2
NC
394 /* This will increment undef to 1, which is what we
395 want for a newly created entry. */
e1a479c5
BB
396 sv_inc(val);
397 }
398 }
399 }
400 }
401
1dcae283
BB
402 /* Initialize retval to build the return value in */
403 retval = newAV();
190d0b22 404 av_push(retval, newSVhek(stashhek)); /* us first */
1dcae283 405
8638e433
RGS
406 /* This loop won't terminate until we either finish building
407 the MRO, or get an exception. */
e1a479c5 408 while(1) {
e1a479c5
BB
409 SV* cand = NULL;
410 SV* winner = NULL;
8638e433
RGS
411 int s;
412
413 /* "foreach $seq (@seqs)" */
1e05feb3 414 SV** const avptr = AvARRAY(seqs);
8638e433 415 for(s = 0; s <= AvFILLp(seqs); s++) {
e1a479c5 416 SV** svp;
1e05feb3
AL
417 AV * const seq = (AV*)(avptr[s]);
418 SV* seqhead;
8638e433
RGS
419 if(!seq) continue; /* skip empty seqs */
420 svp = av_fetch(seq, heads[s], 0);
421 seqhead = *svp; /* seqhead = head of this seq */
e1a479c5 422 if(!winner) {
1e05feb3
AL
423 HE* tail_entry;
424 SV* val;
8638e433
RGS
425 /* if we haven't found a winner for this round yet,
426 and this seqhead is not in tails (or the count
427 for it in tails has dropped to zero), then this
428 seqhead is our new winner, and is added to the
429 final MRO immediately */
e1a479c5
BB
430 cand = seqhead;
431 if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
432 && (val = HeVAL(tail_entry))
25270bc0 433 && (SvIVX(val) > 0))
e1a479c5
BB
434 continue;
435 winner = newSVsv(cand);
436 av_push(retval, winner);
8638e433
RGS
437 /* note however that even when we find a winner,
438 we continue looping over @seqs to do housekeeping */
e1a479c5
BB
439 }
440 if(!sv_cmp(seqhead, winner)) {
8638e433
RGS
441 /* Once we have a winner (including the iteration
442 where we first found him), inc the head ptr
443 for any seq which had the winner as a head,
444 NULL out any seq which is now empty,
445 and adjust tails for consistency */
446
1e05feb3 447 const int new_head = ++heads[s];
8638e433 448 if(new_head > AvFILLp(seq)) {
1dcae283 449 SvREFCNT_dec(avptr[s]);
8638e433
RGS
450 avptr[s] = NULL;
451 }
452 else {
1e05feb3
AL
453 HE* tail_entry;
454 SV* val;
8638e433
RGS
455 /* Because we know this new seqhead used to be
456 a tail, we can assume it is in tails and has
457 a positive value, which we need to dec */
458 svp = av_fetch(seq, new_head, 0);
459 seqhead = *svp;
460 tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
461 val = HeVAL(tail_entry);
462 sv_dec(val);
463 }
e1a479c5
BB
464 }
465 }
8638e433
RGS
466
467 /* if we found no candidates, we are done building the MRO.
468 !cand means no seqs have any entries left to check */
469 if(!cand) {
470 Safefree(heads);
471 break;
472 }
473
474 /* If we had candidates, but nobody won, then the @ISA
475 hierarchy is not C3-incompatible */
e1a479c5 476 if(!winner) {
8638e433 477 /* we have to do some cleanup before we croak */
8638e433 478
e1a479c5 479 SvREFCNT_dec(retval);
8638e433
RGS
480 Safefree(heads);
481
e1a479c5 482 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
190d0b22 483 "merging failed on parent '%"SVf"'", HEK_KEY(stashhek), SVfARG(cand));
e1a479c5
BB
484 }
485 }
486 }
1dcae283
BB
487 else { /* @ISA was undefined or empty */
488 /* build a retval containing only ourselves */
489 retval = newAV();
190d0b22 490 av_push(retval, newSVhek(stashhek));
1dcae283 491 }
e1a479c5 492
1c908217
RGS
493 /* we don't want anyone modifying the cache entry but us,
494 and we do so by replacing it completely */
e1a479c5 495 SvREADONLY_on(retval);
1c908217 496
e1a479c5
BB
497 meta->mro_linear_c3 = retval;
498 return retval;
499}
500
501/*
502=for apidoc mro_get_linear_isa
503
504Returns either C<mro_get_linear_isa_c3> or
505C<mro_get_linear_isa_dfs> for the given stash,
506dependant upon which MRO is in effect
507for that stash. The return value is a
508read-only AV*.
509
1c908217
RGS
510You are responsible for C<SvREFCNT_inc()> on the
511return value if you plan to store it anywhere
512semi-permanently (otherwise it might be deleted
513out from under you the next time the cache is
514invalidated).
515
e1a479c5
BB
516=cut
517*/
518AV*
519Perl_mro_get_linear_isa(pTHX_ HV *stash)
520{
521 struct mro_meta* meta;
2c7f4b87 522
7918f24d 523 PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA;
2c7f4b87
BB
524 if(!SvOOK(stash))
525 Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
e1a479c5
BB
526
527 meta = HvMROMETA(stash);
3d76853f 528 if (!meta->mro_which)
14f97ce6 529 Perl_croak(aTHX_ "panic: invalid MRO!");
3d76853f 530 return meta->mro_which->resolve(aTHX_ stash, 0);
e1a479c5
BB
531}
532
533/*
534=for apidoc mro_isa_changed_in
535
1c908217 536Takes the necessary steps (cache invalidations, mostly)
e1a479c5
BB
537when the @ISA of the given package has changed. Invoked
538by the C<setisa> magic, should not need to invoke directly.
539
540=cut
541*/
542void
543Perl_mro_isa_changed_in(pTHX_ HV* stash)
544{
545 dVAR;
546 HV* isarev;
547 AV* linear_mro;
548 HE* iter;
549 SV** svp;
550 I32 items;
1e05feb3 551 bool is_universal;
2c7f4b87 552 struct mro_meta * meta;
e1a479c5 553
0fa56319
RGS
554 const char * const stashname = HvNAME_get(stash);
555 const STRLEN stashname_len = HvNAMELEN_get(stash);
e1a479c5 556
7918f24d
NC
557 PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
558
2c7f4b87
BB
559 if(!stashname)
560 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
561
e1a479c5 562 /* wipe out the cached linearizations for this stash */
2c7f4b87 563 meta = HvMROMETA(stash);
e1a479c5
BB
564 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
565 SvREFCNT_dec((SV*)meta->mro_linear_c3);
566 meta->mro_linear_dfs = NULL;
567 meta->mro_linear_c3 = NULL;
5782d502
NC
568 if (meta->isa) {
569 SvREFCNT_dec(meta->isa);
570 meta->isa = NULL;
571 }
e1a479c5 572
70cd14a1
CB
573 /* Inc the package generation, since our @ISA changed */
574 meta->pkg_gen++;
575
e1a479c5
BB
576 /* Wipe the global method cache if this package
577 is UNIVERSAL or one of its parents */
dd69841b
BB
578
579 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
580 isarev = svp ? (HV*)*svp : NULL;
581
582 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
583 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 584 PL_sub_generation++;
dd69841b
BB
585 is_universal = TRUE;
586 }
1e05feb3 587 else { /* Wipe the local method cache otherwise */
dd69841b 588 meta->cache_gen++;
1e05feb3
AL
589 is_universal = FALSE;
590 }
e1a479c5
BB
591
592 /* wipe next::method cache too */
593 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 594
e1a479c5
BB
595 /* Iterate the isarev (classes that are our children),
596 wiping out their linearization and method caches */
dd69841b 597 if(isarev) {
e1a479c5
BB
598 hv_iterinit(isarev);
599 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
600 I32 len;
601 const char* const revkey = hv_iterkey(iter, &len);
602 HV* revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
603 struct mro_meta* revmeta;
604
605 if(!revstash) continue;
606 revmeta = HvMROMETA(revstash);
e1a479c5
BB
607 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
608 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
609 revmeta->mro_linear_dfs = NULL;
610 revmeta->mro_linear_c3 = NULL;
dd69841b
BB
611 if(!is_universal)
612 revmeta->cache_gen++;
e1a479c5
BB
613 if(revmeta->mro_nextmethod)
614 hv_clear(revmeta->mro_nextmethod);
615 }
616 }
617
1c908217
RGS
618 /* Now iterate our MRO (parents), and do a few things:
619 1) instantiate with the "fake" flag if they don't exist
620 2) flag them as universal if we are universal
621 3) Add everything from our isarev to their isarev
622 */
623
624 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
625 linear_mro = mro_get_linear_isa(stash);
626 svp = AvARRAY(linear_mro) + 1;
627 items = AvFILLp(linear_mro);
1c908217 628
e1a479c5
BB
629 while (items--) {
630 SV* const sv = *svp++;
e1a479c5
BB
631 HV* mroisarev;
632
117b69ca
NC
633 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
634
635 /* That fetch should not fail. But if it had to create a new SV for
4ea50411
NC
636 us, then will need to upgrade it to an HV (which sv_upgrade() can
637 now do for us. */
117b69ca 638
dd69841b 639 mroisarev = (HV*)HeVAL(he);
e1a479c5 640
4ea50411 641 SvUPGRADE((SV*)mroisarev, SVt_PVHV);
117b69ca 642
25270bc0
NC
643 /* This hash only ever contains PL_sv_yes. Storing it over itself is
644 almost as cheap as calling hv_exists, so on aggregate we expect to
645 save time by not making two calls to the common HV code for the
646 case where it doesn't exist. */
647
04fe65b0 648 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
649
650 if(isarev) {
651 hv_iterinit(isarev);
652 while((iter = hv_iternext(isarev))) {
dd69841b 653 I32 revkeylen;
1e05feb3 654 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 655 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
656 }
657 }
658 }
659}
660
661/*
662=for apidoc mro_method_changed_in
663
47c9dd14
BB
664Invalidates method caching on any child classes
665of the given stash, so that they might notice
666the changes in this one.
e1a479c5
BB
667
668Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
669perl source outside of C<mro.c> should be
670replaced by calls to this.
671
672Perl automatically handles most of the common
673ways a method might be redefined. However, there
674are a few ways you could change a method in a stash
675without the cache code noticing, in which case you
676need to call this method afterwards:
e1a479c5 677
dd69841b
BB
6781) Directly manipulating the stash HV entries from
679XS code.
e1a479c5 680
dd69841b
BB
6812) Assigning a reference to a readonly scalar
682constant into a stash entry in order to create
683a constant subroutine (like constant.pm
684does).
685
686This same method is available from pure perl
687via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
688
689=cut
690*/
691void
692Perl_mro_method_changed_in(pTHX_ HV *stash)
693{
1e05feb3
AL
694 const char * const stashname = HvNAME_get(stash);
695 const STRLEN stashname_len = HvNAMELEN_get(stash);
dd69841b 696
1e05feb3
AL
697 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
698 HV * const isarev = svp ? (HV*)*svp : NULL;
e1a479c5 699
7918f24d
NC
700 PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
701
2c7f4b87
BB
702 if(!stashname)
703 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
704
70cd14a1
CB
705 /* Inc the package generation, since a local method changed */
706 HvMROMETA(stash)->pkg_gen++;
707
e1a479c5
BB
708 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
709 invalidate all method caches globally */
dd69841b
BB
710 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
711 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
712 PL_sub_generation++;
713 return;
714 }
715
716 /* else, invalidate the method caches of all child classes,
717 but not itself */
dd69841b 718 if(isarev) {
1e05feb3
AL
719 HE* iter;
720
e1a479c5
BB
721 hv_iterinit(isarev);
722 while((iter = hv_iternext(isarev))) {
ec49eb61
NC
723 I32 len;
724 const char* const revkey = hv_iterkey(iter, &len);
725 HV* const revstash = gv_stashpvn(revkey, len, 0);
bc2cbbac
BB
726 struct mro_meta* mrometa;
727
728 if(!revstash) continue;
729 mrometa = HvMROMETA(revstash);
dd69841b 730 mrometa->cache_gen++;
e1a479c5
BB
731 if(mrometa->mro_nextmethod)
732 hv_clear(mrometa->mro_nextmethod);
733 }
734 }
735}
736
737/* These two are static helpers for next::method and friends,
738 and re-implement a bunch of the code from pp_caller() in
739 a more efficient manner for this particular usage.
740*/
741
742STATIC I32
743__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
744 I32 i;
745 for (i = startingblock; i >= 0; i--) {
746 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
747 }
748 return i;
749}
750
e1a479c5
BB
751#include "XSUB.h"
752
753XS(XS_mro_get_linear_isa);
754XS(XS_mro_set_mro);
755XS(XS_mro_get_mro);
756XS(XS_mro_get_isarev);
757XS(XS_mro_is_universal);
c5860d66 758XS(XS_mro_invalidate_method_caches);
e1a479c5 759XS(XS_mro_method_changed_in);
70cd14a1 760XS(XS_mro_get_pkg_gen);
f58cd386 761XS(XS_mro_nextcan);
e1a479c5
BB
762
763void
764Perl_boot_core_mro(pTHX)
765{
766 dVAR;
767 static const char file[] = __FILE__;
768
769 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
770 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
771 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
772 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
773 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
c5860d66 774 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
e1a479c5 775 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
70cd14a1 776 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
f58cd386 777 newXS("mro::_nextcan", XS_mro_nextcan, file);
e1a479c5
BB
778}
779
780XS(XS_mro_get_linear_isa) {
781 dVAR;
782 dXSARGS;
783 AV* RETVAL;
784 HV* class_stash;
785 SV* classname;
786
e1a479c5 787 if(items < 1 || items > 2)
afa74d42 788 croak_xs_usage(cv, "classname [, type ]");
e1a479c5
BB
789
790 classname = ST(0);
791 class_stash = gv_stashsv(classname, 0);
e1a479c5 792
70cd14a1
CB
793 if(!class_stash) {
794 /* No stash exists yet, give them just the classname */
795 AV* isalin = newAV();
796 av_push(isalin, newSVsv(classname));
797 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
798 XSRETURN(1);
799 }
800 else if(items > 1) {
1e05feb3 801 const char* const which = SvPV_nolen(ST(1));
3d76853f
NC
802 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
803 if (!algo)
804 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
84dccb35 805 RETVAL = algo->resolve(aTHX_ class_stash, 0);
e1a479c5
BB
806 }
807 else {
808 RETVAL = mro_get_linear_isa(class_stash);
809 }
810
811 ST(0) = newRV_inc((SV*)RETVAL);
812 sv_2mortal(ST(0));
813 XSRETURN(1);
814}
815
816XS(XS_mro_set_mro)
817{
818 dVAR;
819 dXSARGS;
820 SV* classname;
3d76853f
NC
821 const char* whichstr;
822 const struct mro_alg *which;
e1a479c5
BB
823 HV* class_stash;
824 struct mro_meta* meta;
825
e1a479c5 826 if (items != 2)
afa74d42 827 croak_xs_usage(cv, "classname, type");
e1a479c5
BB
828
829 classname = ST(0);
830 whichstr = SvPV_nolen(ST(1));
831 class_stash = gv_stashsv(classname, GV_ADD);
832 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
833 meta = HvMROMETA(class_stash);
834
3d76853f
NC
835 which = S_get_mro_from_name(aTHX_ whichstr);
836 if (!which)
e1a479c5
BB
837 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
838
839 if(meta->mro_which != which) {
840 meta->mro_which = which;
841 /* Only affects local method cache, not
842 even child classes */
dd69841b 843 meta->cache_gen++;
e1a479c5
BB
844 if(meta->mro_nextmethod)
845 hv_clear(meta->mro_nextmethod);
846 }
847
848 XSRETURN_EMPTY;
849}
850
851
852XS(XS_mro_get_mro)
853{
854 dVAR;
855 dXSARGS;
856 SV* classname;
857 HV* class_stash;
e1a479c5 858
e1a479c5 859 if (items != 1)
afa74d42 860 croak_xs_usage(cv, "classname");
e1a479c5
BB
861
862 classname = ST(0);
863 class_stash = gv_stashsv(classname, 0);
e1a479c5 864
3d76853f
NC
865 ST(0) = sv_2mortal(newSVpv(class_stash
866 ? HvMROMETA(class_stash)->mro_which->name
867 : "dfs", 0));
e1a479c5
BB
868 XSRETURN(1);
869}
870
871XS(XS_mro_get_isarev)
872{
873 dVAR;
874 dXSARGS;
875 SV* classname;
73968c7a 876 HE* he;
e1a479c5 877 HV* isarev;
70cd14a1 878 AV* ret_array;
e1a479c5 879
e1a479c5 880 if (items != 1)
afa74d42 881 croak_xs_usage(cv, "classname");
e1a479c5
BB
882
883 classname = ST(0);
884
e1a479c5 885 SP -= items;
dd69841b 886
70cd14a1 887
73968c7a
NC
888 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
889 isarev = he ? (HV*)HeVAL(he) : NULL;
70cd14a1
CB
890
891 ret_array = newAV();
dd69841b 892 if(isarev) {
e1a479c5
BB
893 HE* iter;
894 hv_iterinit(isarev);
895 while((iter = hv_iternext(isarev)))
70cd14a1 896 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
e1a479c5 897 }
6e449a3a 898 mXPUSHs(newRV_noinc((SV*)ret_array));
e1a479c5
BB
899
900 PUTBACK;
901 return;
902}
903
904XS(XS_mro_is_universal)
905{
906 dVAR;
907 dXSARGS;
908 SV* classname;
dd69841b 909 HV* isarev;
70cd14a1
CB
910 char* classname_pv;
911 STRLEN classname_len;
73968c7a 912 HE* he;
e1a479c5 913
e1a479c5 914 if (items != 1)
afa74d42 915 croak_xs_usage(cv, "classname");
e1a479c5
BB
916
917 classname = ST(0);
e1a479c5 918
cfff9797 919 classname_pv = SvPV(classname,classname_len);
dd69841b 920
73968c7a
NC
921 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
922 isarev = he ? (HV*)HeVAL(he) : NULL;
dd69841b 923
70cd14a1 924 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
dd69841b 925 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
9edc5bb8
RGS
926 XSRETURN_YES;
927 else
928 XSRETURN_NO;
e1a479c5
BB
929}
930
c5860d66 931XS(XS_mro_invalidate_method_caches)
e1a479c5
BB
932{
933 dVAR;
934 dXSARGS;
935
e1a479c5 936 if (items != 0)
afa74d42 937 croak_xs_usage(cv, "");
e1a479c5
BB
938
939 PL_sub_generation++;
940
941 XSRETURN_EMPTY;
942}
943
e1a479c5
BB
944XS(XS_mro_method_changed_in)
945{
946 dVAR;
947 dXSARGS;
948 SV* classname;
949 HV* class_stash;
950
e1a479c5 951 if(items != 1)
afa74d42 952 croak_xs_usage(cv, "classname");
e1a479c5
BB
953
954 classname = ST(0);
955
956 class_stash = gv_stashsv(classname, 0);
957 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
958
959 mro_method_changed_in(class_stash);
960
961 XSRETURN_EMPTY;
962}
963
70cd14a1
CB
964XS(XS_mro_get_pkg_gen)
965{
966 dVAR;
967 dXSARGS;
968 SV* classname;
969 HV* class_stash;
970
70cd14a1 971 if(items != 1)
afa74d42 972 croak_xs_usage(cv, "classname");
70cd14a1
CB
973
974 classname = ST(0);
975
976 class_stash = gv_stashsv(classname, 0);
977
978 SP -= items;
979
6e449a3a 980 mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
70cd14a1
CB
981
982 PUTBACK;
983 return;
984}
985
f58cd386 986XS(XS_mro_nextcan)
e1a479c5
BB
987{
988 dVAR;
989 dXSARGS;
f58cd386
BB
990 SV* self = ST(0);
991 const I32 throw_nomethod = SvIVX(ST(1));
bbd28cb9 992 register I32 cxix = cxstack_ix;
f58cd386
BB
993 register const PERL_CONTEXT *ccstack = cxstack;
994 const PERL_SI *top_si = PL_curstackinfo;
995 HV* selfstash;
996 SV *stashname;
997 const char *fq_subname;
998 const char *subname;
999 STRLEN stashname_len;
1000 STRLEN subname_len;
1001 SV* sv;
1002 GV** gvp;
1003 AV* linear_av;
1004 SV** linear_svp;
1005 const char *hvname;
1006 I32 entries;
1007 struct mro_meta* selfmeta;
1008 HV* nmcache;
bbd28cb9 1009 I32 i;
e1a479c5 1010
48fc4736
JH
1011 PERL_UNUSED_ARG(cv);
1012
f58cd386
BB
1013 SP -= items;
1014
1015 if(sv_isobject(self))
1016 selfstash = SvSTASH(SvRV(self));
1017 else
5fa9f951 1018 selfstash = gv_stashsv(self, GV_ADD);
f58cd386
BB
1019
1020 assert(selfstash);
1021
1022 hvname = HvNAME_get(selfstash);
1023 if (!hvname)
1024 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
1025
f58cd386
BB
1026 /* This block finds the contextually-enclosing fully-qualified subname,
1027 much like looking at (caller($i))[3] until you find a real sub that
bbd28cb9
BB
1028 isn't ANON, etc (also skips over pureperl next::method, etc) */
1029 for(i = 0; i < 2; i++) {
1030 cxix = __dopoptosub_at(ccstack, cxix);
1031 for (;;) {
1032 GV* cvgv;
1033 STRLEN fq_subname_len;
1034
1035 /* we may be in a higher stacklevel, so dig down deeper */
1036 while (cxix < 0) {
1037 if(top_si->si_type == PERLSI_MAIN)
1038 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
1039 top_si = top_si->si_prev;
1040 ccstack = top_si->si_cxstack;
1041 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
1042 }
f58cd386 1043
bbd28cb9
BB
1044 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
1045 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
1046 cxix = __dopoptosub_at(ccstack, cxix - 1);
1047 continue;
1048 }
e1a479c5 1049
bbd28cb9
BB
1050 {
1051 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
1052 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
1053 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
1054 cxix = dbcxix;
1055 continue;
1056 }
f58cd386
BB
1057 }
1058 }
f58cd386 1059
bbd28cb9 1060 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
f58cd386 1061
bbd28cb9
BB
1062 if(!isGV(cvgv)) {
1063 cxix = __dopoptosub_at(ccstack, cxix - 1);
1064 continue;
1065 }
f58cd386 1066
bbd28cb9
BB
1067 /* we found a real sub here */
1068 sv = sv_2mortal(newSV(0));
f58cd386 1069
bbd28cb9 1070 gv_efullname3(sv, cvgv, NULL);
f58cd386 1071
bbd28cb9
BB
1072 fq_subname = SvPVX(sv);
1073 fq_subname_len = SvCUR(sv);
f58cd386 1074
bbd28cb9
BB
1075 subname = strrchr(fq_subname, ':');
1076 if(!subname)
1077 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
f58cd386 1078
bbd28cb9
BB
1079 subname++;
1080 subname_len = fq_subname_len - (subname - fq_subname);
1081 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1082 cxix = __dopoptosub_at(ccstack, cxix - 1);
1083 continue;
1084 }
1085 break;
f58cd386 1086 }
bbd28cb9 1087 cxix--;
e1a479c5 1088 }
f58cd386
BB
1089
1090 /* If we made it to here, we found our context */
1091
1092 /* Initialize the next::method cache for this stash
1093 if necessary */
1094 selfmeta = HvMROMETA(selfstash);
1095 if(!(nmcache = selfmeta->mro_nextmethod)) {
1096 nmcache = selfmeta->mro_nextmethod = newHV();
1097 }
1098 else { /* Use the cached coderef if it exists */
1099 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1100 if (cache_entry) {
1101 SV* const val = HeVAL(cache_entry);
1102 if(val == &PL_sv_undef) {
1103 if(throw_nomethod)
1104 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1105 XSRETURN_EMPTY;
1106 }
6e449a3a 1107 mXPUSHs(newRV_inc(val));
f58cd386
BB
1108 XSRETURN(1);
1109 }
e1a479c5
BB
1110 }
1111
f58cd386 1112 /* beyond here is just for cache misses, so perf isn't as critical */
e1a479c5 1113
f58cd386 1114 stashname_len = subname - fq_subname - 2;
59cd0e26 1115 stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
e1a479c5 1116
f58cd386 1117 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
e1a479c5 1118
f58cd386
BB
1119 linear_svp = AvARRAY(linear_av);
1120 entries = AvFILLp(linear_av) + 1;
e1a479c5 1121
f58cd386
BB
1122 /* Walk down our MRO, skipping everything up
1123 to the contextually enclosing class */
1124 while (entries--) {
1125 SV * const linear_sv = *linear_svp++;
1126 assert(linear_sv);
1127 if(sv_eq(linear_sv, stashname))
1128 break;
1129 }
e1a479c5 1130
f58cd386
BB
1131 /* Now search the remainder of the MRO for the
1132 same method name as the contextually enclosing
1133 method */
1134 if(entries > 0) {
1135 while (entries--) {
1136 SV * const linear_sv = *linear_svp++;
1137 HV* curstash;
1138 GV* candidate;
1139 CV* cand_cv;
e1a479c5 1140
f58cd386
BB
1141 assert(linear_sv);
1142 curstash = gv_stashsv(linear_sv, FALSE);
1143
1144 if (!curstash) {
1145 if (ckWARN(WARN_SYNTAX))
1146 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1147 (void*)linear_sv, hvname);
1148 continue;
1149 }
1150
1151 assert(curstash);
1152
1153 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1154 if (!gvp) continue;
1155
1156 candidate = *gvp;
1157 assert(candidate);
1158
1159 if (SvTYPE(candidate) != SVt_PVGV)
1160 gv_init(candidate, curstash, subname, subname_len, TRUE);
1161
1162 /* Notably, we only look for real entries, not method cache
1163 entries, because in C3 the method cache of a parent is not
1164 valid for the child */
1165 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1166 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
04fe65b0 1167 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
6e449a3a 1168 mXPUSHs(newRV_inc((SV*)cand_cv));
f58cd386
BB
1169 XSRETURN(1);
1170 }
1171 }
e1a479c5
BB
1172 }
1173
04fe65b0 1174 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
f58cd386
BB
1175 if(throw_nomethod)
1176 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1177 XSRETURN_EMPTY;
e1a479c5
BB
1178}
1179
1180/*
1181 * Local variables:
1182 * c-indentation-style: bsd
1183 * c-basic-offset: 4
1184 * indent-tabs-mode: t
1185 * End:
1186 *
1187 * ex: set ts=8 sts=4 sw=4 noet:
1188 */