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