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