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