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