This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
mad-const patch
[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
e1a479c5
BB
634#include "XSUB.h"
635
636XS(XS_mro_get_linear_isa);
637XS(XS_mro_set_mro);
638XS(XS_mro_get_mro);
639XS(XS_mro_get_isarev);
640XS(XS_mro_is_universal);
c5860d66 641XS(XS_mro_invalidate_method_caches);
e1a479c5 642XS(XS_mro_method_changed_in);
70cd14a1 643XS(XS_mro_get_pkg_gen);
f58cd386 644XS(XS_mro_nextcan);
e1a479c5
BB
645
646void
647Perl_boot_core_mro(pTHX)
648{
649 dVAR;
650 static const char file[] = __FILE__;
651
652 newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
653 newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
654 newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
655 newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
656 newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
c5860d66 657 newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
e1a479c5 658 newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
70cd14a1 659 newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
f58cd386 660 newXS("mro::_nextcan", XS_mro_nextcan, file);
e1a479c5
BB
661}
662
663XS(XS_mro_get_linear_isa) {
664 dVAR;
665 dXSARGS;
666 AV* RETVAL;
667 HV* class_stash;
668 SV* classname;
669
670 PERL_UNUSED_ARG(cv);
671
672 if(items < 1 || items > 2)
673 Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
674
675 classname = ST(0);
676 class_stash = gv_stashsv(classname, 0);
e1a479c5 677
70cd14a1
CB
678 if(!class_stash) {
679 /* No stash exists yet, give them just the classname */
680 AV* isalin = newAV();
681 av_push(isalin, newSVsv(classname));
682 ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
683 XSRETURN(1);
684 }
685 else if(items > 1) {
1e05feb3 686 const char* const which = SvPV_nolen(ST(1));
e1a479c5
BB
687 if(strEQ(which, "dfs"))
688 RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
689 else if(strEQ(which, "c3"))
690 RETVAL = mro_get_linear_isa_c3(class_stash, 0);
691 else
692 Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
693 }
694 else {
695 RETVAL = mro_get_linear_isa(class_stash);
696 }
697
698 ST(0) = newRV_inc((SV*)RETVAL);
699 sv_2mortal(ST(0));
700 XSRETURN(1);
701}
702
703XS(XS_mro_set_mro)
704{
705 dVAR;
706 dXSARGS;
707 SV* classname;
708 char* whichstr;
709 mro_alg which;
710 HV* class_stash;
711 struct mro_meta* meta;
712
713 PERL_UNUSED_ARG(cv);
714
715 if (items != 2)
716 Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
717
718 classname = ST(0);
719 whichstr = SvPV_nolen(ST(1));
720 class_stash = gv_stashsv(classname, GV_ADD);
721 if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
722 meta = HvMROMETA(class_stash);
723
724 if(strEQ(whichstr, "dfs"))
725 which = MRO_DFS;
726 else if(strEQ(whichstr, "c3"))
727 which = MRO_C3;
728 else
729 Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
730
731 if(meta->mro_which != which) {
732 meta->mro_which = which;
733 /* Only affects local method cache, not
734 even child classes */
dd69841b 735 meta->cache_gen++;
e1a479c5
BB
736 if(meta->mro_nextmethod)
737 hv_clear(meta->mro_nextmethod);
738 }
739
740 XSRETURN_EMPTY;
741}
742
743
744XS(XS_mro_get_mro)
745{
746 dVAR;
747 dXSARGS;
748 SV* classname;
749 HV* class_stash;
e1a479c5
BB
750
751 PERL_UNUSED_ARG(cv);
752
753 if (items != 1)
754 Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
755
756 classname = ST(0);
757 class_stash = gv_stashsv(classname, 0);
e1a479c5 758
70cd14a1 759 if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
e1a479c5
BB
760 ST(0) = sv_2mortal(newSVpvn("dfs", 3));
761 else
762 ST(0) = sv_2mortal(newSVpvn("c3", 2));
763
764 XSRETURN(1);
765}
766
767XS(XS_mro_get_isarev)
768{
769 dVAR;
770 dXSARGS;
771 SV* classname;
dd69841b 772 SV** svp;
e1a479c5 773 HV* isarev;
70cd14a1
CB
774 char* classname_pv;
775 STRLEN classname_len;
776 AV* ret_array;
e1a479c5
BB
777
778 PERL_UNUSED_ARG(cv);
779
780 if (items != 1)
781 Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
782
783 classname = ST(0);
784
e1a479c5 785 SP -= items;
dd69841b 786
70cd14a1
CB
787
788 classname_pv = SvPV_nolen(classname);
789 classname_len = strlen(classname_pv);
790 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
dd69841b 791 isarev = svp ? (HV*)*svp : NULL;
70cd14a1
CB
792
793 ret_array = newAV();
dd69841b 794 if(isarev) {
e1a479c5
BB
795 HE* iter;
796 hv_iterinit(isarev);
797 while((iter = hv_iternext(isarev)))
70cd14a1 798 av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
e1a479c5 799 }
70cd14a1 800 XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
e1a479c5
BB
801
802 PUTBACK;
803 return;
804}
805
806XS(XS_mro_is_universal)
807{
808 dVAR;
809 dXSARGS;
810 SV* classname;
dd69841b 811 HV* isarev;
70cd14a1
CB
812 char* classname_pv;
813 STRLEN classname_len;
dd69841b 814 SV** svp;
e1a479c5
BB
815
816 PERL_UNUSED_ARG(cv);
817
818 if (items != 1)
dd69841b 819 Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
e1a479c5
BB
820
821 classname = ST(0);
e1a479c5 822
70cd14a1
CB
823 classname_pv = SvPV_nolen(classname);
824 classname_len = strlen(classname_pv);
dd69841b 825
70cd14a1 826 svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
dd69841b
BB
827 isarev = svp ? (HV*)*svp : NULL;
828
70cd14a1 829 if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
dd69841b 830 || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
9edc5bb8
RGS
831 XSRETURN_YES;
832 else
833 XSRETURN_NO;
e1a479c5
BB
834}
835
c5860d66 836XS(XS_mro_invalidate_method_caches)
e1a479c5
BB
837{
838 dVAR;
839 dXSARGS;
840
841 PERL_UNUSED_ARG(cv);
842
843 if (items != 0)
844 Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
845
846 PL_sub_generation++;
847
848 XSRETURN_EMPTY;
849}
850
e1a479c5
BB
851XS(XS_mro_method_changed_in)
852{
853 dVAR;
854 dXSARGS;
855 SV* classname;
856 HV* class_stash;
857
858 PERL_UNUSED_ARG(cv);
859
860 if(items != 1)
861 Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
862
863 classname = ST(0);
864
865 class_stash = gv_stashsv(classname, 0);
866 if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
867
868 mro_method_changed_in(class_stash);
869
870 XSRETURN_EMPTY;
871}
872
70cd14a1
CB
873XS(XS_mro_get_pkg_gen)
874{
875 dVAR;
876 dXSARGS;
877 SV* classname;
878 HV* class_stash;
879
880 PERL_UNUSED_ARG(cv);
881
882 if(items != 1)
883 Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
884
885 classname = ST(0);
886
887 class_stash = gv_stashsv(classname, 0);
888
889 SP -= items;
890
891 XPUSHs(sv_2mortal(newSViv(
892 class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
893 )));
894
895 PUTBACK;
896 return;
897}
898
f58cd386 899XS(XS_mro_nextcan)
e1a479c5
BB
900{
901 dVAR;
902 dXSARGS;
f58cd386
BB
903 SV* self = ST(0);
904 const I32 throw_nomethod = SvIVX(ST(1));
905 register I32 cxix;
906 register const PERL_CONTEXT *ccstack = cxstack;
907 const PERL_SI *top_si = PL_curstackinfo;
908 HV* selfstash;
909 SV *stashname;
910 const char *fq_subname;
911 const char *subname;
912 STRLEN stashname_len;
913 STRLEN subname_len;
914 SV* sv;
915 GV** gvp;
916 AV* linear_av;
917 SV** linear_svp;
918 const char *hvname;
919 I32 entries;
920 struct mro_meta* selfmeta;
921 HV* nmcache;
e1a479c5 922
48fc4736
JH
923 PERL_UNUSED_ARG(cv);
924
f58cd386
BB
925 SP -= items;
926
927 if(sv_isobject(self))
928 selfstash = SvSTASH(SvRV(self));
929 else
930 selfstash = gv_stashsv(self, 0);
931
932 assert(selfstash);
933
934 hvname = HvNAME_get(selfstash);
935 if (!hvname)
936 Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
937
938 cxix = __dopoptosub_at(cxstack, cxstack_ix);
939 cxix = __dopoptosub_at(ccstack, cxix - 1); /* skip next::method, etc */
940
941 /* This block finds the contextually-enclosing fully-qualified subname,
942 much like looking at (caller($i))[3] until you find a real sub that
943 isn't ANON, etc */
944 for (;;) {
945 GV* cvgv;
946 STRLEN fq_subname_len;
947
948 /* we may be in a higher stacklevel, so dig down deeper */
949 while (cxix < 0) {
950 if(top_si->si_type == PERLSI_MAIN)
951 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
952 top_si = top_si->si_prev;
953 ccstack = top_si->si_cxstack;
954 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
955 }
956
957 if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
958 || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
959 cxix = __dopoptosub_at(ccstack, cxix - 1);
960 continue;
961 }
e1a479c5 962
f58cd386
BB
963 {
964 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
965 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
966 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
967 cxix = dbcxix;
968 continue;
969 }
970 }
971 }
972
973 cvgv = CvGV(ccstack[cxix].blk_sub.cv);
974
975 if(!isGV(cvgv)) {
976 cxix = __dopoptosub_at(ccstack, cxix - 1);
977 continue;
978 }
979
980 /* we found a real sub here */
981 sv = sv_2mortal(newSV(0));
982
983 gv_efullname3(sv, cvgv, NULL);
984
985 fq_subname = SvPVX(sv);
986 fq_subname_len = SvCUR(sv);
987
988 subname = strrchr(fq_subname, ':');
989 if(!subname)
990 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
991
992 subname++;
993 subname_len = fq_subname_len - (subname - fq_subname);
994 if(subname_len == 8 && strEQ(subname, "__ANON__")) {
995 cxix = __dopoptosub_at(ccstack, cxix - 1);
996 continue;
997 }
998 break;
e1a479c5 999 }
f58cd386
BB
1000
1001 /* If we made it to here, we found our context */
1002
1003 /* Initialize the next::method cache for this stash
1004 if necessary */
1005 selfmeta = HvMROMETA(selfstash);
1006 if(!(nmcache = selfmeta->mro_nextmethod)) {
1007 nmcache = selfmeta->mro_nextmethod = newHV();
1008 }
1009 else { /* Use the cached coderef if it exists */
1010 HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1011 if (cache_entry) {
1012 SV* const val = HeVAL(cache_entry);
1013 if(val == &PL_sv_undef) {
1014 if(throw_nomethod)
1015 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1016 XSRETURN_EMPTY;
1017 }
1018 XPUSHs(sv_2mortal(newRV_inc(val)));
1019 XSRETURN(1);
1020 }
e1a479c5
BB
1021 }
1022
f58cd386 1023 /* beyond here is just for cache misses, so perf isn't as critical */
e1a479c5 1024
f58cd386
BB
1025 stashname_len = subname - fq_subname - 2;
1026 stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
e1a479c5 1027
f58cd386 1028 linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
e1a479c5 1029
f58cd386
BB
1030 linear_svp = AvARRAY(linear_av);
1031 entries = AvFILLp(linear_av) + 1;
e1a479c5 1032
f58cd386
BB
1033 /* Walk down our MRO, skipping everything up
1034 to the contextually enclosing class */
1035 while (entries--) {
1036 SV * const linear_sv = *linear_svp++;
1037 assert(linear_sv);
1038 if(sv_eq(linear_sv, stashname))
1039 break;
1040 }
e1a479c5 1041
f58cd386
BB
1042 /* Now search the remainder of the MRO for the
1043 same method name as the contextually enclosing
1044 method */
1045 if(entries > 0) {
1046 while (entries--) {
1047 SV * const linear_sv = *linear_svp++;
1048 HV* curstash;
1049 GV* candidate;
1050 CV* cand_cv;
e1a479c5 1051
f58cd386
BB
1052 assert(linear_sv);
1053 curstash = gv_stashsv(linear_sv, FALSE);
1054
1055 if (!curstash) {
1056 if (ckWARN(WARN_SYNTAX))
1057 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1058 (void*)linear_sv, hvname);
1059 continue;
1060 }
1061
1062 assert(curstash);
1063
1064 gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1065 if (!gvp) continue;
1066
1067 candidate = *gvp;
1068 assert(candidate);
1069
1070 if (SvTYPE(candidate) != SVt_PVGV)
1071 gv_init(candidate, curstash, subname, subname_len, TRUE);
1072
1073 /* Notably, we only look for real entries, not method cache
1074 entries, because in C3 the method cache of a parent is not
1075 valid for the child */
1076 if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1077 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1078 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1079 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1080 XSRETURN(1);
1081 }
1082 }
e1a479c5
BB
1083 }
1084
f58cd386
BB
1085 hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1086 if(throw_nomethod)
1087 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1088 XSRETURN_EMPTY;
e1a479c5
BB
1089}
1090
1091/*
1092 * Local variables:
1093 * c-indentation-style: bsd
1094 * c-basic-offset: 4
1095 * indent-tabs-mode: t
1096 * End:
1097 *
1098 * ex: set ts=8 sts=4 sw=4 noet:
1099 */