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