Commit | Line | Data |
7a3af373 |
1 | |
2 | #include "EXTERN.h" |
3 | #include "perl.h" |
4 | #include "XSUB.h" |
5 | |
6 | STATIC I32 |
7 | __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { |
8 | I32 i; |
9 | for (i = startingblock; i >= 0; i--) { |
10 | register const PERL_CONTEXT * const cx = &cxstk[i]; |
11 | switch (CxTYPE(cx)) { |
12 | default: |
13 | continue; |
14 | case CXt_EVAL: |
15 | case CXt_SUB: |
16 | case CXt_FORMAT: |
17 | DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i)); |
18 | return i; |
19 | } |
20 | } |
21 | return i; |
22 | } |
23 | |
24 | MODULE = Class::C3 PACKAGE = next |
25 | |
6b80069a |
26 | #ifdef XXX_NEW_PERL /* some sort of cpp check for a perl that has mro_linear */ |
27 | |
28 | /* we want to define next::can, next::method, and maybe::next::method */ |
29 | |
7a3af373 |
30 | CV* |
31 | canxs(self) |
6b80069a |
32 | SV* self |
33 | PPCODE: |
7a3af373 |
34 | register I32 cxix = __dopoptosub_at(cxstack, cxstack_ix); |
35 | register const PERL_CONTEXT *cx; |
36 | register const PERL_CONTEXT *ccstack = cxstack; |
37 | const PERL_SI *top_si = PL_curstackinfo; |
38 | HV* selfstash; |
39 | //sv_dump(self); |
40 | if(sv_isobject(self)) { |
41 | selfstash = SvSTASH(SvRV(self)); |
42 | } |
43 | else { |
44 | selfstash = gv_stashsv(self, 0); |
45 | } |
46 | assert(selfstash); |
47 | |
48 | for (;;) { |
49 | /* we may be in a higher stacklevel, so dig down deeper */ |
50 | while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { |
51 | top_si = top_si->si_prev; |
52 | ccstack = top_si->si_cxstack; |
53 | cxix = __dopoptosub_at(ccstack, top_si->si_cxix); |
54 | } |
55 | if (cxix < 0) { |
56 | croak("next::/maybe::next:: must be used in method context"); |
57 | } |
58 | |
59 | /* caller() should not report the automatic calls to &DB::sub */ |
60 | if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) |
61 | continue; |
62 | |
63 | cx = &ccstack[cxix]; |
64 | if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
65 | const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); |
66 | /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the |
67 | field below is defined for any cx. */ |
68 | /* caller() should not report the automatic calls to &DB::sub */ |
69 | if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) |
70 | cx = &ccstack[dbcxix]; |
71 | } |
72 | if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
73 | GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv); |
74 | /* So is ccstack[dbcxix]. */ |
75 | if (isGV(cvgv)) { /* we found a real sub here */ |
76 | const char *stashname; |
77 | const char *fq_subname; |
78 | const char *subname; |
79 | STRLEN fq_subname_len; |
80 | STRLEN stashname_len; |
81 | STRLEN subname_len; |
82 | GV * found_gv; |
83 | SV * const sv = sv_2mortal(newSV(0)); |
84 | |
85 | gv_efullname3(sv, cvgv, NULL); |
86 | |
87 | fq_subname = SvPVX(sv); |
88 | fq_subname_len = SvCUR(sv); |
89 | /* warn("fqsubname is %s", fq_subname); */ |
90 | |
91 | subname = strrchr(fq_subname, ':'); |
92 | if(subname) { |
93 | subname++; |
94 | subname_len = fq_subname_len - (subname - fq_subname); |
95 | stashname = fq_subname; |
96 | stashname_len = subname - fq_subname - 2; |
97 | if(subname_len == 8 && strEQ(subname, "__ANON__")) { |
98 | croak("Cannot use next::method/next::can/maybe::next::method from an anonymous sub"); |
99 | } |
100 | else { |
101 | GV** gvp; |
102 | AV* linear_av; |
103 | SV** linear_svp; |
104 | SV* linear_sv; |
105 | HV* curstash; |
106 | GV* candidate = NULL; |
107 | CV* cand_cv = NULL; |
108 | const char *hvname; |
109 | I32 items; |
110 | |
111 | hvname = HvNAME_get(selfstash); |
112 | if (!hvname) |
113 | Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); |
114 | |
115 | linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */ |
116 | sv_2mortal((SV*)linear_av); |
117 | |
118 | linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ |
119 | items = AvFILLp(linear_av); /* no +1, to skip over self */ |
120 | |
121 | while (items--) { |
122 | linear_sv = *linear_svp++; |
123 | assert(linear_sv); |
124 | if(strEQ(SvPVX(linear_sv), stashname)) break; |
125 | } |
126 | |
127 | while (items--) { |
128 | linear_sv = *linear_svp++; |
129 | assert(linear_sv); |
130 | curstash = gv_stashsv(linear_sv, FALSE); |
131 | |
132 | if (!curstash) { |
133 | if (ckWARN(WARN_MISC)) |
134 | Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", |
135 | (void*)linear_sv, hvname); |
136 | continue; |
137 | } |
138 | |
139 | assert(curstash); |
140 | |
141 | gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0); |
142 | if (!gvp) continue; |
143 | candidate = *gvp; |
144 | assert(candidate); |
145 | if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, subname, subname_len, TRUE); |
146 | if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { |
147 | PUSHs((SV*)cand_cv); |
148 | return; |
149 | } |
150 | } |
151 | |
152 | /* Check UNIVERSAL without caching */ |
153 | if((candidate = gv_fetchmeth(NULL, subname, subname_len, 1))) { |
154 | PUSHs((SV*)GvCV(candidate)); |
155 | return; |
156 | } |
157 | PUSHs(&PL_sv_undef); |
158 | return; |
159 | } |
160 | } |
161 | } |
162 | } |
163 | |
164 | cxix = __dopoptosub_at(ccstack, cxix - 1); |
165 | } |
166 | |
167 | |
6b80069a |
168 | #else /* mro_linear stuff not in core, so do some helpers for the pure-perl variant */ |
169 | |
170 | /* we want to define two helper functions: |
171 | 1) A replacement for Alg::C3::merge based on mro_linear_c3, but without the mro_meta caching parts. |
172 | it should have optional merge cache support just like Alg::C3 does, but only support @ISA, not |
173 | generic parents. Call it Class::C3::calculateMRO_XS or something. |
174 | 2) A fast "fetch the most recent caller's package/sub-names", based on the xs can function above, |
175 | to speed up the top half of pure-perl next::method. |
176 | */ |
177 | #endif |