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