This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Change 31977 introduced a bug (failing to set the return value of
[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 = (void *) 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_nolen(classname);
844     classname_len = strlen(classname_pv);
845
846     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
847     isarev = he ? (HV*)HeVAL(he) : NULL;
848
849     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
850         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
851         XSRETURN_YES;
852     else
853         XSRETURN_NO;
854 }
855
856 XS(XS_mro_invalidate_method_caches)
857 {
858     dVAR;
859     dXSARGS;
860
861     PERL_UNUSED_ARG(cv);
862
863     if (items != 0)
864         Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()");
865
866     PL_sub_generation++;
867
868     XSRETURN_EMPTY;
869 }
870
871 XS(XS_mro_method_changed_in)
872 {
873     dVAR;
874     dXSARGS;
875     SV* classname;
876     HV* class_stash;
877
878     PERL_UNUSED_ARG(cv);
879
880     if(items != 1)
881         Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)");
882     
883     classname = ST(0);
884
885     class_stash = gv_stashsv(classname, 0);
886     if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
887
888     mro_method_changed_in(class_stash);
889
890     XSRETURN_EMPTY;
891 }
892
893 XS(XS_mro_get_pkg_gen)
894 {
895     dVAR;
896     dXSARGS;
897     SV* classname;
898     HV* class_stash;
899
900     PERL_UNUSED_ARG(cv);
901
902     if(items != 1)
903         Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
904     
905     classname = ST(0);
906
907     class_stash = gv_stashsv(classname, 0);
908
909     SP -= items;
910
911     XPUSHs(sv_2mortal(newSViv(
912         class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
913     )));
914     
915     PUTBACK;
916     return;
917 }
918
919 XS(XS_mro_nextcan)
920 {
921     dVAR;
922     dXSARGS;
923     SV* self = ST(0);
924     const I32 throw_nomethod = SvIVX(ST(1));
925     register I32 cxix = cxstack_ix;
926     register const PERL_CONTEXT *ccstack = cxstack;
927     const PERL_SI *top_si = PL_curstackinfo;
928     HV* selfstash;
929     SV *stashname;
930     const char *fq_subname;
931     const char *subname;
932     STRLEN stashname_len;
933     STRLEN subname_len;
934     SV* sv;
935     GV** gvp;
936     AV* linear_av;
937     SV** linear_svp;
938     const char *hvname;
939     I32 entries;
940     struct mro_meta* selfmeta;
941     HV* nmcache;
942     I32 i;
943
944     PERL_UNUSED_ARG(cv);
945
946     SP -= items;
947
948     if(sv_isobject(self))
949         selfstash = SvSTASH(SvRV(self));
950     else
951         selfstash = gv_stashsv(self, 0);
952
953     assert(selfstash);
954
955     hvname = HvNAME_get(selfstash);
956     if (!hvname)
957         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
958
959     /* This block finds the contextually-enclosing fully-qualified subname,
960        much like looking at (caller($i))[3] until you find a real sub that
961        isn't ANON, etc (also skips over pureperl next::method, etc) */
962     for(i = 0; i < 2; i++) {
963         cxix = __dopoptosub_at(ccstack, cxix);
964         for (;;) {
965             GV* cvgv;
966             STRLEN fq_subname_len;
967
968             /* we may be in a higher stacklevel, so dig down deeper */
969             while (cxix < 0) {
970                 if(top_si->si_type == PERLSI_MAIN)
971                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
972                 top_si = top_si->si_prev;
973                 ccstack = top_si->si_cxstack;
974                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
975             }
976
977             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
978               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
979                 cxix = __dopoptosub_at(ccstack, cxix - 1);
980                 continue;
981             }
982
983             {
984                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
985                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
986                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
987                         cxix = dbcxix;
988                         continue;
989                     }
990                 }
991             }
992
993             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
994
995             if(!isGV(cvgv)) {
996                 cxix = __dopoptosub_at(ccstack, cxix - 1);
997                 continue;
998             }
999
1000             /* we found a real sub here */
1001             sv = sv_2mortal(newSV(0));
1002
1003             gv_efullname3(sv, cvgv, NULL);
1004
1005             fq_subname = SvPVX(sv);
1006             fq_subname_len = SvCUR(sv);
1007
1008             subname = strrchr(fq_subname, ':');
1009             if(!subname)
1010                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
1011
1012             subname++;
1013             subname_len = fq_subname_len - (subname - fq_subname);
1014             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
1015                 cxix = __dopoptosub_at(ccstack, cxix - 1);
1016                 continue;
1017             }
1018             break;
1019         }
1020         cxix--;
1021     }
1022
1023     /* If we made it to here, we found our context */
1024
1025     /* Initialize the next::method cache for this stash
1026        if necessary */
1027     selfmeta = HvMROMETA(selfstash);
1028     if(!(nmcache = selfmeta->mro_nextmethod)) {
1029         nmcache = selfmeta->mro_nextmethod = newHV();
1030     }
1031     else { /* Use the cached coderef if it exists */
1032         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
1033         if (cache_entry) {
1034             SV* const val = HeVAL(cache_entry);
1035             if(val == &PL_sv_undef) {
1036                 if(throw_nomethod)
1037                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1038                 XSRETURN_EMPTY;
1039             }
1040             XPUSHs(sv_2mortal(newRV_inc(val)));
1041             XSRETURN(1);
1042         }
1043     }
1044
1045     /* beyond here is just for cache misses, so perf isn't as critical */
1046
1047     stashname_len = subname - fq_subname - 2;
1048     stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
1049
1050     linear_av = mro_get_linear_isa_c3(selfstash, 0); /* has ourselves at the top of the list */
1051
1052     linear_svp = AvARRAY(linear_av);
1053     entries = AvFILLp(linear_av) + 1;
1054
1055     /* Walk down our MRO, skipping everything up
1056        to the contextually enclosing class */
1057     while (entries--) {
1058         SV * const linear_sv = *linear_svp++;
1059         assert(linear_sv);
1060         if(sv_eq(linear_sv, stashname))
1061             break;
1062     }
1063
1064     /* Now search the remainder of the MRO for the
1065        same method name as the contextually enclosing
1066        method */
1067     if(entries > 0) {
1068         while (entries--) {
1069             SV * const linear_sv = *linear_svp++;
1070             HV* curstash;
1071             GV* candidate;
1072             CV* cand_cv;
1073
1074             assert(linear_sv);
1075             curstash = gv_stashsv(linear_sv, FALSE);
1076
1077             if (!curstash) {
1078                 if (ckWARN(WARN_SYNTAX))
1079                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
1080                         (void*)linear_sv, hvname);
1081                 continue;
1082             }
1083
1084             assert(curstash);
1085
1086             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
1087             if (!gvp) continue;
1088
1089             candidate = *gvp;
1090             assert(candidate);
1091
1092             if (SvTYPE(candidate) != SVt_PVGV)
1093                 gv_init(candidate, curstash, subname, subname_len, TRUE);
1094
1095             /* Notably, we only look for real entries, not method cache
1096                entries, because in C3 the method cache of a parent is not
1097                valid for the child */
1098             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
1099                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
1100                 (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
1101                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
1102                 XSRETURN(1);
1103             }
1104         }
1105     }
1106
1107     (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
1108     if(throw_nomethod)
1109         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
1110     XSRETURN_EMPTY;
1111 }
1112
1113 /*
1114  * Local variables:
1115  * c-indentation-style: bsd
1116  * c-basic-offset: 4
1117  * indent-tabs-mode: t
1118  * End:
1119  *
1120  * ex: set ts=8 sts=4 sw=4 noet:
1121  */