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