1 | #include "EXTERN.h" |
---|
2 | #define PERL_IN_UNIVERSAL_C |
---|
3 | #include "perl.h" |
---|
4 | |
---|
5 | /* |
---|
6 | * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> |
---|
7 | * The main guts of traverse_isa was actually copied from gv_fetchmeth |
---|
8 | */ |
---|
9 | |
---|
10 | STATIC SV * |
---|
11 | S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level) |
---|
12 | { |
---|
13 | AV* av; |
---|
14 | GV* gv; |
---|
15 | GV** gvp; |
---|
16 | HV* hv = Nullhv; |
---|
17 | SV* subgen = Nullsv; |
---|
18 | |
---|
19 | if (!stash) |
---|
20 | return &PL_sv_undef; |
---|
21 | |
---|
22 | if (strEQ(HvNAME(stash), name)) |
---|
23 | return &PL_sv_yes; |
---|
24 | |
---|
25 | if (level > 100) |
---|
26 | Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", |
---|
27 | HvNAME(stash)); |
---|
28 | |
---|
29 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); |
---|
30 | |
---|
31 | if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) |
---|
32 | && (hv = GvHV(gv))) |
---|
33 | { |
---|
34 | if (SvIV(subgen) == PL_sub_generation) { |
---|
35 | SV* sv; |
---|
36 | SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); |
---|
37 | if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { |
---|
38 | DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", |
---|
39 | name, HvNAME(stash)) ); |
---|
40 | return sv; |
---|
41 | } |
---|
42 | } |
---|
43 | else { |
---|
44 | DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", |
---|
45 | HvNAME(stash)) ); |
---|
46 | hv_clear(hv); |
---|
47 | sv_setiv(subgen, PL_sub_generation); |
---|
48 | } |
---|
49 | } |
---|
50 | |
---|
51 | gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); |
---|
52 | |
---|
53 | if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { |
---|
54 | if (!hv || !subgen) { |
---|
55 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); |
---|
56 | |
---|
57 | gv = *gvp; |
---|
58 | |
---|
59 | if (SvTYPE(gv) != SVt_PVGV) |
---|
60 | gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); |
---|
61 | |
---|
62 | if (!hv) |
---|
63 | hv = GvHVn(gv); |
---|
64 | if (!subgen) { |
---|
65 | subgen = newSViv(PL_sub_generation); |
---|
66 | GvSV(gv) = subgen; |
---|
67 | } |
---|
68 | } |
---|
69 | if (hv) { |
---|
70 | SV** svp = AvARRAY(av); |
---|
71 | /* NOTE: No support for tied ISA */ |
---|
72 | I32 items = AvFILLp(av) + 1; |
---|
73 | while (items--) { |
---|
74 | SV* sv = *svp++; |
---|
75 | HV* basestash = gv_stashsv(sv, FALSE); |
---|
76 | if (!basestash) { |
---|
77 | if (ckWARN(WARN_MISC)) |
---|
78 | Perl_warner(aTHX_ WARN_SYNTAX, |
---|
79 | "Can't locate package %s for @%s::ISA", |
---|
80 | SvPVX(sv), HvNAME(stash)); |
---|
81 | continue; |
---|
82 | } |
---|
83 | if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) { |
---|
84 | (void)hv_store(hv,name,len,&PL_sv_yes,0); |
---|
85 | return &PL_sv_yes; |
---|
86 | } |
---|
87 | } |
---|
88 | (void)hv_store(hv,name,len,&PL_sv_no,0); |
---|
89 | } |
---|
90 | } |
---|
91 | |
---|
92 | return boolSV(strEQ(name, "UNIVERSAL")); |
---|
93 | } |
---|
94 | |
---|
95 | /* |
---|
96 | =for apidoc sv_derived_from |
---|
97 | |
---|
98 | Returns a boolean indicating whether the SV is derived from the specified |
---|
99 | class. This is the function that implements C<UNIVERSAL::isa>. It works |
---|
100 | for class names as well as for objects. |
---|
101 | |
---|
102 | =cut |
---|
103 | */ |
---|
104 | |
---|
105 | bool |
---|
106 | Perl_sv_derived_from(pTHX_ SV *sv, const char *name) |
---|
107 | { |
---|
108 | char *type; |
---|
109 | HV *stash; |
---|
110 | |
---|
111 | stash = Nullhv; |
---|
112 | type = Nullch; |
---|
113 | |
---|
114 | if (SvGMAGICAL(sv)) |
---|
115 | mg_get(sv) ; |
---|
116 | |
---|
117 | if (SvROK(sv)) { |
---|
118 | sv = SvRV(sv); |
---|
119 | type = sv_reftype(sv,0); |
---|
120 | if (SvOBJECT(sv)) |
---|
121 | stash = SvSTASH(sv); |
---|
122 | } |
---|
123 | else { |
---|
124 | stash = gv_stashsv(sv, FALSE); |
---|
125 | } |
---|
126 | |
---|
127 | return (type && strEQ(type,name)) || |
---|
128 | (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes) |
---|
129 | ? TRUE |
---|
130 | : FALSE ; |
---|
131 | } |
---|
132 | |
---|
133 | void XS_UNIVERSAL_isa(pTHXo_ CV *cv); |
---|
134 | void XS_UNIVERSAL_can(pTHXo_ CV *cv); |
---|
135 | void XS_UNIVERSAL_VERSION(pTHXo_ CV *cv); |
---|
136 | |
---|
137 | void |
---|
138 | Perl_boot_core_UNIVERSAL(pTHX) |
---|
139 | { |
---|
140 | char *file = __FILE__; |
---|
141 | |
---|
142 | newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); |
---|
143 | newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); |
---|
144 | newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); |
---|
145 | } |
---|
146 | |
---|
147 | #include "XSUB.h" |
---|
148 | |
---|
149 | XS(XS_UNIVERSAL_isa) |
---|
150 | { |
---|
151 | dXSARGS; |
---|
152 | SV *sv; |
---|
153 | char *name; |
---|
154 | STRLEN n_a; |
---|
155 | |
---|
156 | if (items != 2) |
---|
157 | Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)"); |
---|
158 | |
---|
159 | sv = ST(0); |
---|
160 | |
---|
161 | if (SvGMAGICAL(sv)) |
---|
162 | mg_get(sv); |
---|
163 | |
---|
164 | if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) |
---|
165 | XSRETURN_UNDEF; |
---|
166 | |
---|
167 | name = (char *)SvPV(ST(1),n_a); |
---|
168 | |
---|
169 | ST(0) = boolSV(sv_derived_from(sv, name)); |
---|
170 | XSRETURN(1); |
---|
171 | } |
---|
172 | |
---|
173 | XS(XS_UNIVERSAL_can) |
---|
174 | { |
---|
175 | dXSARGS; |
---|
176 | SV *sv; |
---|
177 | char *name; |
---|
178 | SV *rv; |
---|
179 | HV *pkg = NULL; |
---|
180 | STRLEN n_a; |
---|
181 | |
---|
182 | if (items != 2) |
---|
183 | Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); |
---|
184 | |
---|
185 | sv = ST(0); |
---|
186 | |
---|
187 | if (SvGMAGICAL(sv)) |
---|
188 | mg_get(sv); |
---|
189 | |
---|
190 | if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)))) |
---|
191 | XSRETURN_UNDEF; |
---|
192 | |
---|
193 | name = (char *)SvPV(ST(1),n_a); |
---|
194 | rv = &PL_sv_undef; |
---|
195 | |
---|
196 | if (SvROK(sv)) { |
---|
197 | sv = (SV*)SvRV(sv); |
---|
198 | if (SvOBJECT(sv)) |
---|
199 | pkg = SvSTASH(sv); |
---|
200 | } |
---|
201 | else { |
---|
202 | pkg = gv_stashsv(sv, FALSE); |
---|
203 | } |
---|
204 | |
---|
205 | if (pkg) { |
---|
206 | GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); |
---|
207 | if (gv && isGV(gv)) |
---|
208 | rv = sv_2mortal(newRV((SV*)GvCV(gv))); |
---|
209 | } |
---|
210 | |
---|
211 | ST(0) = rv; |
---|
212 | XSRETURN(1); |
---|
213 | } |
---|
214 | |
---|
215 | XS(XS_UNIVERSAL_VERSION) |
---|
216 | { |
---|
217 | dXSARGS; |
---|
218 | HV *pkg; |
---|
219 | GV **gvp; |
---|
220 | GV *gv; |
---|
221 | SV *sv; |
---|
222 | char *undef; |
---|
223 | |
---|
224 | if (SvROK(ST(0))) { |
---|
225 | sv = (SV*)SvRV(ST(0)); |
---|
226 | if (!SvOBJECT(sv)) |
---|
227 | Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); |
---|
228 | pkg = SvSTASH(sv); |
---|
229 | } |
---|
230 | else { |
---|
231 | pkg = gv_stashsv(ST(0), FALSE); |
---|
232 | } |
---|
233 | |
---|
234 | gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); |
---|
235 | |
---|
236 | if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) { |
---|
237 | SV *nsv = sv_newmortal(); |
---|
238 | sv_setsv(nsv, sv); |
---|
239 | sv = nsv; |
---|
240 | undef = Nullch; |
---|
241 | } |
---|
242 | else { |
---|
243 | sv = (SV*)&PL_sv_undef; |
---|
244 | undef = "(undef)"; |
---|
245 | } |
---|
246 | |
---|
247 | if (items > 1) { |
---|
248 | STRLEN len; |
---|
249 | SV *req = ST(1); |
---|
250 | |
---|
251 | if (undef) |
---|
252 | Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed", |
---|
253 | HvNAME(pkg), HvNAME(pkg)); |
---|
254 | |
---|
255 | if (!SvNIOK(sv) && SvPOK(sv)) { |
---|
256 | char *str = SvPVx(sv,len); |
---|
257 | while (len) { |
---|
258 | --len; |
---|
259 | /* XXX could DWIM "1.2.3" here */ |
---|
260 | if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_') |
---|
261 | break; |
---|
262 | } |
---|
263 | if (len) { |
---|
264 | if (SvNOK(req) && SvPOK(req)) { |
---|
265 | /* they said C<use Foo v1.2.3> and $Foo::VERSION |
---|
266 | * doesn't look like a float: do string compare */ |
---|
267 | if (sv_cmp(req,sv) == 1) { |
---|
268 | Perl_croak(aTHX_ "%s v%"VDf" required--" |
---|
269 | "this is only v%"VDf, |
---|
270 | HvNAME(pkg), req, sv); |
---|
271 | } |
---|
272 | goto finish; |
---|
273 | } |
---|
274 | /* they said C<use Foo 1.002_003> and $Foo::VERSION |
---|
275 | * doesn't look like a float: force numeric compare */ |
---|
276 | (void)SvUPGRADE(sv, SVt_PVNV); |
---|
277 | SvNVX(sv) = str_to_version(sv); |
---|
278 | SvPOK_off(sv); |
---|
279 | SvNOK_on(sv); |
---|
280 | } |
---|
281 | } |
---|
282 | /* if we get here, we're looking for a numeric comparison, |
---|
283 | * so force the required version into a float, even if they |
---|
284 | * said C<use Foo v1.2.3> */ |
---|
285 | if (SvNOK(req) && SvPOK(req)) { |
---|
286 | NV n = SvNV(req); |
---|
287 | req = sv_newmortal(); |
---|
288 | sv_setnv(req, n); |
---|
289 | } |
---|
290 | |
---|
291 | if (SvNV(req) > SvNV(sv)) |
---|
292 | Perl_croak(aTHX_ "%s version %s required--this is only version %s", |
---|
293 | HvNAME(pkg), SvPV(req,len), SvPV(sv,len)); |
---|
294 | } |
---|
295 | |
---|
296 | finish: |
---|
297 | ST(0) = sv; |
---|
298 | |
---|
299 | XSRETURN(1); |
---|
300 | } |
---|
301 | |
---|