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