This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Remove some strlen()s and replace one strlcpy() with memcpy() because
[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     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 char* stashname;
121     struct mro_meta* meta;
122
123     assert(stash);
124     assert(HvAUX(stash));
125
126     stashname = HvNAME_get(stash);
127     if (!stashname)
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               stashname);
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, newSVpv(stashname, 0)); /* 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 char* stashname;
235     STRLEN stashname_len;
236     struct mro_meta* meta;
237
238     assert(stash);
239     assert(HvAUX(stash));
240
241     stashname = HvNAME_get(stash);
242     stashname_len = HvNAMELEN_get(stash);
243     if (!stashname)
244       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
245
246     if (level > 100)
247         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
248               stashname);
249
250     meta = HvMROMETA(stash);
251
252     /* return cache if valid */
253     if((retval = meta->mro_linear_c3)) {
254         return retval;
255     }
256
257     /* not in cache, make a new one */
258
259     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
260     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
261
262     /* For a better idea how the rest of this works, see the much clearer
263        pure perl version in Algorithm::C3 0.01:
264        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
265        (later versions go about it differently than this code for speed reasons)
266     */
267
268     if(isa && AvFILLp(isa) >= 0) {
269         SV** seqs_ptr;
270         I32 seqs_items;
271         HV* const tails = (HV*)sv_2mortal((SV*)newHV());
272         AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
273         I32* heads;
274
275         /* This builds @seqs, which is an array of arrays.
276            The members of @seqs are the MROs of
277            the members of @ISA, followed by @ISA itself.
278         */
279         I32 items = AvFILLp(isa) + 1;
280         SV** isa_ptr = AvARRAY(isa);
281         while(items--) {
282             SV* const isa_item = *isa_ptr++;
283             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
284             if(!isa_item_stash) {
285                 /* if no stash, make a temporary fake MRO
286                    containing just itself */
287                 AV* const isa_lin = newAV();
288                 av_push(isa_lin, newSVsv(isa_item));
289                 av_push(seqs, (SV*)isa_lin);
290             }
291             else {
292                 /* recursion */
293                 AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
294                 av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
295             }
296         }
297         av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
298
299         /* This builds "heads", which as an array of integer array
300            indices, one per seq, which point at the virtual "head"
301            of the seq (initially zero) */
302         Newxz(heads, AvFILLp(seqs)+1, I32);
303
304         /* This builds %tails, which has one key for every class
305            mentioned in the tail of any sequence in @seqs (tail meaning
306            everything after the first class, the "head").  The value
307            is how many times this key appears in the tails of @seqs.
308         */
309         seqs_ptr = AvARRAY(seqs);
310         seqs_items = AvFILLp(seqs) + 1;
311         while(seqs_items--) {
312             AV* const seq = (AV*)*seqs_ptr++;
313             I32 seq_items = AvFILLp(seq);
314             if(seq_items > 0) {
315                 SV** seq_ptr = AvARRAY(seq) + 1;
316                 while(seq_items--) {
317                     SV* const seqitem = *seq_ptr++;
318                     HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
319                     if(!he) {
320                         (void)hv_store_ent(tails, seqitem, newSViv(1), 0);
321                     }
322                     else {
323                         SV* const val = HeVAL(he);
324                         sv_inc(val);
325                     }
326                 }
327             }
328         }
329
330         /* Initialize retval to build the return value in */
331         retval = newAV();
332         av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
333
334         /* This loop won't terminate until we either finish building
335            the MRO, or get an exception. */
336         while(1) {
337             SV* cand = NULL;
338             SV* winner = NULL;
339             int s;
340
341             /* "foreach $seq (@seqs)" */
342             SV** const avptr = AvARRAY(seqs);
343             for(s = 0; s <= AvFILLp(seqs); s++) {
344                 SV** svp;
345                 AV * const seq = (AV*)(avptr[s]);
346                 SV* seqhead;
347                 if(!seq) continue; /* skip empty seqs */
348                 svp = av_fetch(seq, heads[s], 0);
349                 seqhead = *svp; /* seqhead = head of this seq */
350                 if(!winner) {
351                     HE* tail_entry;
352                     SV* val;
353                     /* if we haven't found a winner for this round yet,
354                        and this seqhead is not in tails (or the count
355                        for it in tails has dropped to zero), then this
356                        seqhead is our new winner, and is added to the
357                        final MRO immediately */
358                     cand = seqhead;
359                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
360                        && (val = HeVAL(tail_entry))
361                        && (SvIVX(val) > 0))
362                            continue;
363                     winner = newSVsv(cand);
364                     av_push(retval, winner);
365                     /* note however that even when we find a winner,
366                        we continue looping over @seqs to do housekeeping */
367                 }
368                 if(!sv_cmp(seqhead, winner)) {
369                     /* Once we have a winner (including the iteration
370                        where we first found him), inc the head ptr
371                        for any seq which had the winner as a head,
372                        NULL out any seq which is now empty,
373                        and adjust tails for consistency */
374
375                     const int new_head = ++heads[s];
376                     if(new_head > AvFILLp(seq)) {
377                         SvREFCNT_dec(avptr[s]);
378                         avptr[s] = NULL;
379                     }
380                     else {
381                         HE* tail_entry;
382                         SV* val;
383                         /* Because we know this new seqhead used to be
384                            a tail, we can assume it is in tails and has
385                            a positive value, which we need to dec */
386                         svp = av_fetch(seq, new_head, 0);
387                         seqhead = *svp;
388                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
389                         val = HeVAL(tail_entry);
390                         sv_dec(val);
391                     }
392                 }
393             }
394
395             /* if we found no candidates, we are done building the MRO.
396                !cand means no seqs have any entries left to check */
397             if(!cand) {
398                 Safefree(heads);
399                 break;
400             }
401
402             /* If we had candidates, but nobody won, then the @ISA
403                hierarchy is not C3-incompatible */
404             if(!winner) {
405                 /* we have to do some cleanup before we croak */
406
407                 SvREFCNT_dec(retval);
408                 Safefree(heads);
409
410                 Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
411                     "merging failed on parent '%"SVf"'", stashname, SVfARG(cand));
412             }
413         }
414     }
415     else { /* @ISA was undefined or empty */
416         /* build a retval containing only ourselves */
417         retval = newAV();
418         av_push(retval, newSVpvn(stashname, stashname_len));
419     }
420
421     /* we don't want anyone modifying the cache entry but us,
422        and we do so by replacing it completely */
423     SvREADONLY_on(retval);
424
425     meta->mro_linear_c3 = retval;
426     return retval;
427 }
428
429 /*
430 =for apidoc mro_get_linear_isa
431
432 Returns either C<mro_get_linear_isa_c3> or
433 C<mro_get_linear_isa_dfs> for the given stash,
434 dependant upon which MRO is in effect
435 for that stash.  The return value is a
436 read-only AV*.
437
438 You are responsible for C<SvREFCNT_inc()> on the
439 return value if you plan to store it anywhere
440 semi-permanently (otherwise it might be deleted
441 out from under you the next time the cache is
442 invalidated).
443
444 =cut
445 */
446 AV*
447 Perl_mro_get_linear_isa(pTHX_ HV *stash)
448 {
449     struct mro_meta* meta;
450
451     assert(stash);
452     if(!SvOOK(stash))
453         Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
454
455     meta = HvMROMETA(stash);
456     if (!meta->mro_which)
457         Perl_croak(aTHX_ "panic: invalid MRO!");
458     return meta->mro_which->resolve(aTHX_ stash, 0);
459 }
460
461 /*
462 =for apidoc mro_isa_changed_in
463
464 Takes the necessary steps (cache invalidations, mostly)
465 when the @ISA of the given package has changed.  Invoked
466 by the C<setisa> magic, should not need to invoke directly.
467
468 =cut
469 */
470 void
471 Perl_mro_isa_changed_in(pTHX_ HV* stash)
472 {
473     dVAR;
474     HV* isarev;
475     AV* linear_mro;
476     HE* iter;
477     SV** svp;
478     I32 items;
479     bool is_universal;
480     struct mro_meta * meta;
481
482     const char * const stashname = HvNAME_get(stash);
483     const STRLEN stashname_len = HvNAMELEN_get(stash);
484
485     if(!stashname)
486         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
487
488     /* wipe out the cached linearizations for this stash */
489     meta = HvMROMETA(stash);
490     SvREFCNT_dec((SV*)meta->mro_linear_dfs);
491     SvREFCNT_dec((SV*)meta->mro_linear_c3);
492     meta->mro_linear_dfs = NULL;
493     meta->mro_linear_c3 = NULL;
494
495     /* Inc the package generation, since our @ISA changed */
496     meta->pkg_gen++;
497
498     /* Wipe the global method cache if this package
499        is UNIVERSAL or one of its parents */
500
501     svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
502     isarev = svp ? (HV*)*svp : NULL;
503
504     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
505         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
506         PL_sub_generation++;
507         is_universal = TRUE;
508     }
509     else { /* Wipe the local method cache otherwise */
510         meta->cache_gen++;
511         is_universal = FALSE;
512     }
513
514     /* wipe next::method cache too */
515     if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
516
517     /* Iterate the isarev (classes that are our children),
518        wiping out their linearization and method caches */
519     if(isarev) {
520         hv_iterinit(isarev);
521         while((iter = hv_iternext(isarev))) {
522             SV* const revkey = hv_iterkeysv(iter);
523             HV* revstash = gv_stashsv(revkey, 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, 0, 0);
555         if(!he) {
556             he = hv_store_ent(PL_isarev, sv, (SV*)newHV(), 0);
557         }
558         mroisarev = (HV*)HeVAL(he);
559
560         /* This hash only ever contains PL_sv_yes. Storing it over itself is
561            almost as cheap as calling hv_exists, so on aggregate we expect to
562            save time by not making two calls to the common HV code for the
563            case where it doesn't exist.  */
564            
565         (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
566
567         if(isarev) {
568             hv_iterinit(isarev);
569             while((iter = hv_iternext(isarev))) {
570                 I32 revkeylen;
571                 char* const revkey = hv_iterkey(iter, &revkeylen);
572                 (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
573             }
574         }
575     }
576 }
577
578 /*
579 =for apidoc mro_method_changed_in
580
581 Invalidates method caching on any child classes
582 of the given stash, so that they might notice
583 the changes in this one.
584
585 Ideally, all instances of C<PL_sub_generation++> in
586 perl source outside of C<mro.c> should be
587 replaced by calls to this.
588
589 Perl automatically handles most of the common
590 ways a method might be redefined.  However, there
591 are a few ways you could change a method in a stash
592 without the cache code noticing, in which case you
593 need to call this method afterwards:
594
595 1) Directly manipulating the stash HV entries from
596 XS code.
597
598 2) Assigning a reference to a readonly scalar
599 constant into a stash entry in order to create
600 a constant subroutine (like constant.pm
601 does).
602
603 This same method is available from pure perl
604 via, C<mro::method_changed_in(classname)>.
605
606 =cut
607 */
608 void
609 Perl_mro_method_changed_in(pTHX_ HV *stash)
610 {
611     const char * const stashname = HvNAME_get(stash);
612     const STRLEN stashname_len = HvNAMELEN_get(stash);
613
614     SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
615     HV * const isarev = svp ? (HV*)*svp : NULL;
616
617     if(!stashname)
618         Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
619
620     /* Inc the package generation, since a local method changed */
621     HvMROMETA(stash)->pkg_gen++;
622
623     /* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
624        invalidate all method caches globally */
625     if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
626         || (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
627         PL_sub_generation++;
628         return;
629     }
630
631     /* else, invalidate the method caches of all child classes,
632        but not itself */
633     if(isarev) {
634         HE* iter;
635
636         hv_iterinit(isarev);
637         while((iter = hv_iternext(isarev))) {
638             SV* const revkey = hv_iterkeysv(iter);
639             HV* const revstash = gv_stashsv(revkey, 0);
640             struct mro_meta* mrometa;
641
642             if(!revstash) continue;
643             mrometa = HvMROMETA(revstash);
644             mrometa->cache_gen++;
645             if(mrometa->mro_nextmethod)
646                 hv_clear(mrometa->mro_nextmethod);
647         }
648     }
649 }
650
651 /* These two are static helpers for next::method and friends,
652    and re-implement a bunch of the code from pp_caller() in
653    a more efficient manner for this particular usage.
654 */
655
656 STATIC I32
657 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
658     I32 i;
659     for (i = startingblock; i >= 0; i--) {
660         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
661     }
662     return i;
663 }
664
665 #include "XSUB.h"
666
667 XS(XS_mro_get_linear_isa);
668 XS(XS_mro_set_mro);
669 XS(XS_mro_get_mro);
670 XS(XS_mro_get_isarev);
671 XS(XS_mro_is_universal);
672 XS(XS_mro_invalidate_method_caches);
673 XS(XS_mro_method_changed_in);
674 XS(XS_mro_get_pkg_gen);
675 XS(XS_mro_nextcan);
676
677 void
678 Perl_boot_core_mro(pTHX)
679 {
680     dVAR;
681     static const char file[] = __FILE__;
682
683     newXSproto("mro::get_linear_isa", XS_mro_get_linear_isa, file, "$;$");
684     newXSproto("mro::set_mro", XS_mro_set_mro, file, "$$");
685     newXSproto("mro::get_mro", XS_mro_get_mro, file, "$");
686     newXSproto("mro::get_isarev", XS_mro_get_isarev, file, "$");
687     newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
688     newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
689     newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
690     newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
691     newXS("mro::_nextcan", XS_mro_nextcan, file);
692 }
693
694 XS(XS_mro_get_linear_isa) {
695     dVAR;
696     dXSARGS;
697     AV* RETVAL;
698     HV* class_stash;
699     SV* classname;
700
701     PERL_UNUSED_ARG(cv);
702
703     if(items < 1 || items > 2)
704        Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])");
705
706     classname = ST(0);
707     class_stash = gv_stashsv(classname, 0);
708
709     if(!class_stash) {
710         /* No stash exists yet, give them just the classname */
711         AV* isalin = newAV();
712         av_push(isalin, newSVsv(classname));
713         ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
714         XSRETURN(1);
715     }
716     else if(items > 1) {
717         const char* const which = SvPV_nolen(ST(1));
718         const struct mro_alg *const algo = S_get_mro_from_name(aTHX_ which);
719         if (!algo)
720             Perl_croak(aTHX_ "Invalid mro name: '%s'", which);
721         RETVAL = algo->resolve(aTHX_ class_stash, 0);
722     }
723     else {
724         RETVAL = mro_get_linear_isa(class_stash);
725     }
726
727     ST(0) = newRV_inc((SV*)RETVAL);
728     sv_2mortal(ST(0));
729     XSRETURN(1);
730 }
731
732 XS(XS_mro_set_mro)
733 {
734     dVAR;
735     dXSARGS;
736     SV* classname;
737     const char* whichstr;
738     const struct mro_alg *which;
739     HV* class_stash;
740     struct mro_meta* meta;
741
742     PERL_UNUSED_ARG(cv);
743
744     if (items != 2)
745        Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)");
746
747     classname = ST(0);
748     whichstr = SvPV_nolen(ST(1));
749     class_stash = gv_stashsv(classname, GV_ADD);
750     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
751     meta = HvMROMETA(class_stash);
752
753     which = S_get_mro_from_name(aTHX_ whichstr);
754     if (!which)
755         Perl_croak(aTHX_ "Invalid mro name: '%s'", whichstr);
756
757     if(meta->mro_which != which) {
758         meta->mro_which = which;
759         /* Only affects local method cache, not
760            even child classes */
761         meta->cache_gen++;
762         if(meta->mro_nextmethod)
763             hv_clear(meta->mro_nextmethod);
764     }
765
766     XSRETURN_EMPTY;
767 }
768
769
770 XS(XS_mro_get_mro)
771 {
772     dVAR;
773     dXSARGS;
774     SV* classname;
775     HV* class_stash;
776
777     PERL_UNUSED_ARG(cv);
778
779     if (items != 1)
780        Perl_croak(aTHX_ "Usage: mro::get_mro(classname)");
781
782     classname = ST(0);
783     class_stash = gv_stashsv(classname, 0);
784
785     ST(0) = sv_2mortal(newSVpv(class_stash
786                                ? HvMROMETA(class_stash)->mro_which->name
787                                : "dfs", 0));
788     XSRETURN(1);
789 }
790
791 XS(XS_mro_get_isarev)
792 {
793     dVAR;
794     dXSARGS;
795     SV* classname;
796     HE* he;
797     HV* isarev;
798     AV* ret_array;
799
800     PERL_UNUSED_ARG(cv);
801
802     if (items != 1)
803        Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)");
804
805     classname = ST(0);
806
807     SP -= items;
808
809     
810     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
811     isarev = he ? (HV*)HeVAL(he) : NULL;
812
813     ret_array = newAV();
814     if(isarev) {
815         HE* iter;
816         hv_iterinit(isarev);
817         while((iter = hv_iternext(isarev)))
818             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
819     }
820     XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
821
822     PUTBACK;
823     return;
824 }
825
826 XS(XS_mro_is_universal)
827 {
828     dVAR;
829     dXSARGS;
830     SV* classname;
831     HV* isarev;
832     char* classname_pv;
833     STRLEN classname_len;
834     HE* he;
835
836     PERL_UNUSED_ARG(cv);
837
838     if (items != 1)
839        Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
840
841     classname = ST(0);
842
843     classname_pv = SvPV(classname,classname_len);
844
845     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
846     isarev = he ? (HV*)HeVAL(he) : NULL;
847
848     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
849         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
850         XSRETURN_YES;
851     else
852         XSRETURN_NO;
853 }
854
855 XS(XS_mro_invalidate_method_caches)
856 {
857     dVAR;
858     dXSARGS;
859
860     PERL_UNUSED_ARG(cv);
861
862     if (items != 0)
863         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
864
865     PL_sub_generation++;
866
867     XSRETURN_EMPTY;
868 }
869
870 XS(XS_mro_method_changed_in)
871 {
872     dVAR;
873     dXSARGS;
874     SV* classname;
875     HV* class_stash;
876
877     PERL_UNUSED_ARG(cv);
878
879     if(items != 1)
880         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
881     
882     classname = ST(0);
883
884     class_stash = gv_stashsv(classname, 0);
885     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
886
887     mro_method_changed_in(class_stash);
888
889     XSRETURN_EMPTY;
890 }
891
892 XS(XS_mro_get_pkg_gen)
893 {
894     dVAR;
895     dXSARGS;
896     SV* classname;
897     HV* class_stash;
898
899     PERL_UNUSED_ARG(cv);
900
901     if(items != 1)
902         Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
903     
904     classname = ST(0);
905
906     class_stash = gv_stashsv(classname, 0);
907
908     SP -= items;
909
910     XPUSHs(sv_2mortal(newSViv(
911         class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
912     )));
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, 0);
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             XPUSHs(sv_2mortal(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 = sv_2mortal(newSVpvn(fq_subname, stashname_len));
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                 XPUSHs(sv_2mortal(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  */