1
2#include "EXTERN.h"
3#include "perl.h"
4#include "XSUB.h"
5
6/* *********** ppport stuff */
7
8#ifndef PERL_UNUSED_VAR
9#  define PERL_UNUSED_VAR(x) ((void)x)
10#endif
11
12#if defined(PERL_GCC_PEDANTIC)
13#  ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN
14#    define PERL_GCC_BRACE_GROUPS_FORBIDDEN
15#  endif
16#endif
17
18#if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus)
19#  ifndef PERL_USE_GCC_BRACE_GROUPS
20#    define PERL_USE_GCC_BRACE_GROUPS
21#  endif
22#endif
23
24#ifndef SvREFCNT_inc
25#  ifdef PERL_USE_GCC_BRACE_GROUPS
26#    define SvREFCNT_inc(sv)		\
27      ({				\
28          SV * const _sv = (SV*)(sv);	\
29          if (_sv)			\
30               (SvREFCNT(_sv))++;	\
31          _sv;				\
32      })
33#  else
34#    define SvREFCNT_inc(sv)	\
35          ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL)
36#  endif
37#endif
38
39#ifndef dAX
40#  define dAX                            I32 ax = MARK - PL_stack_base + 1
41#endif
42
43#ifndef dVAR
44#  define dVAR                           dNOOP
45#endif
46
47#ifndef packWARN
48#  define packWARN(a)                    (a)
49#endif
50
51/* *********** end ppport.h stuff */
52
53/* Most of this code is backported from the bleadperl patch's
54   mro.c, and then modified to work with Class::C3's
55   internals.
56*/
57
58AV*
59__mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level)
60{
61    AV* retval;
62    GV** gvp;
63    GV* gv;
64    AV* isa;
65    const char* stashname;
66    STRLEN stashname_len;
67    I32 made_mortal_cache = 0;
68
69    assert(stash);
70
71    stashname = HvNAME(stash);
72    stashname_len = strlen(stashname);
73    if (!stashname)
74      Perl_croak(aTHX_
75                 "Can't linearize anonymous symbol table");
76
77    if (level > 100)
78        Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
79              stashname);
80
81    if(!cache) {
82        cache = (HV*)sv_2mortal((SV*)newHV());
83        made_mortal_cache = 1;
84    }
85    else {
86        SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0);
87        if(cache_entry)
88            return (AV*)SvREFCNT_inc(*cache_entry);
89    }
90
91    /* not in cache, make a new one */
92
93    gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
94    isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL;
95    if(isa && AvFILLp(isa) >= 0) {
96        SV** seqs_ptr;
97        I32 seqs_items;
98        HV* const tails = (HV*)sv_2mortal((SV*)newHV());
99        AV* const seqs = (AV*)sv_2mortal((SV*)newAV());
100        I32* heads;
101
102        /* This builds @seqs, which is an array of arrays.
103           The members of @seqs are the MROs of
104           the members of @ISA, followed by @ISA itself.
105        */
106        I32 items = AvFILLp(isa) + 1;
107        SV** isa_ptr = AvARRAY(isa);
108        while(items--) {
109            SV* const isa_item = *isa_ptr++;
110            HV* const isa_item_stash = gv_stashsv(isa_item, 0);
111            if(!isa_item_stash) {
112                /* if no stash, make a temporary fake MRO
113                   containing just itself */
114                AV* const isa_lin = newAV();
115                av_push(isa_lin, newSVsv(isa_item));
116                av_push(seqs, (SV*)isa_lin);
117            }
118            else {
119                /* recursion */
120                AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1);
121                av_push(seqs, (SV*)isa_lin);
122            }
123        }
124        av_push(seqs, SvREFCNT_inc((SV*)isa));
125
126        /* This builds "heads", which as an array of integer array
127           indices, one per seq, which point at the virtual "head"
128           of the seq (initially zero) */
129        Newz(0xdead, heads, AvFILLp(seqs)+1, I32);
130
131        /* This builds %tails, which has one key for every class
132           mentioned in the tail of any sequence in @seqs (tail meaning
133           everything after the first class, the "head").  The value
134           is how many times this key appears in the tails of @seqs.
135        */
136        seqs_ptr = AvARRAY(seqs);
137        seqs_items = AvFILLp(seqs) + 1;
138        while(seqs_items--) {
139            AV* const seq = (AV*)*seqs_ptr++;
140            I32 seq_items = AvFILLp(seq);
141            if(seq_items > 0) {
142                SV** seq_ptr = AvARRAY(seq) + 1;
143                while(seq_items--) {
144                    SV* const seqitem = *seq_ptr++;
145                    HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
146                    if(!he) {
147                        hv_store_ent(tails, seqitem, newSViv(1), 0);
148                    }
149                    else {
150                        SV* const val = HeVAL(he);
151                        sv_inc(val);
152                    }
153                }
154            }
155        }
156
157        /* Initialize retval to build the return value in */
158        retval = newAV();
159        av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */
160
161        /* This loop won't terminate until we either finish building
162           the MRO, or get an exception. */
163        while(1) {
164            SV* cand = NULL;
165            SV* winner = NULL;
166            int s;
167
168            /* "foreach $seq (@seqs)" */
169            SV** const avptr = AvARRAY(seqs);
170            for(s = 0; s <= AvFILLp(seqs); s++) {
171                SV** svp;
172                AV * const seq = (AV*)(avptr[s]);
173                SV* seqhead;
174                if(!seq) continue; /* skip empty seqs */
175                svp = av_fetch(seq, heads[s], 0);
176                seqhead = *svp; /* seqhead = head of this seq */
177                if(!winner) {
178                    HE* tail_entry;
179                    SV* val;
180                    /* if we haven't found a winner for this round yet,
181                       and this seqhead is not in tails (or the count
182                       for it in tails has dropped to zero), then this
183                       seqhead is our new winner, and is added to the
184                       final MRO immediately */
185                    cand = seqhead;
186                    if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
187                       && (val = HeVAL(tail_entry))
188                       && (SvIVX(val) > 0))
189                           continue;
190                    winner = newSVsv(cand);
191                    av_push(retval, winner);
192                    /* note however that even when we find a winner,
193                       we continue looping over @seqs to do housekeeping */
194                }
195                if(!sv_cmp(seqhead, winner)) {
196                    /* Once we have a winner (including the iteration
197                       where we first found him), inc the head ptr
198                       for any seq which had the winner as a head,
199                       NULL out any seq which is now empty,
200                       and adjust tails for consistency */
201
202                    const int new_head = ++heads[s];
203                    if(new_head > AvFILLp(seq)) {
204                        SvREFCNT_dec(avptr[s]);
205                        avptr[s] = NULL;
206                    }
207                    else {
208                        HE* tail_entry;
209                        SV* val;
210                        /* Because we know this new seqhead used to be
211                           a tail, we can assume it is in tails and has
212                           a positive value, which we need to dec */
213                        svp = av_fetch(seq, new_head, 0);
214                        seqhead = *svp;
215                        tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
216                        val = HeVAL(tail_entry);
217                        sv_dec(val);
218                    }
219                }
220            }
221
222            /* if we found no candidates, we are done building the MRO.
223               !cand means no seqs have any entries left to check */
224            if(!cand) {
225                Safefree(heads);
226                break;
227            }
228
229            /* If we had candidates, but nobody won, then the @ISA
230               hierarchy is not C3-incompatible */
231            if(!winner) {
232                /* we have to do some cleanup before we croak */
233
234                SvREFCNT_dec(retval);
235                Safefree(heads);
236
237                Perl_croak(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s': "
238                    "merging failed on parent '%s'", stashname, SvPV_nolen(cand));
239            }
240        }
241    }
242    else { /* @ISA was undefined or empty */
243        /* build a retval containing only ourselves */
244        retval = newAV();
245        av_push(retval, newSVpvn(stashname, stashname_len));
246    }
247
248    /* we don't want anyone modifying the cache entry but us,
249       and we do so by replacing it completely */
250    SvREADONLY_on(retval);
251
252    if(!made_mortal_cache) {
253        SvREFCNT_inc(retval);
254        hv_store(cache, stashname, stashname_len, (SV*)retval, 0);
255    }
256
257    return retval;
258}
259
260STATIC I32
261__dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) {
262    I32 i;
263    for (i = startingblock; i >= 0; i--) {
264        if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i;
265    }
266    return i;
267}
268
269XS(XS_Class_C3_XS_nextcan);
270XS(XS_Class_C3_XS_nextcan)
271{
272    dVAR; dXSARGS;
273
274    SV* self = ST(0);
275    const I32 throw_nomethod = SvIVX(ST(1));
276    register I32 cxix = cxstack_ix;
277    register const PERL_CONTEXT *ccstack = cxstack;
278    const PERL_SI *top_si = PL_curstackinfo;
279    HV* selfstash;
280    GV* cvgv;
281    SV *stashname;
282    const char *fq_subname;
283    const char *subname;
284    STRLEN fq_subname_len;
285    STRLEN stashname_len;
286    STRLEN subname_len;
287    SV* sv;
288    GV** gvp;
289    AV* linear_av;
290    SV** linear_svp;
291    HV* cstash;
292    GV* candidate = NULL;
293    CV* cand_cv = NULL;
294    const char *hvname;
295    I32 entries;
296    HV* nmcache;
297    HE* cache_entry;
298    SV* cachekey;
299    int i;
300
301    SP -= items;
302
303    if(sv_isobject(self))
304        selfstash = SvSTASH(SvRV(self));
305    else
306        selfstash = gv_stashsv(self, 0);
307
308    assert(selfstash);
309
310    hvname = HvNAME(selfstash);
311    if (!hvname)
312        Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup");
313
314    /* This block finds the contextually-enclosing fully-qualified subname,
315       much like looking at (caller($i))[3] until you find a real sub that
316       isn't ANON, etc (also skips over pureperl next::method, etc) */
317    for(i = 0; i < 2; i++) {
318        cxix = __dopoptosub_at(ccstack, cxix);
319        for (;;) {
320            /* we may be in a higher stacklevel, so dig down deeper */
321            while (cxix < 0) {
322                if(top_si->si_type == PERLSI_MAIN)
323                    Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context");
324                top_si = top_si->si_prev;
325                ccstack = top_si->si_cxstack;
326                cxix = __dopoptosub_at(ccstack, top_si->si_cxix);
327            }
328
329            if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB
330              || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) {
331                cxix = __dopoptosub_at(ccstack, cxix - 1);
332                continue;
333            }
334
335            {
336                const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1);
337                if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) {
338                    if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) {
339                        cxix = dbcxix;
340                        continue;
341                    }
342                }
343            }
344
345            cvgv = CvGV(ccstack[cxix].blk_sub.cv);
346
347            if(!isGV(cvgv)) {
348                cxix = __dopoptosub_at(ccstack, cxix - 1);
349                continue;
350            }
351
352            /* we found a real sub here */
353            sv = sv_2mortal(newSV(0));
354
355            gv_efullname3(sv, cvgv, NULL);
356
357            fq_subname = SvPVX(sv);
358            fq_subname_len = SvCUR(sv);
359
360            subname = strrchr(fq_subname, ':');
361            if(!subname)
362                Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method");
363
364            subname++;
365            subname_len = fq_subname_len - (subname - fq_subname);
366            if(subname_len == 8 && strEQ(subname, "__ANON__")) {
367                cxix = __dopoptosub_at(ccstack, cxix - 1);
368                continue;
369            }
370            break;
371        }
372        cxix--;
373    }
374
375    /* If we made it to here, we found our context */
376
377    /* cachekey = "objpkg|context::method::name" */
378    cachekey = sv_2mortal(newSVpv(hvname, 0));
379    sv_catpvn(cachekey, "|", 1);
380    sv_catsv(cachekey, sv);
381
382    nmcache = get_hv("next::METHOD_CACHE", 1);
383    if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) {
384        SV* val = HeVAL(cache_entry);
385        if(val == &PL_sv_undef) {
386            if(throw_nomethod)
387                Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
388            XSRETURN_EMPTY;
389        }
390        XPUSHs(sv_2mortal(newRV_inc(val)));
391        XSRETURN(1);
392    }
393
394    /* beyond here is just for cache misses, so perf isn't as critical */
395
396    stashname_len = subname - fq_subname - 2;
397    stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len));
398
399    linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0);
400
401    linear_svp = AvARRAY(linear_av);
402    entries = AvFILLp(linear_av) + 1;
403
404    while (entries--) {
405        SV* const linear_sv = *linear_svp++;
406        assert(linear_sv);
407        if(sv_eq(linear_sv, stashname))
408            break;
409    }
410
411    if(entries > 0) {
412        SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len));
413        HV* cc3_mro = get_hv("Class::C3::MRO", 0);
414
415        while (entries--) {
416            SV* const linear_sv = *linear_svp++;
417            assert(linear_sv);
418
419            if(cc3_mro) {
420                HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0);
421                if(he_cc3_mro_class) {
422                    SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class);
423                    if(SvROK(cc3_mro_class_sv)) {
424                        HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv);
425                        SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0);
426                        if(svp_cc3_mro_class_methods) {
427                            SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods;
428                            if(SvROK(cc3_mro_class_methods_sv)) {
429                                HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv);
430                                if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0))
431                                    continue;
432                            }
433                        }
434                    }
435                }
436            }
437
438            cstash = gv_stashsv(linear_sv, FALSE);
439
440            if (!cstash) {
441                if (ckWARN(WARN_MISC))
442                    Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
443                        (void*)linear_sv, hvname);
444                continue;
445            }
446
447            assert(cstash);
448
449            gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0);
450            if (!gvp) continue;
451
452            candidate = *gvp;
453            assert(candidate);
454
455            if (SvTYPE(candidate) != SVt_PVGV)
456                gv_init(candidate, cstash, subname, subname_len, TRUE);
457            if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
458                SvREFCNT_dec(linear_av);
459                SvREFCNT_inc((SV*)cand_cv);
460                hv_store_ent(nmcache, newSVsv(cachekey), (SV*)cand_cv, 0);
461                XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
462                XSRETURN(1);
463            }
464        }
465    }
466
467    SvREFCNT_dec(linear_av);
468    hv_store_ent(nmcache, newSVsv(cachekey), &PL_sv_undef, 0);
469    if(throw_nomethod)
470        Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
471    XSRETURN_EMPTY;
472}
473
474XS(XS_Class_C3_XS_calculateMRO);
475XS(XS_Class_C3_XS_calculateMRO)
476{
477    dVAR; dXSARGS;
478
479    SV* classname;
480    HV* class_stash;
481    HV* cache = NULL;
482    AV* res;
483    I32 res_items;
484    I32 ret_items;
485    SV** res_ptr;
486
487    if(items < 1 || items > 2)
488        croak("Usage: calculateMRO(classname[, cache])");
489
490    classname = ST(0);
491    if(items == 2) cache = (HV*)SvRV(ST(1));
492
493    class_stash = gv_stashsv(classname, 0);
494    if(!class_stash)
495        Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
496
497    res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
498
499    res_items = ret_items = AvFILLp(res) + 1;
500    res_ptr = AvARRAY(res);
501
502    SP -= items;
503
504    while(res_items--) {
505        SV* res_item = *res_ptr++;
506        XPUSHs(sv_2mortal(newSVsv(res_item)));
507    }
508    SvREFCNT_dec(res);
509
510    PUTBACK;
511
512    return;
513}
514
515XS(XS_Class_C3_XS_plsubgen);
516XS(XS_Class_C3_XS_plsubgen)
517{
518    dVAR; dXSARGS;
519
520    SP -= items;
521    XPUSHs(sv_2mortal(newSViv(PL_sub_generation)));
522    PUTBACK;
523    return;
524}
525
526XS(XS_Class_C3_XS_calc_mdt);
527XS(XS_Class_C3_XS_calc_mdt)
528{
529    dVAR; dXSARGS;
530
531    SV* classname;
532    HV* cache;
533    HV* class_stash;
534    AV* class_mro;
535    HV* our_c3mro; /* $Class::C3::MRO{classname} */
536    SV* has_ovf = NULL;
537    HV* methods;
538    I32 mroitems;
539
540    /* temps */
541    HV* hv;
542    HE* he;
543    SV** svp;
544
545    if(items < 1 || items > 2)
546        croak("Usage: calculate_method_dispatch_table(classname[, cache])");
547
548    classname = ST(0);
549    class_stash = gv_stashsv(classname, 0);
550    if(!class_stash)
551        Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname));
552
553    if(items == 2) cache = (HV*)SvRV(ST(1));
554
555    class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0);
556
557    our_c3mro = newHV();
558    hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0);
559
560    hv = get_hv("Class::C3::MRO", 1);
561    hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0);
562
563    methods = newHV();
564
565    /* skip first entry */
566    mroitems = AvFILLp(class_mro);
567    svp = AvARRAY(class_mro) + 1;
568    while(mroitems--) {
569        SV* mro_class = *svp++;
570        HV* mro_stash = gv_stashsv(mro_class, 0);
571
572        if(!mro_stash) continue;
573
574        if(!has_ovf) {
575            SV** ovfp = hv_fetch(mro_stash, "()", 2, 0);
576            if(ovfp) has_ovf = *ovfp;
577        }
578
579        hv_iterinit(mro_stash);
580        while(he = hv_iternext(mro_stash)) {
581            CV* code;
582            SV* mskey;
583            SV* msval;
584            HE* ourent;
585            HV* meth_hash;
586            SV* orig;
587
588            mskey = hv_iterkeysv(he);
589            if(hv_exists_ent(methods, mskey, 0)) continue;
590
591            msval = hv_iterval(mro_stash, he);
592            if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval)))
593                continue;
594
595            if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) {
596                SV* val = HeVAL(ourent);
597                if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val))
598                    continue;
599            }
600
601            meth_hash = newHV();
602            orig = newSVsv(mro_class);
603            sv_catpvn(orig, "::", 2);
604            sv_catsv(orig, mskey);
605            hv_store(meth_hash, "orig", 4, orig, 0);
606            hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0);
607            hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0);
608        }
609    }
610
611    hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0);
612    if(has_ovf) hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0);
613    XSRETURN_EMPTY;
614}
615
616MODULE = Class::C3::XS	PACKAGE = Class::C3::XS
617
618BOOT:
619    newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__);
620    newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__);
621    newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__);
622    newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__);
623
624