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