This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
37573f1eecca5fcb4b69db138602b5d1eaf5665f
[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 = HvNAME_get(stash);
459     const STRLEN stashname_len = HvNAMELEN_get(stash);
460
461     if(!stashname)
462         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
463
464     /* wipe out the cached linearizations for this stash */
465     meta = HvMROMETA(stash);
466     SvREFCNT_dec((SV*)meta->mro_linear_dfs);
467     SvREFCNT_dec((SV*)meta->mro_linear_c3);
468     meta->mro_linear_dfs = NULL;
469     meta->mro_linear_c3 = NULL;
470
471     /* Inc the package generation, since our @ISA changed */
472     meta->pkg_gen++;
473
474     /* Wipe the global method cache if this package
475        is UNIVERSAL or one of its parents */
476
477     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
478     isarev = svp ? (HV*)*svp : NULL;
479
480     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
481         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
482         PL_sub_generation++;
483         is_universal = TRUE;
484     }
485     else { /* Wipe the local method cache otherwise */
486         meta->cache_gen++;
487         is_universal = FALSE;
488     }
489
490     /* wipe next::method cache too */
491     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
492
493     /* Iterate the isarev (classes that are our children),
494        wiping out their linearization and method caches */
495     if(isarev) {
496         hv_iterinit(isarev);
497         while((iter = hv_iternext(isarev))) {
498             SV* const revkey = hv_iterkeysv(iter);
499             HV* revstash = gv_stashsv(revkey, 0);
500             struct mro_meta* revmeta;
501
502             if(!revstash) continue;
503             revmeta = HvMROMETA(revstash);
504             SvREFCNT_dec((SV*)revmeta->mro_linear_dfs);
505             SvREFCNT_dec((SV*)revmeta->mro_linear_c3);
506             revmeta->mro_linear_dfs = NULL;
507             revmeta->mro_linear_c3 = NULL;
508             if(!is_universal)
509                 revmeta->cache_gen++;
510             if(revmeta->mro_nextmethod)
511                 hv_clear(revmeta->mro_nextmethod);
512         }
513     }
514
515     /* Now iterate our MRO (parents), and do a few things:
516          1) instantiate with the "fake" flag if they don't exist
517          2) flag them as universal if we are universal
518          3) Add everything from our isarev to their isarev
519     */
520
521     /* We're starting at the 2nd element, skipping ourselves here */
522     linear_mro = mro_get_linear_isa(stash);
523     svp = AvARRAY(linear_mro) + 1;
524     items = AvFILLp(linear_mro);
525
526     while (items--) {
527         SV* const sv = *svp++;
528         HV* mroisarev;
529
530         HE *he = hv_fetch_ent(PL_isarev, sv, 0, 0);
531         if(!he) {
532             he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
533         }
534         mroisarev = (HV*)HeVAL(he);
535
536         /* This hash only ever contains PL_sv_yes. Storing it over itself is
537            almost as cheap as calling hv_exists, so on aggregate we expect to
538            save time by not making two calls to the common HV code for the
539            case where it doesn't exist.  */
540            
541         hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
542
543         if(isarev) {
544             hv_iterinit(isarev);
545             while((iter = hv_iternext(isarev))) {
546                 I32 revkeylen;
547                 char* const revkey = hv_iterkey(iter, &revkeylen);
548                 hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
549             }
550         }
551     }
552 }
553
554 /*
555 =for apidoc mro_method_changed_in
556
557 Invalidates method caching on any child classes
558 of the given stash, so that they might notice
559 the changes in this one.
560
561 Ideally, all instances of C<PL_sub_generation++> in
562 perl source outside of C<mro.c> should be
563 replaced by calls to this.
564
565 Perl automatically handles most of the common
566 ways a method might be redefined.  However, there
567 are a few ways you could change a method in a stash
568 without the cache code noticing, in which case you
569 need to call this method afterwards:
570
571 1) Directly manipulating the stash HV entries from
572 XS code.
573
574 2) Assigning a reference to a readonly scalar
575 constant into a stash entry in order to create
576 a constant subroutine (like constant.pm
577 does).
578
579 This same method is available from pure perl
580 via, C<mro::method_changed_in(classname)>.
581
582 =cut
583 */
584 void
585 Perl_mro_method_changed_in(pTHX_ HV *stash)
586 {
587     const char * const stashname = HvNAME_get(stash);
588     const STRLEN stashname_len = HvNAMELEN_get(stash);
589
590     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
591     HV * const isarev = svp ? (HV*)*svp : NULL;
592
593     if(!stashname)
594         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
595
596     /* Inc the package generation, since a local method changed */
597     HvMROMETA(stash)->pkg_gen++;
598
599     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
600        invalidate all method caches globally */
601     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
602         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
603         PL_sub_generation++;
604         return;
605     }
606
607     /* else, invalidate the method caches of all child classes,
608        but not itself */
609     if(isarev) {
610         HE* iter;
611
612         hv_iterinit(isarev);
613         while((iter = hv_iternext(isarev))) {
614             SV* const revkey = hv_iterkeysv(iter);
615             HV* const revstash = gv_stashsv(revkey, 0);
616             struct mro_meta* mrometa;
617
618             if(!revstash) continue;
619             mrometa = HvMROMETA(revstash);
620             mrometa->cache_gen++;
621             if(mrometa->mro_nextmethod)
622                 hv_clear(mrometa->mro_nextmethod);
623         }
624     }
625 }
626
627 /* These two are static helpers for next::method and friends,
628    and re-implement a bunch of the code from pp_caller() in
629    a more efficient manner for this particular usage.
630 */
631
632 STATIC I32
633 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
634     I32 i;
635     for (i = startingblock; i >= 0; i--) {
636         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
637     }
638     return i;
639 }
640
641 #include "XSUB.h"
642
643 XS(XS_mro_get_linear_isa);
644 XS(XS_mro_set_mro);
645 XS(XS_mro_get_mro);
646 XS(XS_mro_get_isarev);
647 XS(XS_mro_is_universal);
648 XS(XS_mro_invalidate_method_caches);
649 XS(XS_mro_method_changed_in);
650 XS(XS_mro_get_pkg_gen);
651 XS(XS_mro_nextcan);
652
653 void
654 Perl_boot_core_mro(pTHX)
655 {
656     dVAR;
657     static const char file[] = __FILE__;
658
659     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
660     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
661     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
662     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
663     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
664     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
665     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
666     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
667     newXS("mro::_nextcan", XS_mro_nextcan, file);
668 }
669
670 XS(XS_mro_get_linear_isa) {
671     dVAR;
672     dXSARGS;
673     AV* RETVAL;
674     HV* class_stash;
675     SV* classname;
676
677     PERL_UNUSED_ARG(cv);
678
679     if(items < 1 || items > 2)
680        Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
681
682     classname = ST(0);
683     class_stash = gv_stashsv(classname, 0);
684
685     if(!class_stash) {
686         /* No stash exists yet, give them just the classname */
687         AV* isalin = newAV();
688         av_push(isalin, newSVsv(classname));
689         ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
690         XSRETURN(1);
691     }
692     else if(items > 1) {
693         const char* const which = SvPV_nolen(ST(1));
694         if(strEQ(which, "dfs"))
695             RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
696         else if(strEQ(which, "c3"))
697             RETVAL = mro_get_linear_isa_c3(class_stash, 0);
698         else
699             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
700     }
701     else {
702         RETVAL = mro_get_linear_isa(class_stash);
703     }
704
705     ST(0) = newRV_inc((SV*)RETVAL);
706     sv_2mortal(ST(0));
707     XSRETURN(1);
708 }
709
710 XS(XS_mro_set_mro)
711 {
712     dVAR;
713     dXSARGS;
714     SV* classname;
715     char* whichstr;
716     mro_alg which;
717     HV* class_stash;
718     struct mro_meta* meta;
719
720     PERL_UNUSED_ARG(cv);
721
722     if (items != 2)
723        Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
724
725     classname = ST(0);
726     whichstr = SvPV_nolen(ST(1));
727     class_stash = gv_stashsv(classname, GV_ADD);
728     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
729     meta = HvMROMETA(class_stash);
730
731     if(strEQ(whichstr, "dfs"))
732         which = MRO_DFS;
733     else if(strEQ(whichstr, "c3"))
734         which = MRO_C3;
735     else
736         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
737
738     if(meta->mro_which != which) {
739         meta->mro_which = which;
740         /* Only affects local method cache, not
741            even child classes */
742         meta->cache_gen++;
743         if(meta->mro_nextmethod)
744             hv_clear(meta->mro_nextmethod);
745     }
746
747     XSRETURN_EMPTY;
748 }
749
750
751 XS(XS_mro_get_mro)
752 {
753     dVAR;
754     dXSARGS;
755     SV* classname;
756     HV* class_stash;
757
758     PERL_UNUSED_ARG(cv);
759
760     if (items != 1)
761        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
762
763     classname = ST(0);
764     class_stash = gv_stashsv(classname, 0);
765
766     if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
767         ST(0) = sv_2mortal(newSVpvn("dfs", 3));
768     else
769         ST(0) = sv_2mortal(newSVpvn("c3", 2));
770
771     XSRETURN(1);
772 }
773
774 XS(XS_mro_get_isarev)
775 {
776     dVAR;
777     dXSARGS;
778     SV* classname;
779     SV** svp;
780     HV* isarev;
781     char* classname_pv;
782     STRLEN classname_len;
783     AV* ret_array;
784
785     PERL_UNUSED_ARG(cv);
786
787     if (items != 1)
788        Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
789
790     classname = ST(0);
791
792     SP -= items;
793
794     
795     classname_pv = SvPV_nolen(classname);
796     classname_len = strlen(classname_pv);
797     svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
798     isarev = svp ? (HV*)*svp : NULL;
799
800     ret_array = newAV();
801     if(isarev) {
802         HE* iter;
803         hv_iterinit(isarev);
804         while((iter = hv_iternext(isarev)))
805             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
806     }
807     XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
808
809     PUTBACK;
810     return;
811 }
812
813 XS(XS_mro_is_universal)
814 {
815     dVAR;
816     dXSARGS;
817     SV* classname;
818     HV* isarev;
819     char* classname_pv;
820     STRLEN classname_len;
821     SV** svp;
822
823     PERL_UNUSED_ARG(cv);
824
825     if (items != 1)
826        Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
827
828     classname = ST(0);
829
830     classname_pv = SvPV_nolen(classname);
831     classname_len = strlen(classname_pv);
832
833     svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
834     isarev = svp ? (HV*)*svp : NULL;
835
836     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
837         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
838         XSRETURN_YES;
839     else
840         XSRETURN_NO;
841 }
842
843 XS(XS_mro_invalidate_method_caches)
844 {
845     dVAR;
846     dXSARGS;
847
848     PERL_UNUSED_ARG(cv);
849
850     if (items != 0)
851         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
852
853     PL_sub_generation++;
854
855     XSRETURN_EMPTY;
856 }
857
858 XS(XS_mro_method_changed_in)
859 {
860     dVAR;
861     dXSARGS;
862     SV* classname;
863     HV* class_stash;
864
865     PERL_UNUSED_ARG(cv);
866
867     if(items != 1)
868         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
869     
870     classname = ST(0);
871
872     class_stash = gv_stashsv(classname, 0);
873     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
874
875     mro_method_changed_in(class_stash);
876
877     XSRETURN_EMPTY;
878 }
879
880 XS(XS_mro_get_pkg_gen)
881 {
882     dVAR;
883     dXSARGS;
884     SV* classname;
885     HV* class_stash;
886
887     PERL_UNUSED_ARG(cv);
888
889     if(items != 1)
890         Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
891     
892     classname = ST(0);
893
894     class_stash = gv_stashsv(classname, 0);
895
896     SP -= items;
897
898     XPUSHs(sv_2mortal(newSViv(
899         class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
900     )));
901     
902     PUTBACK;
903     return;
904 }
905
906 XS(XS_mro_nextcan)
907 {
908     dVAR;
909     dXSARGS;
910     SV* self = ST(0);
911     const I32 throw_nomethod = SvIVX(ST(1));
912     register I32 cxix = cxstack_ix;
913     register const PERL_CONTEXT *ccstack = cxstack;
914     const PERL_SI *top_si = PL_curstackinfo;
915     HV* selfstash;
916     SV *stashname;
917     const char *fq_subname;
918     const char *subname;
919     STRLEN stashname_len;
920     STRLEN subname_len;
921     SV* sv;
922     GV** gvp;
923     AV* linear_av;
924     SV** linear_svp;
925     const char *hvname;
926     I32 entries;
927     struct mro_meta* selfmeta;
928     HV* nmcache;
929     I32 i;
930
931     PERL_UNUSED_ARG(cv);
932
933     SP -= items;
934
935     if(sv_isobject(self))
936         selfstash = SvSTASH(SvRV(self));
937     else
938         selfstash = gv_stashsv(self, 0);
939
940     assert(selfstash);
941
942     hvname = HvNAME_get(selfstash);
943     if (!hvname)
944         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
945
946     /* This block finds the contextually-enclosing fully-qualified subname,
947        much like looking at (caller($i))[3] until you find a real sub that
948        isn't ANON, etc (also skips over pureperl next::method, etc) */
949     for(i = 0; i < 2; i++) {
950         cxix = __dopoptosub_at(ccstack, cxix);
951         for (;;) {
952             GV* cvgv;
953             STRLEN fq_subname_len;
954
955             /* we may be in a higher stacklevel, so dig down deeper */
956             while (cxix < 0) {
957                 if(top_si->si_type == PERLSI_MAIN)
958                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
959                 top_si = top_si->si_prev;
960                 ccstack = top_si->si_cxstack;
961                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
962             }
963
964             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
965               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
966                 cxix = __dopoptosub_at(ccstack, cxix - 1);
967                 continue;
968             }
969
970             {
971                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
972                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
973                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
974                         cxix = dbcxix;
975                         continue;
976                     }
977                 }
978             }
979
980             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
981
982             if(!isGV(cvgv)) {
983                 cxix = __dopoptosub_at(ccstack, cxix - 1);
984                 continue;
985             }
986
987             /* we found a real sub here */
988             sv = sv_2mortal(newSV(0));
989
990             gv_efullname3(sv, cvgv, NULL);
991
992             fq_subname = SvPVX(sv);
993             fq_subname_len = SvCUR(sv);
994
995             subname = strrchr(fq_subname, ':');
996             if(!subname)
997                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
998
999             subname++;
1000             subname_len = fq_subname_len - (subname - fq_subname);
1001             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1002                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1003                 continue;
1004             }
1005             break;
1006         }
1007         cxix--;
1008     }
1009
1010     /* If we made it to here, we found our context */
1011
1012     /* Initialize the next::method cache for this stash
1013        if necessary */
1014     selfmeta = HvMROMETA(selfstash);
1015     if(!(nmcache = selfmeta->mro_nextmethod)) {
1016         nmcache = selfmeta->mro_nextmethod = newHV();
1017     }
1018     else { /* Use the cached coderef if it exists */
1019         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1020         if (cache_entry) {
1021             SV* const val = HeVAL(cache_entry);
1022             if(val == &PL_sv_undef) {
1023                 if(throw_nomethod)
1024                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1025                 XSRETURN_EMPTY;
1026             }
1027             XPUSHs(sv_2mortal(newRV_inc(val)));
1028             XSRETURN(1);
1029         }
1030     }
1031
1032     /* beyond here is just for cache misses, so perf isn't as critical */
1033
1034     stashname_len = subname - fq_subname - 2;
1035     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
1036
1037     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1038
1039     linear_svp = AvARRAY(linear_av);
1040     entries = AvFILLp(linear_av) + 1;
1041
1042     /* Walk down our MRO, skipping everything up
1043        to the contextually enclosing class */
1044     while (entries--) {
1045         SV * const linear_sv = *linear_svp++;
1046         assert(linear_sv);
1047         if(sv_eq(linear_sv, stashname))
1048             break;
1049     }
1050
1051     /* Now search the remainder of the MRO for the
1052        same method name as the contextually enclosing
1053        method */
1054     if(entries > 0) {
1055         while (entries--) {
1056             SV * const linear_sv = *linear_svp++;
1057             HV* curstash;
1058             GV* candidate;
1059             CV* cand_cv;
1060
1061             assert(linear_sv);
1062             curstash = gv_stashsv(linear_sv, FALSE);
1063
1064             if (!curstash) {
1065                 if (ckWARN(WARN_SYNTAX))
1066                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1067                         (void*)linear_sv, hvname);
1068                 continue;
1069             }
1070
1071             assert(curstash);
1072
1073             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1074             if (!gvp) continue;
1075
1076             candidate = *gvp;
1077             assert(candidate);
1078
1079             if (SvTYPE(candidate) != SVt_PVGV)
1080                 gv_init(candidate, curstash, subname, subname_len, TRUE);
1081
1082             /* Notably, we only look for real entries, not method cache
1083                entries, because in C3 the method cache of a parent is not
1084                valid for the child */
1085             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1086                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1087                 hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1088                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1089                 XSRETURN(1);
1090             }
1091         }
1092     }
1093
1094     hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1095     if(throw_nomethod)
1096         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1097     XSRETURN_EMPTY;
1098 }
1099
1100 /*
1101  * Local variables:
1102  * c-indentation-style: bsd
1103  * c-basic-offset: 4
1104  * indent-tabs-mode: t
1105  * End:
1106  *
1107  * ex: set ts=8 sts=4 sw=4 noet:
1108  */