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