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