This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5c1a9704289fe200c830b89e3c7e6e0f67a770a4
[perl5.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->sub_generation = 1;
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 */
54 struct mro_meta*
55 Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
56 {
57     struct mro_meta* newmeta;
58
59     assert(smeta);
60
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));
76
77     return newmeta;
78 }
79
80 #endif /* USE_ITHREADS */
81
82 /*
83 =for apidoc mro_get_linear_isa_dfs
84
85 Returns the Depth-First Search linearization of @ISA
86 the given stash.  The return value is a read-only AV*.
87 C<level> should be 0 (it is used internally in this
88 function's recursion).
89
90 You are responsible for C<SvREFCNT_inc()> on the
91 return value if you plan to store it anywhere
92 semi-permanently (otherwise it might be deleted
93 out from under you the next time the cache is
94 invalidated).
95
96 =cut
97 */
98 AV*
99 Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
100 {
101     AV* retval;
102     GV** gvp;
103     GV* gv;
104     AV* av;
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);
121
122     /* return cache if valid */
123     if((retval = meta->mro_linear_dfs)) {
124         return retval;
125     }
126
127     /* not in cache, make a new one */
128
129     retval = newAV();
130     av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
131
132     /* fetch our @ISA */
133     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
134     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
135
136     if(av && AvFILLp(av) >= 0) {
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
143         HV* stored = (HV*)sv_2mortal((SV*)newHV());
144         SV **svp = AvARRAY(av);
145         I32 items = AvFILLp(av) + 1;
146
147         /* foreach(@ISA) */
148         while (items--) {
149             SV* const sv = *svp++;
150             HV* const basestash = gv_stashsv(sv, 0);
151             SV *const *subrv_p;
152             I32 subrv_items;
153
154             if (!basestash) {
155                 /* if no stash exists for this @ISA member,
156                    simply add it to the MRO and move on */
157                 subrv_p = &sv;
158                 subrv_items = 1;
159             }
160             else {
161                 /* otherwise, recurse into ourselves for the MRO
162                    of this @ISA member, and append their MRO to ours */
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)) {
172                     hv_store_ent(stored, subsv, &PL_sv_undef, 0);
173                     av_push(retval, newSVsv(subsv));
174                 }
175             }
176         }
177     }
178
179     /* we don't want anyone modifying the cache entry but us,
180        and we do so by replacing it completely */
181     SvREADONLY_on(retval);
182
183     meta->mro_linear_dfs = retval;
184     return retval;
185 }
186
187 /*
188 =for apidoc mro_get_linear_isa_c3
189
190 Returns the C3 linearization of @ISA
191 the given stash.  The return value is a read-only AV*.
192 C<level> should be 0 (it is used internally in this
193 function's recursion).
194
195 You are responsible for C<SvREFCNT_inc()> on the
196 return value if you plan to store it anywhere
197 semi-permanently (otherwise it might be deleted
198 out from under you the next time the cache is
199 invalidated).
200
201 =cut
202 */
203
204 AV*
205 Perl_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);
229
230     /* return cache if valid */
231     if((retval = meta->mro_linear_c3)) {
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
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     */
248
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());
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         */
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) {
267                 /* if no stash, make a temporary fake MRO
268                    containing just itself */
269                 isa_lin = (AV*)sv_2mortal((SV*)newAV());
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             }
275             av_push(seqs, (SV*)isa_lin);
276         }
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         */
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
310         /* This loop won't terminate until we either finish building
311            the MRO, or get an exception. */
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;
319             int s;
320
321             /* "foreach $seq (@seqs)" */
322             SV** avptr = AvARRAY(seqs);
323             for(s = 0; s <= AvFILLp(seqs); s++) {
324                 SV** svp;
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 */
329                 if(!winner) {
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 */
335                     cand = seqhead;
336                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
337                        && (val = HeVAL(tail_entry))
338                        && (SvIVX(val) > 0))
339                            continue;
340                     winner = newSVsv(cand);
341                     av_push(retval, winner);
342                     /* note however that even when we find a winner,
343                        we continue looping over @seqs to do housekeeping */
344                 }
345                 if(!sv_cmp(seqhead, winner)) {
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                     }
366                 }
367             }
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 */
378             if(!winner) {
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
385                 SvREFCNT_dec(retval);
386                 Safefree(heads);
387
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
394     /* we don't want anyone modifying the cache entry but us,
395        and we do so by replacing it completely */
396     SvREADONLY_on(retval);
397
398     meta->mro_linear_c3 = retval;
399     return retval;
400 }
401
402 /*
403 =for apidoc mro_get_linear_isa
404
405 Returns either C<mro_get_linear_isa_c3> or
406 C<mro_get_linear_isa_dfs> for the given stash,
407 dependant upon which MRO is in effect
408 for that stash.  The return value is a
409 read-only AV*.
410
411 You are responsible for C<SvREFCNT_inc()> on the
412 return value if you plan to store it anywhere
413 semi-permanently (otherwise it might be deleted
414 out from under you the next time the cache is
415 invalidated).
416
417 =cut
418 */
419 AV*
420 Perl_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 {
432         Perl_croak(aTHX_ "panic: invalid MRO!");
433     }
434     return NULL; /* NOT REACHED */
435 }
436
437 /*
438 =for apidoc mro_isa_changed_in
439
440 Takes the necessary steps (cache invalidations, mostly)
441 when the @ISA of the given package has changed.  Invoked
442 by the C<setisa> magic, should not need to invoke directly.
443
444 =cut
445 */
446 void
447 Perl_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;
487
488             if(!revstash) continue;
489             revmeta = HvMROMETA(revstash);
490             SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
491             SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
492             revmeta->mro_linear_dfs = NULL;
493             revmeta->mro_linear_c3 = NULL;
494             if(!meta->is_universal)
495                 revmeta->sub_generation++;
496             if(revmeta->mro_nextmethod)
497                 hv_clear(revmeta->mro_nextmethod);
498         }
499     }
500
501     /* Now iterate our MRO (parents), and do a few things:
502          1) instantiate with the "fake" flag if they don't exist
503          2) flag them as universal if we are universal
504          3) Add everything from our isarev to their isarev
505     */
506
507     /* We're starting at the 2nd element, skipping ourselves here */
508     linear_mro = mro_get_linear_isa(stash);
509     svp = AvARRAY(linear_mro) + 1;
510     items = AvFILLp(linear_mro);
511
512     while (items--) {
513         SV* const sv = *svp++;
514         struct mro_meta* mrometa;
515         HV* mroisarev;
516
517         HV* mrostash = gv_stashsv(sv, 0);
518         if(!mrostash) {
519             mrostash = gv_stashsv(sv, GV_ADD);
520             /*
521                We created the package on the fly, so
522                that we could store isarev information.
523                This flag lets gv_fetchmeth know about it,
524                so that it can still generate the very useful
525                "Can't locate package Foo for @Bar::ISA" warning.
526             */
527             HvMROMETA(mrostash)->fake = 1;
528         }
529
530         mrometa = HvMROMETA(mrostash);
531         mroisarev = mrometa->mro_isarev;
532
533         /* is_universal is viral */
534         if(meta->is_universal)
535             mrometa->is_universal = 1;
536
537         if(!mroisarev)
538             mroisarev = mrometa->mro_isarev = newHV();
539
540         /* This hash only ever contains PL_sv_yes. Storing it over itself is
541            almost as cheap as calling hv_exists, so on aggregate we expect to
542            save time by not making two calls to the common HV code for the
543            case where it doesn't exist.  */
544            
545         hv_store(mroisarev, stashname, strlen(stashname), &PL_sv_yes, 0);
546
547         if(isarev) {
548             hv_iterinit(isarev);
549             while((iter = hv_iternext(isarev))) {
550                 SV* revkey = hv_iterkeysv(iter);
551                 hv_store_ent(mroisarev, revkey, &PL_sv_yes, 0);
552             }
553         }
554     }
555 }
556
557 /*
558 =for apidoc mro_method_changed_in
559
560 Invalidates method caching on any child classes
561 of the given stash, so that they might notice
562 the changes in this one.
563
564 Ideally, all instances of C<PL_sub_generation++> in
565 the perl source outside of C<mro.c> should be
566 replaced by calls to this.  This conversion is
567 nearly complete.
568
569 Perl has always had problems with method caches
570 getting out of sync when one directly manipulates
571 stashes via things like C<%{Foo::} = %{Bar::}> or 
572 C<${Foo::}{bar} = ...> or the equivalent.  If
573 you do this in core or XS code, call this afterwards
574 on the destination stash to get things back in sync.
575
576 If you're doing such a thing from pure perl, use
577 C<mro::method_changed_in(classname)>, which
578 just calls this.
579
580 =cut
581 */
582 void
583 Perl_mro_method_changed_in(pTHX_ HV *stash)
584 {
585     struct mro_meta* meta = HvMROMETA(stash);
586     HV* isarev;
587     HE* iter;
588
589     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
590        invalidate all method caches globally */
591     if(meta->is_universal) {
592         PL_sub_generation++;
593         return;
594     }
595
596     /* else, invalidate the method caches of all child classes,
597        but not itself */
598     if((isarev = meta->mro_isarev)) {
599         hv_iterinit(isarev);
600         while((iter = hv_iternext(isarev))) {
601             SV* revkey = hv_iterkeysv(iter);
602             HV* revstash = gv_stashsv(revkey, 0);
603             struct mro_meta* mrometa;
604
605             if(!revstash) continue;
606             mrometa = HvMROMETA(revstash);
607             mrometa->sub_generation++;
608             if(mrometa->mro_nextmethod)
609                 hv_clear(mrometa->mro_nextmethod);
610         }
611     }
612 }
613
614 /* These two are static helpers for next::method and friends,
615    and re-implement a bunch of the code from pp_caller() in
616    a more efficient manner for this particular usage.
617 */
618
619 STATIC I32
620 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
621     I32 i;
622     for (i = startingblock; i >= 0; i--) {
623         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
624     }
625     return i;
626 }
627
628 STATIC SV*
629 __nextcan(pTHX_ SV* self, I32 throw_nomethod)
630 {
631     register I32 cxix;
632     register const PERL_CONTEXT *ccstack = cxstack;
633     const PERL_SI *top_si = PL_curstackinfo;
634     HV* selfstash;
635     GV* cvgv;
636     SV *stashname;
637     const char *fq_subname;
638     const char *subname;
639     STRLEN fq_subname_len;
640     STRLEN stashname_len;
641     STRLEN subname_len;
642     SV* sv;
643     GV** gvp;
644     AV* linear_av;
645     SV** linear_svp;
646     SV* linear_sv;
647     HV* curstash;
648     GV* candidate = NULL;
649     CV* cand_cv = NULL;
650     const char *hvname;
651     I32 items;
652     struct mro_meta* selfmeta;
653     HV* nmcache;
654     HE* cache_entry;
655
656     if(sv_isobject(self))
657         selfstash = SvSTASH(SvRV(self));
658     else
659         selfstash = gv_stashsv(self, 0);
660
661     assert(selfstash);
662
663     hvname = HvNAME_get(selfstash);
664     if (!hvname)
665         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
666
667     cxix = __dopoptosub_at(cxstack, cxstack_ix);
668
669     /* This block finds the contextually-enclosing fully-qualified subname,
670        much like looking at (caller($i))[3] until you find a real sub that
671        isn't ANON, etc */
672     for (;;) {
673         /* we may be in a higher stacklevel, so dig down deeper */
674         while (cxix < 0) {
675             if(top_si->si_type == PERLSI_MAIN)
676                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
677             top_si = top_si->si_prev;
678             ccstack = top_si->si_cxstack;
679             cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
680         }
681
682         if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
683           || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
684             cxix = __dopoptosub_at(ccstack, cxix - 1);
685             continue;
686         }
687
688         {
689             const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
690             if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
691                 if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
692                     cxix = dbcxix;
693                     continue;
694                 }
695             }
696         }
697
698         cvgv = CvGV(ccstack[cxix].blk_sub.cv);
699
700         if(!isGV(cvgv)) {
701             cxix = __dopoptosub_at(ccstack, cxix - 1);
702             continue;
703         }
704
705         /* we found a real sub here */
706         sv = sv_2mortal(newSV(0));
707
708         gv_efullname3(sv, cvgv, NULL);
709
710         fq_subname = SvPVX(sv);
711         fq_subname_len = SvCUR(sv);
712
713         subname = strrchr(fq_subname, ':');
714         if(!subname)
715             Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
716
717         subname++;
718         subname_len = fq_subname_len - (subname - fq_subname);
719         if(subname_len == 8 && strEQ(subname, "__ANON__")) {
720             cxix = __dopoptosub_at(ccstack, cxix - 1);
721             continue;
722         }
723         break;
724     }
725
726     /* If we made it to here, we found our context */
727
728     /* Initialize the next::method cache for this stash
729        if necessary */
730     selfmeta = HvMROMETA(selfstash);
731     if(!(nmcache = selfmeta->mro_nextmethod)) {
732         nmcache = selfmeta->mro_nextmethod = newHV();
733     }
734
735     /* Use the cached coderef if it exists */
736     else if((cache_entry = hv_fetch_ent(nmcache, sv, 0, 0))) {
737         SV* val = HeVAL(cache_entry);
738         if(val == &PL_sv_undef) {
739             if(throw_nomethod)
740                 Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
741         }
742         return val;
743     }
744
745     /* beyond here is just for cache misses, so perf isn't as critical */
746
747     stashname_len = subname - fq_subname - 2;
748     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
749
750     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
751
752     linear_svp = AvARRAY(linear_av);
753     items = AvFILLp(linear_av) + 1;
754
755     /* Walk down our MRO, skipping everything up
756        to the contextually enclosing class */
757     while (items--) {
758         linear_sv = *linear_svp++;
759         assert(linear_sv);
760         if(sv_eq(linear_sv, stashname))
761             break;
762     }
763
764     /* Now search the remainder of the MRO for the
765        same method name as the contextually enclosing
766        method */
767     if(items > 0) {
768         while (items--) {
769             linear_sv = *linear_svp++;
770             assert(linear_sv);
771             curstash = gv_stashsv(linear_sv, FALSE);
772
773             if (!curstash || (HvMROMETA(curstash)->fake && !HvFILL(curstash))) {
774                 if (ckWARN(WARN_SYNTAX))
775                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
776                         (void*)linear_sv, hvname);
777                 continue;
778             }
779
780             assert(curstash);
781
782             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
783             if (!gvp) continue;
784
785             candidate = *gvp;
786             assert(candidate);
787
788             if (SvTYPE(candidate) != SVt_PVGV)
789                 gv_init(candidate, curstash, subname, subname_len, TRUE);
790
791             /* Notably, we only look for real entries, not method cache
792                entries, because in C3 the method cache of a parent is not
793                valid for the child */
794             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
795                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
796                 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
797                 return (SV*)cand_cv;
798             }
799         }
800     }
801
802     hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
803     if(throw_nomethod)
804         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
805     return &PL_sv_undef;
806 }
807
808 #include "XSUB.h"
809
810 XS(XS_mro_get_linear_isa);
811 XS(XS_mro_set_mro);
812 XS(XS_mro_get_mro);
813 XS(XS_mro_get_isarev);
814 XS(XS_mro_is_universal);
815 XS(XS_mro_get_global_sub_gen);
816 XS(XS_mro_invalidate_method_caches);
817 XS(XS_mro_get_sub_generation);
818 XS(XS_mro_method_changed_in);
819 XS(XS_next_can);
820 XS(XS_next_method);
821 XS(XS_maybe_next_method);
822
823 void
824 Perl_boot_core_mro(pTHX)
825 {
826     dVAR;
827     static const char file[] = __FILE__;
828
829     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
830     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
831     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
832     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
833     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
834     newXSproto("mro::get_global_sub_generation", XS_mro_get_global_sub_gen, file, "");
835     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
836     newXSproto("mro::get_sub_generation", XS_mro_get_sub_generation, file, "$");
837     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
838     newXS("next::can", XS_next_can, file);
839     newXS("next::method", XS_next_method, file);
840     newXS("maybe::next::method", XS_maybe_next_method, file);
841 }
842
843 XS(XS_mro_get_linear_isa) {
844     dVAR;
845     dXSARGS;
846     AV* RETVAL;
847     HV* class_stash;
848     SV* classname;
849
850     PERL_UNUSED_ARG(cv);
851
852     if(items < 1 || items > 2)
853        Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
854
855     classname = ST(0);
856     class_stash = gv_stashsv(classname, 0);
857     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
858
859     if(items > 1) {
860         char* which = SvPV_nolen(ST(1));
861         if(strEQ(which, "dfs"))
862             RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
863         else if(strEQ(which, "c3"))
864             RETVAL = mro_get_linear_isa_c3(class_stash, 0);
865         else
866             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
867     }
868     else {
869         RETVAL = mro_get_linear_isa(class_stash);
870     }
871
872     ST(0) = newRV_inc((SV*)RETVAL);
873     sv_2mortal(ST(0));
874     XSRETURN(1);
875 }
876
877 XS(XS_mro_set_mro)
878 {
879     dVAR;
880     dXSARGS;
881     SV* classname;
882     char* whichstr;
883     mro_alg which;
884     HV* class_stash;
885     struct mro_meta* meta;
886
887     PERL_UNUSED_ARG(cv);
888
889     if (items != 2)
890        Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
891
892     classname = ST(0);
893     whichstr = SvPV_nolen(ST(1));
894     class_stash = gv_stashsv(classname, GV_ADD);
895     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
896     meta = HvMROMETA(class_stash);
897
898     if(strEQ(whichstr, "dfs"))
899         which = MRO_DFS;
900     else if(strEQ(whichstr, "c3"))
901         which = MRO_C3;
902     else
903         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
904
905     if(meta->mro_which != which) {
906         meta->mro_which = which;
907         /* Only affects local method cache, not
908            even child classes */
909         meta->sub_generation++;
910         if(meta->mro_nextmethod)
911             hv_clear(meta->mro_nextmethod);
912     }
913
914     XSRETURN_EMPTY;
915 }
916
917
918 XS(XS_mro_get_mro)
919 {
920     dVAR;
921     dXSARGS;
922     SV* classname;
923     HV* class_stash;
924     struct mro_meta* meta;
925
926     PERL_UNUSED_ARG(cv);
927
928     if (items != 1)
929        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
930
931     classname = ST(0);
932     class_stash = gv_stashsv(classname, 0);
933     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
934     meta = HvMROMETA(class_stash);
935
936     if(meta->mro_which == MRO_DFS)
937         ST(0) = sv_2mortal(newSVpvn("dfs", 3));
938     else
939         ST(0) = sv_2mortal(newSVpvn("c3", 2));
940
941     XSRETURN(1);
942 }
943
944 XS(XS_mro_get_isarev)
945 {
946     dVAR;
947     dXSARGS;
948     SV* classname;
949     HV* class_stash;
950     HV* isarev;
951
952     PERL_UNUSED_ARG(cv);
953
954     if (items != 1)
955        Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
956
957     classname = ST(0);
958
959     class_stash = gv_stashsv(classname, 0);
960     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
961
962     SP -= items;
963    
964     if((isarev = HvMROMETA(class_stash)->mro_isarev)) {
965         HE* iter;
966         hv_iterinit(isarev);
967         while((iter = hv_iternext(isarev)))
968             XPUSHs(hv_iterkeysv(iter));
969     }
970
971     PUTBACK;
972     return;
973 }
974
975 XS(XS_mro_is_universal)
976 {
977     dVAR;
978     dXSARGS;
979     SV* classname;
980     HV* class_stash;
981
982     PERL_UNUSED_ARG(cv);
983
984     if (items != 1)
985        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
986
987     classname = ST(0);
988     class_stash = gv_stashsv(classname, 0);
989     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
990
991     if (HvMROMETA(class_stash)->is_universal)
992         XSRETURN_YES;
993     else
994         XSRETURN_NO;
995 }
996
997 XS(XS_mro_get_global_sub_gen)
998 {
999     dVAR;
1000     dXSARGS;
1001
1002     PERL_UNUSED_ARG(cv);
1003
1004     if (items != 0)
1005         Perl_croak(aTHX_ "Usage: mro::get_global_sub_generation()");
1006
1007     ST(0) = sv_2mortal(newSViv(PL_sub_generation));
1008     XSRETURN(1);
1009 }
1010
1011 XS(XS_mro_invalidate_method_caches)
1012 {
1013     dVAR;
1014     dXSARGS;
1015
1016     PERL_UNUSED_ARG(cv);
1017
1018     if (items != 0)
1019         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
1020
1021     PL_sub_generation++;
1022
1023     XSRETURN_EMPTY;
1024 }
1025
1026 XS(XS_mro_get_sub_generation)
1027 {
1028     dVAR;
1029     dXSARGS;
1030     SV* classname;
1031     HV* class_stash;
1032
1033     PERL_UNUSED_ARG(cv);
1034
1035     if(items != 1)
1036         Perl_croak(aTHX_ "Usage: mro::get_sub_generation(classname)");
1037
1038     classname = ST(0);
1039     class_stash = gv_stashsv(classname, 0);
1040     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1041
1042     ST(0) = sv_2mortal(newSViv(HvMROMETA(class_stash)->sub_generation));
1043     XSRETURN(1);
1044 }
1045
1046 XS(XS_mro_method_changed_in)
1047 {
1048     dVAR;
1049     dXSARGS;
1050     SV* classname;
1051     HV* class_stash;
1052
1053     PERL_UNUSED_ARG(cv);
1054
1055     if(items != 1)
1056         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
1057     
1058     classname = ST(0);
1059
1060     class_stash = gv_stashsv(classname, 0);
1061     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
1062
1063     mro_method_changed_in(class_stash);
1064
1065     XSRETURN_EMPTY;
1066 }
1067
1068 XS(XS_next_can)
1069 {
1070     dVAR;
1071     dXSARGS;
1072     SV* self = ST(0);
1073     SV* methcv = __nextcan(aTHX_ self, 0);
1074
1075     PERL_UNUSED_ARG(cv);
1076     PERL_UNUSED_VAR(items);
1077
1078     if(methcv == &PL_sv_undef) {
1079         ST(0) = &PL_sv_undef;
1080     }
1081     else {
1082         ST(0) = sv_2mortal(newRV_inc(methcv));
1083     }
1084
1085     XSRETURN(1);
1086 }
1087
1088 XS(XS_next_method)
1089 {
1090     dMARK;
1091     dAX;
1092     SV* self = ST(0);
1093     SV* methcv = __nextcan(aTHX_ self, 1);
1094
1095     PERL_UNUSED_ARG(cv);
1096
1097     PL_markstack_ptr++;
1098     call_sv(methcv, GIMME_V);
1099 }
1100
1101 XS(XS_maybe_next_method)
1102 {
1103     dMARK;
1104     dAX;
1105     SV* self = ST(0);
1106     SV* methcv = __nextcan(aTHX_ self, 0);
1107
1108     PERL_UNUSED_ARG(cv);
1109
1110     if(methcv == &PL_sv_undef) {
1111         ST(0) = &PL_sv_undef;
1112         XSRETURN(1);
1113     }
1114
1115     PL_markstack_ptr++;
1116     call_sv(methcv, GIMME_V);
1117 }
1118
1119 /*
1120  * Local variables:
1121  * c-indentation-style: bsd
1122  * c-basic-offset: 4
1123  * indent-tabs-mode: t
1124  * End:
1125  *
1126  * ex: set ts=8 sts=4 sw=4 noet:
1127  */