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