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