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 | |
26 | CV* |
27 | canxs(self) |
28 | SV* self; |
29 | CODE: |
30 | register I32 cxix = __dopoptosub_at(cxstack, cxstack_ix); |
31 | register const PERL_CONTEXT *cx; |
32 | register const PERL_CONTEXT *ccstack = cxstack; |
33 | const PERL_SI *top_si = PL_curstackinfo; |
34 | HV* selfstash; |
35 | //sv_dump(self); |
36 | if(sv_isobject(self)) { |
37 | selfstash = SvSTASH(SvRV(self)); |
38 | } |
39 | else { |
40 | selfstash = gv_stashsv(self, 0); |
41 | } |
42 | assert(selfstash); |
43 | |
44 | for (;;) { |
45 | /* we may be in a higher stacklevel, so dig down deeper */ |
46 | while (cxix < 0 && top_si->si_type != PERLSI_MAIN) { |
47 | top_si = top_si->si_prev; |
48 | ccstack = top_si->si_cxstack; |
49 | cxix = __dopoptosub_at(ccstack, top_si->si_cxix); |
50 | } |
51 | if (cxix < 0) { |
52 | croak("next::/maybe::next:: must be used in method context"); |
53 | } |
54 | |
55 | /* caller() should not report the automatic calls to &DB::sub */ |
56 | if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub)) |
57 | continue; |
58 | |
59 | cx = &ccstack[cxix]; |
60 | if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
61 | const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); |
62 | /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the |
63 | field below is defined for any cx. */ |
64 | /* caller() should not report the automatic calls to &DB::sub */ |
65 | if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) |
66 | cx = &ccstack[dbcxix]; |
67 | } |
68 | if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) { |
69 | GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv); |
70 | /* So is ccstack[dbcxix]. */ |
71 | if (isGV(cvgv)) { /* we found a real sub here */ |
72 | const char *stashname; |
73 | const char *fq_subname; |
74 | const char *subname; |
75 | STRLEN fq_subname_len; |
76 | STRLEN stashname_len; |
77 | STRLEN subname_len; |
78 | GV * found_gv; |
79 | SV * const sv = sv_2mortal(newSV(0)); |
80 | |
81 | gv_efullname3(sv, cvgv, NULL); |
82 | |
83 | fq_subname = SvPVX(sv); |
84 | fq_subname_len = SvCUR(sv); |
85 | /* warn("fqsubname is %s", fq_subname); */ |
86 | |
87 | subname = strrchr(fq_subname, ':'); |
88 | if(subname) { |
89 | subname++; |
90 | subname_len = fq_subname_len - (subname - fq_subname); |
91 | stashname = fq_subname; |
92 | stashname_len = subname - fq_subname - 2; |
93 | if(subname_len == 8 && strEQ(subname, "__ANON__")) { |
94 | croak("Cannot use next::method/next::can/maybe::next::method from an anonymous sub"); |
95 | } |
96 | else { |
97 | GV** gvp; |
98 | AV* linear_av; |
99 | SV** linear_svp; |
100 | SV* linear_sv; |
101 | HV* curstash; |
102 | GV* candidate = NULL; |
103 | CV* cand_cv = NULL; |
104 | const char *hvname; |
105 | I32 items; |
106 | |
107 | hvname = HvNAME_get(selfstash); |
108 | if (!hvname) |
109 | Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); |
110 | |
111 | linear_av = mro_linear(selfstash); /* has ourselves at the top of the list */ |
112 | sv_2mortal((SV*)linear_av); |
113 | |
114 | linear_svp = AvARRAY(linear_av) + 1; /* skip over self */ |
115 | items = AvFILLp(linear_av); /* no +1, to skip over self */ |
116 | |
117 | while (items--) { |
118 | linear_sv = *linear_svp++; |
119 | assert(linear_sv); |
120 | if(strEQ(SvPVX(linear_sv), stashname)) break; |
121 | } |
122 | |
123 | while (items--) { |
124 | linear_sv = *linear_svp++; |
125 | assert(linear_sv); |
126 | curstash = gv_stashsv(linear_sv, FALSE); |
127 | |
128 | if (!curstash) { |
129 | if (ckWARN(WARN_MISC)) |
130 | Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", |
131 | (void*)linear_sv, hvname); |
132 | continue; |
133 | } |
134 | |
135 | assert(curstash); |
136 | |
137 | gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0); |
138 | if (!gvp) continue; |
139 | candidate = *gvp; |
140 | assert(candidate); |
141 | if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, curstash, subname, subname_len, TRUE); |
142 | if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { |
143 | PUSHs((SV*)cand_cv); |
144 | return; |
145 | } |
146 | } |
147 | |
148 | /* Check UNIVERSAL without caching */ |
149 | if((candidate = gv_fetchmeth(NULL, subname, subname_len, 1))) { |
150 | PUSHs((SV*)GvCV(candidate)); |
151 | return; |
152 | } |
153 | PUSHs(&PL_sv_undef); |
154 | return; |
155 | } |
156 | } |
157 | } |
158 | } |
159 | |
160 | cxix = __dopoptosub_at(ccstack, cxix - 1); |
161 | } |
162 | |
163 | |