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