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