This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In Perl_mro_isa_changed_in(), no need to call an RVALUE hv_fetch() then
[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
BB
56
57 assert(stash);
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
77 assert(smeta);
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
123 assert(stash);
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
237 assert(stash);
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
e1a479c5 450 assert(stash);
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
2c7f4b87
BB
484 if(!stashname)
485 Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
486
e1a479c5 487 /* wipe out the cached linearizations for this stash */
2c7f4b87 488 meta = HvMROMETA(stash);
e1a479c5
BB
489 SvREFCNT_dec((SV*)meta->mro_linear_dfs);
490 SvREFCNT_dec((SV*)meta->mro_linear_c3);
491 meta->mro_linear_dfs = NULL;
492 meta->mro_linear_c3 = NULL;
493
70cd14a1
CB
494 /* Inc the package generation, since our @ISA changed */
495 meta->pkg_gen++;
496
e1a479c5
BB
497 /* Wipe the global method cache if this package
498 is UNIVERSAL or one of its parents */
dd69841b
BB
499
500 svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
501 isarev = svp ? (HV*)*svp : NULL;
502
503 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
504 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5 505 PL_sub_generation++;
dd69841b
BB
506 is_universal = TRUE;
507 }
1e05feb3 508 else { /* Wipe the local method cache otherwise */
dd69841b 509 meta->cache_gen++;
1e05feb3
AL
510 is_universal = FALSE;
511 }
e1a479c5
BB
512
513 /* wipe next::method cache too */
514 if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
1e05feb3 515
e1a479c5
BB
516 /* Iterate the isarev (classes that are our children),
517 wiping out their linearization and method caches */
dd69841b 518 if(isarev) {
e1a479c5
BB
519 hv_iterinit(isarev);
520 while((iter = hv_iternext(isarev))) {
1e05feb3 521 SV* const revkey = hv_iterkeysv(iter);
e1a479c5 522 HV* revstash = gv_stashsv(revkey, 0);
bc2cbbac
BB
523 struct mro_meta* revmeta;
524
525 if(!revstash) continue;
526 revmeta = HvMROMETA(revstash);
e1a479c5
BB
527 SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
528 SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
529 revmeta->mro_linear_dfs = NULL;
530 revmeta->mro_linear_c3 = NULL;
dd69841b
BB
531 if(!is_universal)
532 revmeta->cache_gen++;
e1a479c5
BB
533 if(revmeta->mro_nextmethod)
534 hv_clear(revmeta->mro_nextmethod);
535 }
536 }
537
1c908217
RGS
538 /* Now iterate our MRO (parents), and do a few things:
539 1) instantiate with the "fake" flag if they don't exist
540 2) flag them as universal if we are universal
541 3) Add everything from our isarev to their isarev
542 */
543
544 /* We're starting at the 2nd element, skipping ourselves here */
e1a479c5
BB
545 linear_mro = mro_get_linear_isa(stash);
546 svp = AvARRAY(linear_mro) + 1;
547 items = AvFILLp(linear_mro);
1c908217 548
e1a479c5
BB
549 while (items--) {
550 SV* const sv = *svp++;
e1a479c5
BB
551 HV* mroisarev;
552
117b69ca
NC
553 HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
554
555 /* That fetch should not fail. But if it had to create a new SV for
556 us, then we can detect it, because it will not be the correct type.
557 Probably faster and cleaner for us to free that scalar [very little
558 code actually executed to free it] and create a new HV than to
559 copy&paste [SIN!] the code from newHV() to allow us to upgrade the
560 new SV from SVt_NULL. */
561
dd69841b 562 mroisarev = (HV*)HeVAL(he);
e1a479c5 563
117b69ca
NC
564 if(SvTYPE(mroisarev) != SVt_PVHV) {
565 SvREFCNT_dec(mroisarev);
566 mroisarev = newHV();
567 HeVAL(he) = (SV *) mroisarev;
568 }
569
25270bc0
NC
570 /* This hash only ever contains PL_sv_yes. Storing it over itself is
571 almost as cheap as calling hv_exists, so on aggregate we expect to
572 save time by not making two calls to the common HV code for the
573 case where it doesn't exist. */
574
04fe65b0 575 (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
e1a479c5
BB
576
577 if(isarev) {
578 hv_iterinit(isarev);
579 while((iter = hv_iternext(isarev))) {
dd69841b 580 I32 revkeylen;
1e05feb3 581 char* const revkey = hv_iterkey(iter, &revkeylen);
04fe65b0 582 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
e1a479c5
BB
583 }
584 }
585 }
586}
587
588/*
589=for apidoc mro_method_changed_in
590
47c9dd14
BB
591Invalidates method caching on any child classes
592of the given stash, so that they might notice
593the changes in this one.
e1a479c5
BB
594
595Ideally, all instances of C<PL_sub_generation++> in
dd69841b
BB
596perl source outside of C<mro.c> should be
597replaced by calls to this.
598
599Perl automatically handles most of the common
600ways a method might be redefined. However, there
601are a few ways you could change a method in a stash
602without the cache code noticing, in which case you
603need to call this method afterwards:
e1a479c5 604
dd69841b
BB
6051) Directly manipulating the stash HV entries from
606XS code.
e1a479c5 607
dd69841b
BB
6082) Assigning a reference to a readonly scalar
609constant into a stash entry in order to create
610a constant subroutine (like constant.pm
611does).
612
613This same method is available from pure perl
614via, C<mro::method_changed_in(classname)>.
e1a479c5
BB
615
616=cut
617*/
618void
619Perl_mro_method_changed_in(pTHX_ HV *stash)
620{
1e05feb3
AL
621 const char * const stashname = HvNAME_get(stash);
622 const STRLEN stashname_len = HvNAMELEN_get(stash);
dd69841b 623
1e05feb3
AL
624 SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
625 HV * const isarev = svp ? (HV*)*svp : NULL;
e1a479c5 626
2c7f4b87
BB
627 if(!stashname)
628 Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
629
70cd14a1
CB
630 /* Inc the package generation, since a local method changed */
631 HvMROMETA(stash)->pkg_gen++;
632
e1a479c5
BB
633 /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
634 invalidate all method caches globally */
dd69841b
BB
635 if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
636 || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
e1a479c5
BB
637 PL_sub_generation++;
638 return;
639 }
640
641 /* else, invalidate the method caches of all child classes,
642 but not itself */
dd69841b 643 if(isarev) {
1e05feb3
AL
644 HE* iter;
645
e1a479c5
BB
646 hv_iterinit(isarev);
647 while((iter = hv_iternext(isarev))) {
1e05feb3
AL
648 SV* const revkey = hv_iterkeysv(iter);
649 HV* const revstash = gv_stashsv(revkey, 0);
bc2cbbac
BB
650 struct mro_meta* mrometa;
651
652 if(!revstash) continue;
653 mrometa = HvMROMETA(revstash);
dd69841b 654 mrometa->cache_gen++;
e1a479c5
BB
655 if(mrometa->mro_nextmethod)
656 hv_clear(mrometa->mro_nextmethod);
657 }
658 }
659}
660
661/* These two are static helpers for next::method and friends,
662 and re-implement a bunch of the code from pp_caller() in
663 a more efficient manner for this particular usage.
664*/
665
666STATIC I32
667__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
668 I32 i;
669 for (i = startingblock; i >= 0; i--) {
670 if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
671 }
672 return i;
673}
674
e1a479c5
BB
675#include "XSUB.h"
676
677XS(XS_mro_get_linear_isa);
678XS(XS_mro_set_mro);
679XS(XS_mro_get_mro);
680XS(XS_mro_get_isarev);
681XS(XS_mro_is_universal);
c5860d66 682XS(XS_mro_invalidate_method_caches);
e1a479c5 683XS(XS_mro_method_changed_in);
70cd14a1 684XS(XS_mro_get_pkg_gen);
f58cd386 685XS(XS_mro_nextcan);
e1a479c5
BB
686
687void
688Perl_boot_core_mro(pTHX)
689{
690 dVAR;
691 static const char file[] = __FILE__;
692
693 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
694 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
695 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
696 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
697 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
c5860d66 698 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
e1a479c5 699 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
70cd14a1 700 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
f58cd386 701 newXS("mro::_nextcan", XS_mro_nextcan, file);
e1a479c5
BB
702}
703
704XS(XS_mro_get_linear_isa) {
705 dVAR;
706 dXSARGS;
707 AV* RETVAL;
708 HV* class_stash;
709 SV* classname;
710
711 PERL_UNUSED_ARG(cv);
712
713 if(items < 1 || items > 2)
714 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
715
716 classname = ST(0);
717 class_stash = gv_stashsv(classname, 0);
e1a479c5 718
70cd14a1
CB
719 if(!class_stash) {
720 /* No stash exists yet, give them just the classname */
721 AV* isalin = newAV();
722 av_push(isalin, newSVsv(classname));
723 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
724 XSRETURN(1);
725 }
726 else if(items > 1) {
1e05feb3 727 const char* const which = SvPV_nolen(ST(1));
3d76853f
NC
728 const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
729 if (!algo)
730 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
84dccb35 731 RETVAL = algo->resolve(aTHX_ class_stash, 0);
e1a479c5
BB
732 }
733 else {
734 RETVAL = mro_get_linear_isa(class_stash);
735 }
736
737 ST(0) = newRV_inc((SV*)RETVAL);
738 sv_2mortal(ST(0));
739 XSRETURN(1);
740}
741
742XS(XS_mro_set_mro)
743{
744 dVAR;
745 dXSARGS;
746 SV* classname;
3d76853f
NC
747 const char* whichstr;
748 const struct mro_alg *which;
e1a479c5
BB
749 HV* class_stash;
750 struct mro_meta* meta;
751
752 PERL_UNUSED_ARG(cv);
753
754 if (items != 2)
755 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
756
757 classname = ST(0);
758 whichstr = SvPV_nolen(ST(1));
759 class_stash = gv_stashsv(classname, GV_ADD);
760 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
761 meta = HvMROMETA(class_stash);
762
3d76853f
NC
763 which = S_get_mro_from_name(aTHX_ whichstr);
764 if (!which)
e1a479c5
BB
765 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
766
767 if(meta->mro_which != which) {
768 meta->mro_which = which;
769 /* Only affects local method cache, not
770 even child classes */
dd69841b 771 meta->cache_gen++;
e1a479c5
BB
772 if(meta->mro_nextmethod)
773 hv_clear(meta->mro_nextmethod);
774 }
775
776 XSRETURN_EMPTY;
777}
778
779
780XS(XS_mro_get_mro)
781{
782 dVAR;
783 dXSARGS;
784 SV* classname;
785 HV* class_stash;
e1a479c5
BB
786
787 PERL_UNUSED_ARG(cv);
788
789 if (items != 1)
790 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
791
792 classname = ST(0);
793 class_stash = gv_stashsv(classname, 0);
e1a479c5 794
3d76853f
NC
795 ST(0) = sv_2mortal(newSVpv(class_stash
796 ? HvMROMETA(class_stash)->mro_which->name
797 : "dfs", 0));
e1a479c5
BB
798 XSRETURN(1);
799}
800
801XS(XS_mro_get_isarev)
802{
803 dVAR;
804 dXSARGS;
805 SV* classname;
73968c7a 806 HE* he;
e1a479c5 807 HV* isarev;
70cd14a1 808 AV* ret_array;
e1a479c5
BB
809
810 PERL_UNUSED_ARG(cv);
811
812 if (items != 1)
813 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
814
815 classname = ST(0);
816
e1a479c5 817 SP -= items;
dd69841b 818
70cd14a1 819
73968c7a
NC
820 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
821 isarev = he ? (HV*)HeVAL(he) : NULL;
70cd14a1
CB
822
823 ret_array = newAV();
dd69841b 824 if(isarev) {
e1a479c5
BB
825 HE* iter;
826 hv_iterinit(isarev);
827 while((iter = hv_iternext(isarev)))
70cd14a1 828 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
e1a479c5 829 }
70cd14a1 830 XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
e1a479c5
BB
831
832 PUTBACK;
833 return;
834}
835
836XS(XS_mro_is_universal)
837{
838 dVAR;
839 dXSARGS;
840 SV* classname;
dd69841b 841 HV* isarev;
70cd14a1
CB
842 char* classname_pv;
843 STRLEN classname_len;
73968c7a 844 HE* he;
e1a479c5
BB
845
846 PERL_UNUSED_ARG(cv);
847
848 if (items != 1)
dd69841b 849 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
e1a479c5
BB
850
851 classname = ST(0);
e1a479c5 852
cfff9797 853 classname_pv = SvPV(classname,classname_len);
dd69841b 854
73968c7a
NC
855 he = hv_fetch_ent(PL_isarev, classname, 0, 0);
856 isarev = he ? (HV*)HeVAL(he) : NULL;
dd69841b 857
70cd14a1 858 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
dd69841b 859 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
9edc5bb8
RGS
860 XSRETURN_YES;
861 else
862 XSRETURN_NO;
e1a479c5
BB
863}
864
c5860d66 865XS(XS_mro_invalidate_method_caches)
e1a479c5
BB
866{
867 dVAR;
868 dXSARGS;
869
870 PERL_UNUSED_ARG(cv);
871
872 if (items != 0)
873 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
874
875 PL_sub_generation++;
876
877 XSRETURN_EMPTY;
878}
879
e1a479c5
BB
880XS(XS_mro_method_changed_in)
881{
882 dVAR;
883 dXSARGS;
884 SV* classname;
885 HV* class_stash;
886
887 PERL_UNUSED_ARG(cv);
888
889 if(items != 1)
890 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
891
892 classname = ST(0);
893
894 class_stash = gv_stashsv(classname, 0);
895 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
896
897 mro_method_changed_in(class_stash);
898
899 XSRETURN_EMPTY;
900}
901
70cd14a1
CB
902XS(XS_mro_get_pkg_gen)
903{
904 dVAR;
905 dXSARGS;
906 SV* classname;
907 HV* class_stash;
908
909 PERL_UNUSED_ARG(cv);
910
911 if(items != 1)
912 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
913
914 classname = ST(0);
915
916 class_stash = gv_stashsv(classname, 0);
917
918 SP -= items;
919
920 XPUSHs(sv_2mortal(newSViv(
921 class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
922 )));
923
924 PUTBACK;
925 return;
926}
927
f58cd386 928XS(XS_mro_nextcan)
e1a479c5
BB
929{
930 dVAR;
931 dXSARGS;
f58cd386
BB
932 SV* self = ST(0);
933 const I32 throw_nomethod = SvIVX(ST(1));
bbd28cb9 934 register I32 cxix = cxstack_ix;
f58cd386
BB
935 register const PERL_CONTEXT *ccstack = cxstack;
936 const PERL_SI *top_si = PL_curstackinfo;
937 HV* selfstash;
938 SV *stashname;
939 const char *fq_subname;
940 const char *subname;
941 STRLEN stashname_len;
942 STRLEN subname_len;
943 SV* sv;
944 GV** gvp;
945 AV* linear_av;
946 SV** linear_svp;
947 const char *hvname;
948 I32 entries;
949 struct mro_meta* selfmeta;
950 HV* nmcache;
bbd28cb9 951 I32 i;
e1a479c5 952
48fc4736
JH
953 PERL_UNUSED_ARG(cv);
954
f58cd386
BB
955 SP -= items;
956
957 if(sv_isobject(self))
958 selfstash = SvSTASH(SvRV(self));
959 else
960 selfstash = gv_stashsv(self, 0);
961
962 assert(selfstash);
963
964 hvname = HvNAME_get(selfstash);
965 if (!hvname)
966 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
967
f58cd386
BB
968 /* This block finds the contextually-enclosing fully-qualified subname,
969 much like looking at (caller($i))[3] until you find a real sub that
bbd28cb9
BB
970 isn't ANON, etc (also skips over pureperl next::method, etc) */
971 for(i = 0; i < 2; i++) {
972 cxix = __dopoptosub_at(ccstack, cxix);
973 for (;;) {
974 GV* cvgv;
975 STRLEN fq_subname_len;
976
977 /* we may be in a higher stacklevel, so dig down deeper */
978 while (cxix < 0) {
979 if(top_si->si_type == PERLSI_MAIN)
980 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
981 top_si = top_si->si_prev;
982 ccstack = top_si->si_cxstack;
983 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
984 }
f58cd386 985
bbd28cb9
BB
986 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
987 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
988 cxix = __dopoptosub_at(ccstack, cxix - 1);
989 continue;
990 }
e1a479c5 991
bbd28cb9
BB
992 {
993 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
994 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
995 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
996 cxix = dbcxix;
997 continue;
998 }
f58cd386
BB
999 }
1000 }
f58cd386 1001
bbd28cb9 1002 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
f58cd386 1003
bbd28cb9
BB
1004 if(!isGV(cvgv)) {
1005 cxix = __dopoptosub_at(ccstack, cxix - 1);
1006 continue;
1007 }
f58cd386 1008
bbd28cb9
BB
1009 /* we found a real sub here */
1010 sv = sv_2mortal(newSV(0));
f58cd386 1011
bbd28cb9 1012 gv_efullname3(sv, cvgv, NULL);
f58cd386 1013
bbd28cb9
BB
1014 fq_subname = SvPVX(sv);
1015 fq_subname_len = SvCUR(sv);
f58cd386 1016
bbd28cb9
BB
1017 subname = strrchr(fq_subname, ':');
1018 if(!subname)
1019 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
f58cd386 1020
bbd28cb9
BB
1021 subname++;
1022 subname_len = fq_subname_len - (subname - fq_subname);
1023 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1024 cxix = __dopoptosub_at(ccstack, cxix - 1);
1025 continue;
1026 }
1027 break;
f58cd386 1028 }
bbd28cb9 1029 cxix--;
e1a479c5 1030 }
f58cd386
BB
1031
1032 /* If we made it to here, we found our context */
1033
1034 /* Initialize the next::method cache for this stash
1035 if necessary */
1036 selfmeta = HvMROMETA(selfstash);
1037 if(!(nmcache = selfmeta->mro_nextmethod)) {
1038 nmcache = selfmeta->mro_nextmethod = newHV();
1039 }
1040 else { /* Use the cached coderef if it exists */
1041 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1042 if (cache_entry) {
1043 SV* const val = HeVAL(cache_entry);
1044 if(val == &PL_sv_undef) {
1045 if(throw_nomethod)
1046 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1047 XSRETURN_EMPTY;
1048 }
1049 XPUSHs(sv_2mortal(newRV_inc(val)));
1050 XSRETURN(1);
1051 }
e1a479c5
BB
1052 }
1053
f58cd386 1054 /* beyond here is just for cache misses, so perf isn't as critical */
e1a479c5 1055
f58cd386
BB
1056 stashname_len = subname - fq_subname - 2;
1057 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
e1a479c5 1058
f58cd386 1059 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
e1a479c5 1060
f58cd386
BB
1061 linear_svp = AvARRAY(linear_av);
1062 entries = AvFILLp(linear_av) + 1;
e1a479c5 1063
f58cd386
BB
1064 /* Walk down our MRO, skipping everything up
1065 to the contextually enclosing class */
1066 while (entries--) {
1067 SV * const linear_sv = *linear_svp++;
1068 assert(linear_sv);
1069 if(sv_eq(linear_sv, stashname))
1070 break;
1071 }
e1a479c5 1072
f58cd386
BB
1073 /* Now search the remainder of the MRO for the
1074 same method name as the contextually enclosing
1075 method */
1076 if(entries > 0) {
1077 while (entries--) {
1078 SV * const linear_sv = *linear_svp++;
1079 HV* curstash;
1080 GV* candidate;
1081 CV* cand_cv;
e1a479c5 1082
f58cd386
BB
1083 assert(linear_sv);
1084 curstash = gv_stashsv(linear_sv, FALSE);
1085
1086 if (!curstash) {
1087 if (ckWARN(WARN_SYNTAX))
1088 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1089 (void*)linear_sv, hvname);
1090 continue;
1091 }
1092
1093 assert(curstash);
1094
1095 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1096 if (!gvp) continue;
1097
1098 candidate = *gvp;
1099 assert(candidate);
1100
1101 if (SvTYPE(candidate) != SVt_PVGV)
1102 gv_init(candidate, curstash, subname, subname_len, TRUE);
1103
1104 /* Notably, we only look for real entries, not method cache
1105 entries, because in C3 the method cache of a parent is not
1106 valid for the child */
1107 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1108 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
04fe65b0 1109 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
f58cd386
BB
1110 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1111 XSRETURN(1);
1112 }
1113 }
e1a479c5
BB
1114 }
1115
04fe65b0 1116 (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
f58cd386
BB
1117 if(throw_nomethod)
1118 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1119 XSRETURN_EMPTY;
e1a479c5
BB
1120}
1121
1122/*
1123 * Local variables:
1124 * c-indentation-style: bsd
1125 * c-basic-offset: 4
1126 * indent-tabs-mode: t
1127 * End:
1128 *
1129 * ex: set ts=8 sts=4 sw=4 noet:
1130 */