Add CPANPLUS to Maintainers.pl
[perl.git] / mro.c
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 /*
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 /*
16 =head1 MRO Functions
17
18 These 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
26 struct mro_meta*
27 Perl_mro_meta_init(pTHX_ HV* stash)
28 {
29     struct mro_meta* newmeta;
30
31     assert(stash);
32     assert(HvAUX(stash));
33     assert(!(HvAUX(stash)->xhv_mro_meta));
34     Newxz(newmeta, 1, struct mro_meta);
35     HvAUX(stash)->xhv_mro_meta = newmeta;
36     newmeta->cache_gen = 1;
37
38     return newmeta;
39 }
40
41 #if defined(USE_ITHREADS)
42
43 /* for sv_dup on new threads */
44 struct mro_meta*
45 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
46 {
47     struct mro_meta* newmeta;
48
49     assert(smeta);
50
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));
60     if (newmeta->mro_nextmethod)
61         newmeta->mro_nextmethod
62             = (HV*) SvREFCNT_inc(sv_dup((SV*)newmeta->mro_nextmethod, param));
63
64     return newmeta;
65 }
66
67 #endif /* USE_ITHREADS */
68
69 /*
70 =for apidoc mro_get_linear_isa_dfs
71
72 Returns the Depth-First Search linearization of @ISA
73 the given stash.  The return value is a read-only AV*.
74 C<level> should be 0 (it is used internally in this
75 function's recursion).
76
77 You are responsible for C<SvREFCNT_inc()> on the
78 return value if you plan to store it anywhere
79 semi-permanently (otherwise it might be deleted
80 out from under you the next time the cache is
81 invalidated).
82
83 =cut
84 */
85 AV*
86 Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
87 {
88     AV* retval;
89     GV** gvp;
90     GV* gv;
91     AV* av;
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);
108
109     /* return cache if valid */
110     if((retval = meta->mro_linear_dfs)) {
111         return retval;
112     }
113
114     /* not in cache, make a new one */
115
116     retval = newAV();
117     av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
118
119     /* fetch our @ISA */
120     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
121     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
122
123     if(av && AvFILLp(av) >= 0) {
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
130         HV* stored = (HV*)sv_2mortal((SV*)newHV());
131         SV **svp = AvARRAY(av);
132         I32 items = AvFILLp(av) + 1;
133
134         /* foreach(@ISA) */
135         while (items--) {
136             SV* const sv = *svp++;
137             HV* const basestash = gv_stashsv(sv, 0);
138             SV *const *subrv_p;
139             I32 subrv_items;
140
141             if (!basestash) {
142                 /* if no stash exists for this @ISA member,
143                    simply add it to the MRO and move on */
144                 subrv_p = &sv;
145                 subrv_items = 1;
146             }
147             else {
148                 /* otherwise, recurse into ourselves for the MRO
149                    of this @ISA member, and append their MRO to ours */
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)) {
159                     hv_store_ent(stored, subsv, &PL_sv_undef, 0);
160                     av_push(retval, newSVsv(subsv));
161                 }
162             }
163         }
164     }
165
166     /* we don't want anyone modifying the cache entry but us,
167        and we do so by replacing it completely */
168     SvREADONLY_on(retval);
169
170     meta->mro_linear_dfs = retval;
171     return retval;
172 }
173
174 /*
175 =for apidoc mro_get_linear_isa_c3
176
177 Returns the C3 linearization of @ISA
178 the given stash.  The return value is a read-only AV*.
179 C<level> should be 0 (it is used internally in this
180 function's recursion).
181
182 You are responsible for C<SvREFCNT_inc()> on the
183 return value if you plan to store it anywhere
184 semi-permanently (otherwise it might be deleted
185 out from under you the next time the cache is
186 invalidated).
187
188 =cut
189 */
190
191 AV*
192 Perl_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);
216
217     /* return cache if valid */
218     if((retval = meta->mro_linear_c3)) {
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
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     */
235
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());
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         */
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) {
254                 /* if no stash, make a temporary fake MRO
255                    containing just itself */
256                 isa_lin = (AV*)sv_2mortal((SV*)newAV());
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             }
262             av_push(seqs, (SV*)isa_lin);
263         }
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         */
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
297         /* This loop won't terminate until we either finish building
298            the MRO, or get an exception. */
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;
306             int s;
307
308             /* "foreach $seq (@seqs)" */
309             SV** avptr = AvARRAY(seqs);
310             for(s = 0; s <= AvFILLp(seqs); s++) {
311                 SV** svp;
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 */
316                 if(!winner) {
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 */
322                     cand = seqhead;
323                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
324                        && (val = HeVAL(tail_entry))
325                        && (SvIVX(val) > 0))
326                            continue;
327                     winner = newSVsv(cand);
328                     av_push(retval, winner);
329                     /* note however that even when we find a winner,
330                        we continue looping over @seqs to do housekeeping */
331                 }
332                 if(!sv_cmp(seqhead, winner)) {
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                     }
353                 }
354             }
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 */
365             if(!winner) {
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
372                 SvREFCNT_dec(retval);
373                 Safefree(heads);
374
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
381     /* we don't want anyone modifying the cache entry but us,
382        and we do so by replacing it completely */
383     SvREADONLY_on(retval);
384
385     meta->mro_linear_c3 = retval;
386     return retval;
387 }
388
389 /*
390 =for apidoc mro_get_linear_isa
391
392 Returns either C<mro_get_linear_isa_c3> or
393 C<mro_get_linear_isa_dfs> for the given stash,
394 dependant upon which MRO is in effect
395 for that stash.  The return value is a
396 read-only AV*.
397
398 You are responsible for C<SvREFCNT_inc()> on the
399 return value if you plan to store it anywhere
400 semi-permanently (otherwise it might be deleted
401 out from under you the next time the cache is
402 invalidated).
403
404 =cut
405 */
406 AV*
407 Perl_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 {
419         Perl_croak(aTHX_ "panic: invalid MRO!");
420     }
421     return NULL; /* NOT REACHED */
422 }
423
424 /*
425 =for apidoc mro_isa_changed_in
426
427 Takes the necessary steps (cache invalidations, mostly)
428 when the @ISA of the given package has changed.  Invoked
429 by the C<setisa> magic, should not need to invoke directly.
430
431 =cut
432 */
433 void
434 Perl_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;
444     STRLEN stashname_len;
445     bool is_universal = FALSE;
446
447     stashname = HvNAME_get(stash);
448     stashname_len = HvNAMELEN_get(stash);
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 */
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))) {
465         PL_sub_generation++;
466         is_universal = TRUE;
467     }
468
469     /* Wipe the local method cache otherwise */
470     else
471         meta->cache_gen++;
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 */
478     if(isarev) {
479         hv_iterinit(isarev);
480         while((iter = hv_iternext(isarev))) {
481             SV* revkey = hv_iterkeysv(iter);
482             HV* revstash = gv_stashsv(revkey, 0);
483             struct mro_meta* revmeta;
484
485             if(!revstash) continue;
486             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(!is_universal)
492                 revmeta->cache_gen++;
493             if(revmeta->mro_nextmethod)
494                 hv_clear(revmeta->mro_nextmethod);
495         }
496     }
497
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 */
505     linear_mro = mro_get_linear_isa(stash);
506     svp = AvARRAY(linear_mro) + 1;
507     items = AvFILLp(linear_mro);
508
509     while (items--) {
510         HE* he;
511         SV* const sv = *svp++;
512         HV* mroisarev;
513
514         he = hv_fetch_ent(PL_isarev, sv, 0, 0);
515         if(!he) {
516             he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
517         }
518         mroisarev = (HV*)HeVAL(he);
519
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            
525         hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
526
527         if(isarev) {
528             hv_iterinit(isarev);
529             while((iter = hv_iternext(isarev))) {
530                 I32 revkeylen;
531                 char* revkey = hv_iterkey(iter, &revkeylen);
532                 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
533             }
534         }
535     }
536 }
537
538 /*
539 =for apidoc mro_method_changed_in
540
541 Invalidates method caching on any child classes
542 of the given stash, so that they might notice
543 the changes in this one.
544
545 Ideally, all instances of C<PL_sub_generation++> in
546 perl source outside of C<mro.c> should be
547 replaced by calls to this.
548
549 Perl automatically handles most of the common
550 ways a method might be redefined.  However, there
551 are a few ways you could change a method in a stash
552 without the cache code noticing, in which case you
553 need to call this method afterwards:
554
555 1) Directly manipulating the stash HV entries from
556 XS code.
557
558 2) Assigning a reference to a readonly scalar
559 constant into a stash entry in order to create
560 a constant subroutine (like constant.pm
561 does).
562
563 This same method is available from pure perl
564 via, C<mro::method_changed_in(classname)>.
565
566 =cut
567 */
568 void
569 Perl_mro_method_changed_in(pTHX_ HV *stash)
570 {
571     SV** svp;
572     HV* isarev;
573     HE* iter;
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;
582
583     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
584        invalidate all method caches globally */
585     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
586         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
587         PL_sub_generation++;
588         return;
589     }
590
591     /* else, invalidate the method caches of all child classes,
592        but not itself */
593     if(isarev) {
594         hv_iterinit(isarev);
595         while((iter = hv_iternext(isarev))) {
596             SV* revkey = hv_iterkeysv(iter);
597             HV* revstash = gv_stashsv(revkey, 0);
598             struct mro_meta* mrometa;
599
600             if(!revstash) continue;
601             mrometa = HvMROMETA(revstash);
602             mrometa->cache_gen++;
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
614 STATIC 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
623 STATIC 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
723     /* Initialize the next::method cache for this stash
724        if necessary */
725     selfmeta = HvMROMETA(selfstash);
726     if(!(nmcache = selfmeta->mro_nextmethod)) {
727         nmcache = selfmeta->mro_nextmethod = newHV();
728     }
729
730     /* Use the cached coderef if it exists */
731     else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
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
750     /* Walk down our MRO, skipping everything up
751        to the contextually enclosing class */
752     while (items--) {
753         linear_sv = *linear_svp++;
754         assert(linear_sv);
755         if(sv_eq(linear_sv, stashname))
756             break;
757     }
758
759     /* Now search the remainder of the MRO for the
760        same method name as the contextually enclosing
761        method */
762     if(items > 0) {
763         while (items--) {
764             linear_sv = *linear_svp++;
765             assert(linear_sv);
766             curstash = gv_stashsv(linear_sv, FALSE);
767
768             if (!curstash) {
769                 if (ckWARN(WARN_SYNTAX))
770                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
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);
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 */
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
805 XS(XS_mro_get_linear_isa);
806 XS(XS_mro_set_mro);
807 XS(XS_mro_get_mro);
808 XS(XS_mro_get_isarev);
809 XS(XS_mro_is_universal);
810 XS(XS_mro_invalidate_method_caches);
811 XS(XS_mro_method_changed_in);
812 XS(XS_next_can);
813 XS(XS_next_method);
814 XS(XS_maybe_next_method);
815
816 void
817 Perl_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, "$");
827     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
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
834 XS(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
868 XS(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 */
900         meta->cache_gen++;
901         if(meta->mro_nextmethod)
902             hv_clear(meta->mro_nextmethod);
903     }
904
905     XSRETURN_EMPTY;
906 }
907
908
909 XS(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
935 XS(XS_mro_get_isarev)
936 {
937     dVAR;
938     dXSARGS;
939     SV* classname;
940     HV* class_stash;
941     SV** svp;
942     HV* isarev;
943     char* stashname;
944     STRLEN stashname_len;
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     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) {
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
973 XS(XS_mro_is_universal)
974 {
975     dVAR;
976     dXSARGS;
977     SV* classname;
978     HV* class_stash;
979     HV* isarev;
980     char* stashname;
981     STRLEN stashname_len;
982     SV** svp;
983
984     PERL_UNUSED_ARG(cv);
985
986     if (items != 1)
987        Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
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
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)))
1001         XSRETURN_YES;
1002     else
1003         XSRETURN_NO;
1004 }
1005
1006 XS(XS_mro_invalidate_method_caches)
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
1021 XS(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
1043 XS(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
1063 XS(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
1076 XS(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  */