This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
7074e7ab72b71b7eb860f6bded99b9c6913cd49b
[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->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     AV* tmp_retval; /* mortal to avoid leaks */
91     GV** gvp;
92     GV* gv;
93     AV* av;
94     const char* stashname;
95     struct mro_meta* meta;
96
97     assert(stash);
98     assert(HvAUX(stash));
99
100     stashname = HvNAME_get(stash);
101     if (!stashname)
102       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
103
104     if (level > 100)
105         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
106               stashname);
107
108     meta = HvMROMETA(stash);
109
110     /* return cache if valid */
111     if((retval = meta->mro_linear_dfs)) {
112         return retval;
113     }
114
115     /* not in cache, make a new one */
116
117     tmp_retval = (AV*)sv_2mortal((SV*)newAV());
118     av_push(tmp_retval, newSVpv(stashname, 0)); /* add ourselves at the top */
119
120     /* fetch our @ISA */
121     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
122     av = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
123
124     if(av && AvFILLp(av) >= 0) {
125
126         /* "stored" is used to keep track of all of the classnames
127            we have added to the MRO so far, so we can do a quick
128            exists check and avoid adding duplicate classnames to
129            the MRO as we go. */
130
131         HV* const stored = (HV*)sv_2mortal((SV*)newHV());
132         SV **svp = AvARRAY(av);
133         I32 items = AvFILLp(av) + 1;
134
135         /* foreach(@ISA) */
136         while (items--) {
137             SV* const sv = *svp++;
138             HV* const basestash = gv_stashsv(sv, 0);
139             SV *const *subrv_p;
140             I32 subrv_items;
141
142             if (!basestash) {
143                 /* if no stash exists for this @ISA member,
144                    simply add it to the MRO and move on */
145                 subrv_p = &sv;
146                 subrv_items = 1;
147             }
148             else {
149                 /* otherwise, recurse into ourselves for the MRO
150                    of this @ISA member, and append their MRO to ours.
151                    The recursive call could throw an exception, which
152                    has memory management implications here (tmp_retval) */
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(tmp_retval, newSVsv(subsv));
164                 }
165             }
166         }
167     }
168
169     /* make the real retval out of tmp_retval, now that we're
170        past the exception dangers */
171     retval = av_make(AvFILLp(tmp_retval)+1, AvARRAY(tmp_retval));
172
173     /* we don't want anyone modifying the cache entry but us,
174        and we do so by replacing it completely */
175     SvREADONLY_on(retval);
176
177     meta->mro_linear_dfs = retval;
178     return retval;
179 }
180
181 /*
182 =for apidoc mro_get_linear_isa_c3
183
184 Returns the C3 linearization of @ISA
185 the given stash.  The return value is a read-only AV*.
186 C<level> should be 0 (it is used internally in this
187 function's recursion).
188
189 You are responsible for C<SvREFCNT_inc()> on the
190 return value if you plan to store it anywhere
191 semi-permanently (otherwise it might be deleted
192 out from under you the next time the cache is
193 invalidated).
194
195 =cut
196 */
197
198 AV*
199 Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
200 {
201     AV* retval;
202     GV** gvp;
203     GV* gv;
204     AV* isa;
205     const char* stashname;
206     STRLEN stashname_len;
207     struct mro_meta* meta;
208
209     assert(stash);
210     assert(HvAUX(stash));
211
212     stashname = HvNAME_get(stash);
213     stashname_len = HvNAMELEN_get(stash);
214     if (!stashname)
215       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
216
217     if (level > 100)
218         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
219               stashname);
220
221     meta = HvMROMETA(stash);
222
223     /* return cache if valid */
224     if((retval = meta->mro_linear_c3)) {
225         return retval;
226     }
227
228     /* not in cache, make a new one */
229
230     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
231     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
232
233     /* For a better idea how the rest of this works, see the much clearer
234        pure perl version in Algorithm::C3 0.01:
235        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
236        (later versions go about it differently than this code for speed reasons)
237     */
238
239     if(isa && AvFILLp(isa) >= 0) {
240         SV** seqs_ptr;
241         I32 seqs_items;
242         HV* const tails = (HV*)sv_2mortal((SV*)newHV());
243         AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
244         I32* heads;
245
246         /* This builds @seqs, which is an array of arrays.
247            The members of @seqs are the MROs of
248            the members of @ISA, followed by @ISA itself.
249         */
250         I32 items = AvFILLp(isa) + 1;
251         SV** isa_ptr = AvARRAY(isa);
252         while(items--) {
253             SV* const isa_item = *isa_ptr++;
254             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
255             if(!isa_item_stash) {
256                 /* if no stash, make a temporary fake MRO
257                    containing just itself */
258                 AV* const isa_lin = newAV();
259                 av_push(isa_lin, newSVsv(isa_item));
260                 av_push(seqs, (SV*)isa_lin);
261             }
262             else {
263                 /* recursion */
264                 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
265                 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
266             }
267         }
268         av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
269
270         /* This builds "heads", which as an array of integer array
271            indices, one per seq, which point at the virtual "head"
272            of the seq (initially zero) */
273         Newxz(heads, AvFILLp(seqs)+1, I32);
274
275         /* This builds %tails, which has one key for every class
276            mentioned in the tail of any sequence in @seqs (tail meaning
277            everything after the first class, the "head").  The value
278            is how many times this key appears in the tails of @seqs.
279         */
280         seqs_ptr = AvARRAY(seqs);
281         seqs_items = AvFILLp(seqs) + 1;
282         while(seqs_items--) {
283             AV* const seq = (AV*)*seqs_ptr++;
284             I32 seq_items = AvFILLp(seq);
285             if(seq_items > 0) {
286                 SV** seq_ptr = AvARRAY(seq) + 1;
287                 while(seq_items--) {
288                     SV* const seqitem = *seq_ptr++;
289                     HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
290                     if(!he) {
291                         hv_store_ent(tails, seqitem, newSViv(1), 0);
292                     }
293                     else {
294                         SV* const val = HeVAL(he);
295                         sv_inc(val);
296                     }
297                 }
298             }
299         }
300
301         /* Initialize retval to build the return value in */
302         retval = newAV();
303         av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
304
305         /* This loop won't terminate until we either finish building
306            the MRO, or get an exception. */
307         while(1) {
308             SV* cand = NULL;
309             SV* winner = NULL;
310             int s;
311
312             /* "foreach $seq (@seqs)" */
313             SV** const avptr = AvARRAY(seqs);
314             for(s = 0; s <= AvFILLp(seqs); s++) {
315                 SV** svp;
316                 AV * const seq = (AV*)(avptr[s]);
317                 SV* seqhead;
318                 if(!seq) continue; /* skip empty seqs */
319                 svp = av_fetch(seq, heads[s], 0);
320                 seqhead = *svp; /* seqhead = head of this seq */
321                 if(!winner) {
322                     HE* tail_entry;
323                     SV* val;
324                     /* if we haven't found a winner for this round yet,
325                        and this seqhead is not in tails (or the count
326                        for it in tails has dropped to zero), then this
327                        seqhead is our new winner, and is added to the
328                        final MRO immediately */
329                     cand = seqhead;
330                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
331                        && (val = HeVAL(tail_entry))
332                        && (SvIVX(val) > 0))
333                            continue;
334                     winner = newSVsv(cand);
335                     av_push(retval, winner);
336                     /* note however that even when we find a winner,
337                        we continue looping over @seqs to do housekeeping */
338                 }
339                 if(!sv_cmp(seqhead, winner)) {
340                     /* Once we have a winner (including the iteration
341                        where we first found him), inc the head ptr
342                        for any seq which had the winner as a head,
343                        NULL out any seq which is now empty,
344                        and adjust tails for consistency */
345
346                     const int new_head = ++heads[s];
347                     if(new_head > AvFILLp(seq)) {
348                         SvREFCNT_dec(avptr[s]);
349                         avptr[s] = NULL;
350                     }
351                     else {
352                         HE* tail_entry;
353                         SV* val;
354                         /* Because we know this new seqhead used to be
355                            a tail, we can assume it is in tails and has
356                            a positive value, which we need to dec */
357                         svp = av_fetch(seq, new_head, 0);
358                         seqhead = *svp;
359                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
360                         val = HeVAL(tail_entry);
361                         sv_dec(val);
362                     }
363                 }
364             }
365
366             /* if we found no candidates, we are done building the MRO.
367                !cand means no seqs have any entries left to check */
368             if(!cand) {
369                 Safefree(heads);
370                 break;
371             }
372
373             /* If we had candidates, but nobody won, then the @ISA
374                hierarchy is not C3-incompatible */
375             if(!winner) {
376                 /* we have to do some cleanup before we croak */
377
378                 SvREFCNT_dec(retval);
379                 Safefree(heads);
380
381                 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
382                     "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
383             }
384         }
385     }
386     else { /* @ISA was undefined or empty */
387         /* build a retval containing only ourselves */
388         retval = newAV();
389         av_push(retval, newSVpvn(stashname, stashname_len));
390     }
391
392     /* we don't want anyone modifying the cache entry but us,
393        and we do so by replacing it completely */
394     SvREADONLY_on(retval);
395
396     meta->mro_linear_c3 = retval;
397     return retval;
398 }
399
400 /*
401 =for apidoc mro_get_linear_isa
402
403 Returns either C<mro_get_linear_isa_c3> or
404 C<mro_get_linear_isa_dfs> for the given stash,
405 dependant upon which MRO is in effect
406 for that stash.  The return value is a
407 read-only AV*.
408
409 You are responsible for C<SvREFCNT_inc()> on the
410 return value if you plan to store it anywhere
411 semi-permanently (otherwise it might be deleted
412 out from under you the next time the cache is
413 invalidated).
414
415 =cut
416 */
417 AV*
418 Perl_mro_get_linear_isa(pTHX_ HV *stash)
419 {
420     struct mro_meta* meta;
421
422     assert(stash);
423     if(!SvOOK(stash))
424         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
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     bool is_universal;
456     struct mro_meta * meta;
457
458     const char * const stashname = stash ? HvNAME_get(stash) : NULL;
459     const STRLEN stashname_len = stash ? HvNAMELEN_get(stash) : 0;
460
461     if(!stash) return;
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  */