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