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 boolSV(strEQ(name, "UNIVERSAL")); |
---|
75 | } |
---|
76 | |
---|
77 | bool |
---|
78 | sv_derived_from(sv, name) |
---|
79 | SV * sv ; |
---|
80 | char * name ; |
---|
81 | { |
---|
82 | SV *rv; |
---|
83 | char *type; |
---|
84 | HV *stash; |
---|
85 | |
---|
86 | stash = Nullhv; |
---|
87 | type = Nullch; |
---|
88 | |
---|
89 | if (SvGMAGICAL(sv)) |
---|
90 | mg_get(sv) ; |
---|
91 | |
---|
92 | if (SvROK(sv)) { |
---|
93 | sv = SvRV(sv); |
---|
94 | type = sv_reftype(sv,0); |
---|
95 | if(SvOBJECT(sv)) |
---|
96 | stash = SvSTASH(sv); |
---|
97 | } |
---|
98 | else { |
---|
99 | stash = gv_stashsv(sv, FALSE); |
---|
100 | } |
---|
101 | |
---|
102 | return (type && strEQ(type,name)) || |
---|
103 | (stash && isa_lookup(stash, name, strlen(name), 0) == &sv_yes) |
---|
104 | ? TRUE |
---|
105 | : FALSE ; |
---|
106 | |
---|
107 | } |
---|
108 | |
---|
109 | |
---|
110 | static |
---|
111 | XS(XS_UNIVERSAL_isa) |
---|
112 | { |
---|
113 | dXSARGS; |
---|
114 | SV *sv; |
---|
115 | char *name; |
---|
116 | |
---|
117 | if (items != 2) |
---|
118 | croak("Usage: UNIVERSAL::isa(reference, kind)"); |
---|
119 | |
---|
120 | sv = ST(0); |
---|
121 | name = (char *)SvPV(ST(1),na); |
---|
122 | |
---|
123 | ST(0) = boolSV(sv_derived_from(sv, name)); |
---|
124 | XSRETURN(1); |
---|
125 | } |
---|
126 | |
---|
127 | static |
---|
128 | XS(XS_UNIVERSAL_can) |
---|
129 | { |
---|
130 | dXSARGS; |
---|
131 | SV *sv; |
---|
132 | char *name; |
---|
133 | SV *rv; |
---|
134 | HV *pkg = NULL; |
---|
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)) { |
---|
144 | sv = (SV*)SvRV(sv); |
---|
145 | if(SvOBJECT(sv)) |
---|
146 | pkg = SvSTASH(sv); |
---|
147 | } |
---|
148 | else { |
---|
149 | pkg = gv_stashsv(sv, FALSE); |
---|
150 | } |
---|
151 | |
---|
152 | if (pkg) { |
---|
153 | GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); |
---|
154 | if (gv && isGV(gv)) |
---|
155 | rv = sv_2mortal(newRV((SV*)GvCV(gv))); |
---|
156 | } |
---|
157 | |
---|
158 | ST(0) = rv; |
---|
159 | XSRETURN(1); |
---|
160 | } |
---|
161 | |
---|
162 | static |
---|
163 | XS(XS_UNIVERSAL_VERSION) |
---|
164 | { |
---|
165 | dXSARGS; |
---|
166 | HV *pkg; |
---|
167 | GV **gvp; |
---|
168 | GV *gv; |
---|
169 | SV *sv; |
---|
170 | char *undef; |
---|
171 | double req; |
---|
172 | |
---|
173 | if(SvROK(ST(0))) { |
---|
174 | sv = (SV*)SvRV(ST(0)); |
---|
175 | if(!SvOBJECT(sv)) |
---|
176 | croak("Cannot find version of an unblessed reference"); |
---|
177 | pkg = SvSTASH(sv); |
---|
178 | } |
---|
179 | else { |
---|
180 | pkg = gv_stashsv(ST(0), FALSE); |
---|
181 | } |
---|
182 | |
---|
183 | gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**); |
---|
184 | |
---|
185 | if (gvp && (gv = *gvp) != (GV*)&sv_undef && (sv = GvSV(gv))) { |
---|
186 | SV *nsv = sv_newmortal(); |
---|
187 | sv_setsv(nsv, sv); |
---|
188 | sv = nsv; |
---|
189 | undef = Nullch; |
---|
190 | } |
---|
191 | else { |
---|
192 | sv = (SV*)&sv_undef; |
---|
193 | undef = "(undef)"; |
---|
194 | } |
---|
195 | |
---|
196 | if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) |
---|
197 | croak("%s version %s required--this is only version %s", |
---|
198 | HvNAME(pkg), SvPV(ST(1),na), undef ? undef : SvPV(sv,na)); |
---|
199 | |
---|
200 | ST(0) = sv; |
---|
201 | |
---|
202 | XSRETURN(1); |
---|
203 | } |
---|
204 | |
---|
205 | void |
---|
206 | boot_core_UNIVERSAL() |
---|
207 | { |
---|
208 | char *file = __FILE__; |
---|
209 | |
---|
210 | newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); |
---|
211 | newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); |
---|
212 | newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); |
---|
213 | } |
---|