This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
76a91ae07ce97a2e13e86158a7c4a58ade1eca25
[perl5.git] / ext / mro / mro.xs
1 #include "EXTERN.h"
2 #include "perl.h"
3 #include "XSUB.h"
4
5 static AV*
6 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level);
7
8 static const struct mro_alg c3_alg =
9     {S_mro_get_linear_isa_c3, "c3", 2, 0, 0};
10
11 /*
12 =for apidoc mro_get_linear_isa_c3
13
14 Returns the C3 linearization of @ISA
15 the given stash.  The return value is a read-only AV*.
16 C<level> should be 0 (it is used internally in this
17 function's recursion).
18
19 You are responsible for C<SvREFCNT_inc()> on the
20 return value if you plan to store it anywhere
21 semi-permanently (otherwise it might be deleted
22 out from under you the next time the cache is
23 invalidated).
24
25 =cut
26 */
27
28 static AV*
29 S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
30 {
31     AV* retval;
32     GV** gvp;
33     GV* gv;
34     AV* isa;
35     const HEK* stashhek;
36     struct mro_meta* meta;
37
38     assert(HvAUX(stash));
39
40     stashhek = HvENAME_HEK(stash);
41     if (!stashhek) stashhek = HvNAME_HEK(stash);
42     if (!stashhek)
43       Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
44
45     if (level > 100)
46         Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
47                    HEK_KEY(stashhek));
48
49     meta = HvMROMETA(stash);
50
51     /* return cache if valid */
52     if((retval = MUTABLE_AV(MRO_GET_PRIVATE_DATA(meta, &c3_alg)))) {
53         return retval;
54     }
55
56     /* not in cache, make a new one */
57
58     gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
59     isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
60
61     /* For a better idea how the rest of this works, see the much clearer
62        pure perl version in Algorithm::C3 0.01:
63        http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
64        (later versions go about it differently than this code for speed reasons)
65     */
66
67     if(isa && AvFILLp(isa) >= 0) {
68         SV** seqs_ptr;
69         I32 seqs_items;
70         HV *tails;
71         AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
72         I32* heads;
73
74         /* This builds @seqs, which is an array of arrays.
75            The members of @seqs are the MROs of
76            the members of @ISA, followed by @ISA itself.
77         */
78         I32 items = AvFILLp(isa) + 1;
79         SV** isa_ptr = AvARRAY(isa);
80         while(items--) {
81             SV* const isa_item = *isa_ptr++;
82             HV* const isa_item_stash = gv_stashsv(isa_item, 0);
83             if(!isa_item_stash) {
84                 /* if no stash, make a temporary fake MRO
85                    containing just itself */
86                 AV* const isa_lin = newAV();
87                 av_push(isa_lin, newSVsv(isa_item));
88                 av_push(seqs, MUTABLE_SV(isa_lin));
89             }
90             else {
91                 /* recursion */
92                 AV* const isa_lin
93                   = S_mro_get_linear_isa_c3(aTHX_ isa_item_stash, level + 1);
94
95                 if(items == 0 && AvFILLp(seqs) == -1) {
96                     /* Only one parent class. For this case, the C3
97                        linearisation is this class followed by the parent's
98                        linearisation, so don't bother with the expensive
99                        calculation.  */
100                     SV **svp;
101                     I32 subrv_items = AvFILLp(isa_lin) + 1;
102                     SV *const *subrv_p = AvARRAY(isa_lin);
103
104                     /* Hijack the allocated but unused array seqs to be the
105                        return value. It's currently mortalised.  */
106
107                     retval = seqs;
108
109                     av_extend(retval, subrv_items);
110                     AvFILLp(retval) = subrv_items;
111                     svp = AvARRAY(retval);
112
113                     /* First entry is this class.  We happen to make a shared
114                        hash key scalar because it's the cheapest and fastest
115                        way to do it.  */
116                     *svp++ = newSVhek(stashhek);
117
118                     while(subrv_items--) {
119                         /* These values are unlikely to be shared hash key
120                            scalars, so no point in adding code to optimising
121                            for a case that is unlikely to be true.
122                            (Or prove me wrong and do it.)  */
123
124                         SV *const val = *subrv_p++;
125                         *svp++ = newSVsv(val);
126                     }
127
128                     SvREFCNT_inc(retval);
129
130                     goto done;
131                 }
132                 av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa_lin)));
133             }
134         }
135         av_push(seqs, SvREFCNT_inc_simple_NN(MUTABLE_SV(isa)));
136         tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
137
138         /* This builds "heads", which as an array of integer array
139            indices, one per seq, which point at the virtual "head"
140            of the seq (initially zero) */
141         Newxz(heads, AvFILLp(seqs)+1, I32);
142
143         /* This builds %tails, which has one key for every class
144            mentioned in the tail of any sequence in @seqs (tail meaning
145            everything after the first class, the "head").  The value
146            is how many times this key appears in the tails of @seqs.
147         */
148         seqs_ptr = AvARRAY(seqs);
149         seqs_items = AvFILLp(seqs) + 1;
150         while(seqs_items--) {
151             AV *const seq = MUTABLE_AV(*seqs_ptr++);
152             I32 seq_items = AvFILLp(seq);
153             if(seq_items > 0) {
154                 SV** seq_ptr = AvARRAY(seq) + 1;
155                 while(seq_items--) {
156                     SV* const seqitem = *seq_ptr++;
157                     /* LVALUE fetch will create a new undefined SV if necessary
158                      */
159                     HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
160                     if(he) {
161                         SV* const val = HeVAL(he);
162                         /* For 5.8.0 and later, sv_inc() with increment undef to
163                            an IV of 1, which is what we want for a newly created
164                            entry.  However, for 5.6.x it will become an NV of
165                            1.0, which confuses the SvIVX() checks above.  */
166                         if(SvIOK(val)) {
167                             SvIV_set(val, SvIVX(val) + 1);
168                         } else {
169                             sv_setiv(val, 1);
170                         }
171                     }
172                 }
173             }
174         }
175
176         /* Initialize retval to build the return value in */
177         retval = newAV();
178         av_push(retval, newSVhek(stashhek)); /* us first */
179
180         /* This loop won't terminate until we either finish building
181            the MRO, or get an exception. */
182         while(1) {
183             SV* cand = NULL;
184             SV* winner = NULL;
185             int s;
186
187             /* "foreach $seq (@seqs)" */
188             SV** const avptr = AvARRAY(seqs);
189             for(s = 0; s <= AvFILLp(seqs); s++) {
190                 SV** svp;
191                 AV * const seq = MUTABLE_AV(avptr[s]);
192                 SV* seqhead;
193                 if(!seq) continue; /* skip empty seqs */
194                 svp = av_fetch(seq, heads[s], 0);
195                 seqhead = *svp; /* seqhead = head of this seq */
196                 if(!winner) {
197                     HE* tail_entry;
198                     SV* val;
199                     /* if we haven't found a winner for this round yet,
200                        and this seqhead is not in tails (or the count
201                        for it in tails has dropped to zero), then this
202                        seqhead is our new winner, and is added to the
203                        final MRO immediately */
204                     cand = seqhead;
205                     if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
206                        && (val = HeVAL(tail_entry))
207                        && (SvIVX(val) > 0))
208                            continue;
209                     winner = newSVsv(cand);
210                     av_push(retval, winner);
211                     /* note however that even when we find a winner,
212                        we continue looping over @seqs to do housekeeping */
213                 }
214                 if(!sv_cmp(seqhead, winner)) {
215                     /* Once we have a winner (including the iteration
216                        where we first found him), inc the head ptr
217                        for any seq which had the winner as a head,
218                        NULL out any seq which is now empty,
219                        and adjust tails for consistency */
220
221                     const int new_head = ++heads[s];
222                     if(new_head > AvFILLp(seq)) {
223                         SvREFCNT_dec(avptr[s]);
224                         avptr[s] = NULL;
225                     }
226                     else {
227                         HE* tail_entry;
228                         SV* val;
229                         /* Because we know this new seqhead used to be
230                            a tail, we can assume it is in tails and has
231                            a positive value, which we need to dec */
232                         svp = av_fetch(seq, new_head, 0);
233                         seqhead = *svp;
234                         tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
235                         val = HeVAL(tail_entry);
236                         sv_dec(val);
237                     }
238                 }
239             }
240
241             /* if we found no candidates, we are done building the MRO.
242                !cand means no seqs have any entries left to check */
243             if(!cand) {
244                 Safefree(heads);
245                 break;
246             }
247
248             /* If we had candidates, but nobody won, then the @ISA
249                hierarchy is not C3-incompatible */
250             if(!winner) {
251                 SV *errmsg;
252                 I32 i;
253
254                 errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t"
255                                   "current merge results [\n", HEK_KEY(stashhek));
256                 for (i = 0; i <= av_len(retval); i++) {
257                     SV **elem = av_fetch(retval, i, 0);
258                     sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
259                 }
260                 sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
261
262                 /* we have to do some cleanup before we croak */
263
264                 SvREFCNT_dec(retval);
265                 Safefree(heads);
266
267                 Perl_croak(aTHX_ "%"SVf, SVfARG(errmsg));
268             }
269         }
270     }
271     else { /* @ISA was undefined or empty */
272         /* build a retval containing only ourselves */
273         retval = newAV();
274         av_push(retval, newSVhek(stashhek));
275     }
276
277  done:
278     /* we don't want anyone modifying the cache entry but us,
279        and we do so by replacing it completely */
280     SvREADONLY_on(retval);
281
282     return MUTABLE_AV(Perl_mro_set_private_data(aTHX_ meta, &c3_alg,
283                                                 MUTABLE_SV(retval)));
284 }
285
286
287 /* These two are static helpers for next::method and friends,
288    and re-implement a bunch of the code from pp_caller() in
289    a more efficient manner for this particular usage.
290 */
291
292 static I32
293 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
294     I32 i;
295     for (i = startingblock; i >= 0; i--) {
296         if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
297     }
298     return i;
299 }
300
301 MODULE = mro            PACKAGE = mro           PREFIX = mro_
302
303 void
304 mro_get_linear_isa(...)
305   PROTOTYPE: $;$
306   PREINIT:
307     AV* RETVAL;
308     HV* class_stash;
309     SV* classname;
310   PPCODE:
311     if(items < 1 || items > 2)
312         croak_xs_usage(cv, "classname [, type ]");
313
314     classname = ST(0);
315     class_stash = gv_stashsv(classname, 0);
316
317     if(!class_stash) {
318         /* No stash exists yet, give them just the classname */
319         AV* isalin = newAV();
320         av_push(isalin, newSVsv(classname));
321         ST(0) = sv_2mortal(newRV_noinc(MUTABLE_SV(isalin)));
322         XSRETURN(1);
323     }
324     else if(items > 1) {
325         const struct mro_alg *const algo = Perl_mro_get_from_name(aTHX_ ST(1));
326         if (!algo)
327             Perl_croak(aTHX_ "Invalid mro name: '%"SVf"'", ST(1));
328         RETVAL = algo->resolve(aTHX_ class_stash, 0);
329     }
330     else {
331         RETVAL = mro_get_linear_isa(class_stash);
332     }
333     ST(0) = newRV_inc(MUTABLE_SV(RETVAL));
334     sv_2mortal(ST(0));
335     XSRETURN(1);
336
337 void
338 mro_set_mro(...)
339   PROTOTYPE: $$
340   PREINIT:
341     SV* classname;
342     HV* class_stash;
343     struct mro_meta* meta;
344   PPCODE:
345     if (items != 2)
346         croak_xs_usage(cv, "classname, type");
347
348     classname = ST(0);
349     class_stash = gv_stashsv(classname, GV_ADD);
350     if(!class_stash) Perl_croak(aTHX_ "Cannot create class: '%"SVf"'!", SVfARG(classname));
351     meta = HvMROMETA(class_stash);
352
353     Perl_mro_set_mro(aTHX_ meta, ST(1));
354
355     XSRETURN_EMPTY;
356
357 void
358 mro_get_mro(...)
359   PROTOTYPE: $
360   PREINIT:
361     SV* classname;
362     HV* class_stash;
363   PPCODE:
364     if (items != 1)
365         croak_xs_usage(cv, "classname");
366
367     classname = ST(0);
368     class_stash = gv_stashsv(classname, 0);
369
370     if (class_stash) {
371         const struct mro_alg *const meta = HvMROMETA(class_stash)->mro_which;
372         ST(0) = newSVpvn_flags(meta->name, meta->length,
373                                SVs_TEMP
374                                | ((meta->kflags & HVhek_UTF8) ? SVf_UTF8 : 0));
375     } else {
376       ST(0) = newSVpvn_flags("dfs", 3, SVs_TEMP);
377     }
378     XSRETURN(1);
379
380 void
381 mro_get_isarev(...)
382   PROTOTYPE: $
383   PREINIT:
384     SV* classname;
385     HE* he;
386     HV* isarev;
387     AV* ret_array;
388   PPCODE:
389     if (items != 1)
390         croak_xs_usage(cv, "classname");
391
392     classname = ST(0);
393
394     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
395     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
396
397     ret_array = newAV();
398     if(isarev) {
399         HE* iter;
400         hv_iterinit(isarev);
401         while((iter = hv_iternext(isarev)))
402             av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
403     }
404     mXPUSHs(newRV_noinc(MUTABLE_SV(ret_array)));
405
406     PUTBACK;
407
408 void
409 mro_is_universal(...)
410   PROTOTYPE: $
411   PREINIT:
412     SV* classname;
413     HV* isarev;
414     char* classname_pv;
415     STRLEN classname_len;
416     HE* he;
417   PPCODE:
418     if (items != 1)
419         croak_xs_usage(cv, "classname");
420
421     classname = ST(0);
422
423     classname_pv = SvPV(classname,classname_len);
424
425     he = hv_fetch_ent(PL_isarev, classname, 0, 0);
426     isarev = he ? MUTABLE_HV(HeVAL(he)) : NULL;
427
428     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
429         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
430         XSRETURN_YES;
431     else
432         XSRETURN_NO;
433
434
435 void
436 mro_invalidate_all_method_caches(...)
437   PROTOTYPE: 
438   PPCODE:
439     if (items != 0)
440         croak_xs_usage(cv, "");
441
442     PL_sub_generation++;
443
444     XSRETURN_EMPTY;
445
446 void
447 mro_get_pkg_gen(...)
448   PROTOTYPE: $
449   PREINIT:
450     SV* classname;
451     HV* class_stash;
452   PPCODE:
453     if(items != 1)
454         croak_xs_usage(cv, "classname");
455     
456     classname = ST(0);
457
458     class_stash = gv_stashsv(classname, 0);
459
460     mXPUSHi(class_stash ? HvMROMETA(class_stash)->pkg_gen : 0);
461     
462     PUTBACK;
463
464 void
465 mro__nextcan(...)
466   PREINIT:
467     SV* self = ST(0);
468     const I32 throw_nomethod = SvIVX(ST(1));
469     register I32 cxix = cxstack_ix;
470     register const PERL_CONTEXT *ccstack = cxstack;
471     const PERL_SI *top_si = PL_curstackinfo;
472     HV* selfstash;
473     SV *stashname;
474     const char *fq_subname;
475     const char *subname;
476     STRLEN stashname_len;
477     STRLEN subname_len;
478     SV* sv;
479     GV** gvp;
480     AV* linear_av;
481     SV** linear_svp;
482     const char *hvname;
483     I32 entries;
484     struct mro_meta* selfmeta;
485     HV* nmcache;
486     I32 i;
487   PPCODE:
488     PERL_UNUSED_ARG(cv);
489
490     if(sv_isobject(self))
491         selfstash = SvSTASH(SvRV(self));
492     else
493         selfstash = gv_stashsv(self, GV_ADD);
494
495     assert(selfstash);
496
497     hvname = HvNAME_get(selfstash);
498     if (!hvname)
499         Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
500
501     /* This block finds the contextually-enclosing fully-qualified subname,
502        much like looking at (caller($i))[3] until you find a real sub that
503        isn't ANON, etc (also skips over pureperl next::method, etc) */
504     for(i = 0; i < 2; i++) {
505         cxix = __dopoptosub_at(ccstack, cxix);
506         for (;;) {
507             GV* cvgv;
508             STRLEN fq_subname_len;
509
510             /* we may be in a higher stacklevel, so dig down deeper */
511             while (cxix < 0) {
512                 if(top_si->si_type == PERLSI_MAIN)
513                     Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
514                 top_si = top_si->si_prev;
515                 ccstack = top_si->si_cxstack;
516                 cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
517             }
518
519             if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
520               || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
521                 cxix = __dopoptosub_at(ccstack, cxix - 1);
522                 continue;
523             }
524
525             {
526                 const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
527                 if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
528                     if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
529                         cxix = dbcxix;
530                         continue;
531                     }
532                 }
533             }
534
535             cvgv = CvGV(ccstack[cxix].blk_sub.cv);
536
537             if(!isGV(cvgv)) {
538                 cxix = __dopoptosub_at(ccstack, cxix - 1);
539                 continue;
540             }
541
542             /* we found a real sub here */
543             sv = sv_newmortal();
544
545             gv_efullname3(sv, cvgv, NULL);
546
547             if(SvPOK(sv)) {
548                 fq_subname = SvPVX(sv);
549                 fq_subname_len = SvCUR(sv);
550
551                 subname = strrchr(fq_subname, ':');
552             } else {
553                 subname = NULL;
554             }
555
556             if(!subname)
557                 Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
558
559             subname++;
560             subname_len = fq_subname_len - (subname - fq_subname);
561             if(subname_len == 8 && strEQ(subname, "__ANON__")) {
562                 cxix = __dopoptosub_at(ccstack, cxix - 1);
563                 continue;
564             }
565             break;
566         }
567         cxix--;
568     }
569
570     /* If we made it to here, we found our context */
571
572     /* Initialize the next::method cache for this stash
573        if necessary */
574     selfmeta = HvMROMETA(selfstash);
575     if(!(nmcache = selfmeta->mro_nextmethod)) {
576         nmcache = selfmeta->mro_nextmethod = newHV();
577     }
578     else { /* Use the cached coderef if it exists */
579         HE* cache_entry = hv_fetch_ent(nmcache, sv, 0, 0);
580         if (cache_entry) {
581             SV* const val = HeVAL(cache_entry);
582             if(val == &PL_sv_undef) {
583                 if(throw_nomethod)
584                     Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
585                 XSRETURN_EMPTY;
586             }
587             mXPUSHs(newRV_inc(val));
588             XSRETURN(1);
589         }
590     }
591
592     /* beyond here is just for cache misses, so perf isn't as critical */
593
594     stashname_len = subname - fq_subname - 2;
595     stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
596
597     /* has ourselves at the top of the list */
598     linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
599
600     linear_svp = AvARRAY(linear_av);
601     entries = AvFILLp(linear_av) + 1;
602
603     /* Walk down our MRO, skipping everything up
604        to the contextually enclosing class */
605     while (entries--) {
606         SV * const linear_sv = *linear_svp++;
607         assert(linear_sv);
608         if(sv_eq(linear_sv, stashname))
609             break;
610     }
611
612     /* Now search the remainder of the MRO for the
613        same method name as the contextually enclosing
614        method */
615     if(entries > 0) {
616         while (entries--) {
617             SV * const linear_sv = *linear_svp++;
618             HV* curstash;
619             GV* candidate;
620             CV* cand_cv;
621
622             assert(linear_sv);
623             curstash = gv_stashsv(linear_sv, FALSE);
624
625             if (!curstash) {
626                 if (ckWARN(WARN_SYNTAX))
627                     Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Can't locate package %"SVf" for @%s::ISA",
628                         (void*)linear_sv, hvname);
629                 continue;
630             }
631
632             assert(curstash);
633
634             gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
635             if (!gvp) continue;
636
637             candidate = *gvp;
638             assert(candidate);
639
640             if (SvTYPE(candidate) != SVt_PVGV)
641                 gv_init(candidate, curstash, subname, subname_len, TRUE);
642
643             /* Notably, we only look for real entries, not method cache
644                entries, because in C3 the method cache of a parent is not
645                valid for the child */
646             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
647                 SvREFCNT_inc_simple_void_NN(MUTABLE_SV(cand_cv));
648                 (void)hv_store_ent(nmcache, sv, MUTABLE_SV(cand_cv), 0);
649                 mXPUSHs(newRV_inc(MUTABLE_SV(cand_cv)));
650                 XSRETURN(1);
651             }
652         }
653     }
654
655     (void)hv_store_ent(nmcache, sv, &PL_sv_undef, 0);
656     if(throw_nomethod)
657         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
658     XSRETURN_EMPTY;
659
660 BOOT:
661     Perl_mro_register(aTHX_ &c3_alg);