Commit | Line | Data |
---|---|---|
6d4a7be2 PP |
1 | #include "EXTERN.h" |
2 | #include "perl.h" | |
3 | #include "XSUB.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 | isa_lookup(stash, name, len, level) | |
12 | HV *stash; | |
13 | char *name; | |
14 | int len; | |
15 | int level; | |
16 | { | |
17 | AV* av; | |
18 | GV* gv; | |
19 | GV** gvp; | |
20 | HV* hv = Nullhv; | |
21 | ||
22 | if (!stash) | |
23 | return &sv_undef; | |
24 | ||
25 | if(strEQ(HvNAME(stash), name)) | |
26 | return &sv_yes; | |
27 | ||
28 | if (level > 100) | |
29 | croak("Recursive inheritance detected"); | |
30 | ||
31 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); | |
32 | ||
33 | if (gvp && (gv = *gvp) != (GV*)&sv_undef && (hv = GvHV(gv))) { | |
34 | SV* sv; | |
35 | SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); | |
36 | if (svp && (sv = *svp) != (SV*)&sv_undef) | |
37 | return sv; | |
38 | } | |
39 | ||
40 | gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); | |
41 | ||
42 | if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) { | |
43 | if(!hv) { | |
44 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); | |
45 | ||
46 | gv = *gvp; | |
47 | ||
48 | if (SvTYPE(gv) != SVt_PVGV) | |
49 | gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); | |
50 | ||
51 | hv = GvHVn(gv); | |
52 | } | |
53 | if(hv) { | |
54 | SV** svp = AvARRAY(av); | |
55 | I32 items = AvFILL(av) + 1; | |
56 | while (items--) { | |
57 | SV* sv = *svp++; | |
58 | HV* basestash = gv_stashsv(sv, FALSE); | |
59 | if (!basestash) { | |
60 | if (dowarn) | |
61 | warn("Can't locate package %s for @%s::ISA", | |
62 | SvPVX(sv), HvNAME(stash)); | |
63 | continue; | |
64 | } | |
65 | if(&sv_yes == isa_lookup(basestash, name, len, level + 1)) { | |
66 | (void)hv_store(hv,name,len,&sv_yes,0); | |
67 | return &sv_yes; | |
68 | } | |
69 | } | |
70 | (void)hv_store(hv,name,len,&sv_no,0); | |
71 | } | |
72 | } | |
73 | ||
74 | return &sv_no; | |
75 | } | |
76 | ||
77 | static | |
78 | XS(XS_UNIVERSAL_isa) | |
79 | { | |
80 | dXSARGS; | |
81 | SV *sv, *rv; | |
82 | char *name; | |
83 | ||
84 | if (items != 2) | |
85 | croak("Usage: UNIVERSAL::isa(reference, kind)"); | |
86 | ||
87 | sv = ST(0); | |
88 | name = (char *)SvPV(ST(1),na); | |
89 | ||
90 | if (!SvROK(sv)) { | |
91 | rv = &sv_no; | |
92 | } | |
93 | else if((sv = (SV*)SvRV(sv)) && SvOBJECT(sv) && | |
94 | &sv_yes == isa_lookup(SvSTASH(sv), name, strlen(name), 0)) { | |
95 | rv = &sv_yes; | |
96 | } | |
97 | else { | |
98 | char *s; | |
99 | ||
100 | switch (SvTYPE(sv)) { | |
101 | case SVt_NULL: | |
102 | case SVt_IV: | |
103 | case SVt_NV: | |
104 | case SVt_RV: | |
105 | case SVt_PV: | |
106 | case SVt_PVIV: | |
107 | case SVt_PVNV: | |
108 | case SVt_PVBM: | |
109 | case SVt_PVMG: s = "SCALAR"; break; | |
110 | case SVt_PVLV: s = "LVALUE"; break; | |
111 | case SVt_PVAV: s = "ARRAY"; break; | |
112 | case SVt_PVHV: s = "HASH"; break; | |
113 | case SVt_PVCV: s = "CODE"; break; | |
114 | case SVt_PVGV: s = "GLOB"; break; | |
115 | case SVt_PVFM: s = "FORMATLINE"; break; | |
116 | case SVt_PVIO: s = "FILEHANDLE"; break; | |
117 | default: s = "UNKNOWN"; break; | |
118 | } | |
119 | rv = strEQ(s,name) ? &sv_yes : &sv_no; | |
120 | } | |
121 | ||
122 | ST(0) = rv; | |
123 | XSRETURN(1); | |
124 | } | |
125 | ||
126 | static | |
127 | XS(XS_UNIVERSAL_can) | |
128 | { | |
129 | dXSARGS; | |
130 | SV *sv; | |
131 | char *name; | |
132 | SV *rv; | |
133 | GV *gv; | |
134 | CV *cvp; | |
135 | ||
136 | if (items != 2) | |
137 | croak("Usage: UNIVERSAL::can(object-ref, method)"); | |
138 | ||
139 | sv = ST(0); | |
140 | name = (char *)SvPV(ST(1),na); | |
141 | rv = &sv_undef; | |
142 | ||
143 | if(SvROK(sv) && (sv = (SV*)SvRV(sv)) && SvOBJECT(sv)) { | |
144 | gv = gv_fetchmethod(SvSTASH(sv), name); | |
145 | ||
146 | if(gv && GvCV(gv)) { | |
147 | /* If the sub is only a stub then we may have a gv to AUTOLOAD */ | |
148 | GV **gvp = (GV**)hv_fetch(GvSTASH(gv), name, strlen(name), TRUE); | |
149 | if(gvp && (cvp = GvCV(*gvp))) { | |
150 | rv = sv_newmortal(); | |
151 | sv_setsv(rv, newRV((SV*)cvp)); | |
152 | } | |
153 | } | |
154 | } | |
155 | ||
156 | ST(0) = rv; | |
157 | XSRETURN(1); | |
158 | } | |
159 | ||
160 | static | |
161 | XS(XS_UNIVERSAL_is_instance) | |
162 | { | |
163 | dXSARGS; | |
164 | ST(0) = SvROK(ST(0)) ? &sv_yes : &sv_no; | |
165 | XSRETURN(1); | |
166 | } | |
167 | ||
168 | static | |
169 | XS(XS_UNIVERSAL_class) | |
170 | { | |
171 | dXSARGS; | |
172 | if(SvROK(ST(0))) { | |
173 | SV *sv = sv_newmortal(); | |
174 | sv_setpv(sv, HvNAME(SvSTASH(ST(0)))); | |
175 | ST(0) = sv; | |
176 | } | |
177 | XSRETURN(1); | |
178 | } | |
179 | ||
180 | static | |
181 | XS(XS_UNIVERSAL_VERSION) | |
182 | { | |
183 | dXSARGS; | |
184 | HV *pkg; | |
185 | GV **gvp; | |
186 | GV *gv; | |
187 | SV *sv; | |
188 | char *undef; | |
189 | ||
190 | if(SvROK(ST(0))) { | |
191 | sv = (SV*)SvRV(ST(0)); | |
192 | if(!SvOBJECT(sv)) | |
193 | croak("Cannot find version of an unblessed reference"); | |
194 | pkg = SvSTASH(sv); | |
195 | } | |
196 | else { | |
197 | pkg = gv_stashsv(ST(0), FALSE); | |
198 | } | |
199 | ||
200 | gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); | |
201 | ||
202 | if (gvp && (gv = *gvp) != (GV*)&sv_undef && (sv = GvSV(gv))) { | |
203 | SV *nsv = sv_newmortal(); | |
204 | sv_setsv(nsv, sv); | |
205 | sv = nsv; | |
206 | undef = Nullch; | |
207 | } | |
208 | else { | |
209 | sv = (SV*)&sv_undef; | |
210 | undef = "(undef)"; | |
211 | } | |
212 | ||
213 | if(items > 1 && (undef || SvNV(ST(1)) > SvNV(sv))) | |
214 | croak("%s version %s required--this is only version %s", | |
215 | HvNAME(pkg),SvPV(ST(1),na),undef ? undef : SvPV(sv,na)); | |
216 | ||
217 | ST(0) = sv; | |
218 | ||
219 | XSRETURN(1); | |
220 | } | |
221 | ||
222 | void | |
223 | boot_core_UNIVERSAL() | |
224 | { | |
225 | char *file = __FILE__; | |
226 | ||
227 | newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); | |
228 | newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); | |
229 | newXS("UNIVERSAL::class", XS_UNIVERSAL_class, file); | |
230 | newXS("UNIVERSAL::is_instance", XS_UNIVERSAL_is_instance, file); | |
231 | newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); | |
232 | } |