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