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