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