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