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