Commit | Line | Data |
6d4a7be2 |
1 | #include "EXTERN.h" |
2 | #include "perl.h" |
6d4a7be2 |
3 | |
4 | /* |
5 | * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com> |
6 | * The main guts of traverse_isa was actually copied from gv_fetchmeth |
7 | */ |
8 | |
76e3520e |
9 | STATIC SV * |
08105a92 |
10 | isa_lookup(HV *stash, const char *name, int len, int level) |
6d4a7be2 |
11 | { |
12 | AV* av; |
13 | GV* gv; |
14 | GV** gvp; |
15 | HV* hv = Nullhv; |
16 | |
17 | if (!stash) |
3280af22 |
18 | return &PL_sv_undef; |
6d4a7be2 |
19 | |
20 | if(strEQ(HvNAME(stash), name)) |
3280af22 |
21 | return &PL_sv_yes; |
6d4a7be2 |
22 | |
23 | if (level > 100) |
3e0ccd42 |
24 | croak("Recursive inheritance detected in package '%s'", HvNAME(stash)); |
6d4a7be2 |
25 | |
26 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE); |
27 | |
3280af22 |
28 | if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (hv = GvHV(gv))) { |
6d4a7be2 |
29 | SV* sv; |
30 | SV** svp = (SV**)hv_fetch(hv, name, len, FALSE); |
3280af22 |
31 | if (svp && (sv = *svp) != (SV*)&PL_sv_undef) |
6d4a7be2 |
32 | return sv; |
33 | } |
34 | |
35 | gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE); |
36 | |
3280af22 |
37 | if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { |
6d4a7be2 |
38 | if(!hv) { |
39 | gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE); |
40 | |
41 | gv = *gvp; |
42 | |
43 | if (SvTYPE(gv) != SVt_PVGV) |
44 | gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); |
45 | |
46 | hv = GvHVn(gv); |
47 | } |
48 | if(hv) { |
49 | SV** svp = AvARRAY(av); |
93965878 |
50 | /* NOTE: No support for tied ISA */ |
51 | I32 items = AvFILLp(av) + 1; |
6d4a7be2 |
52 | while (items--) { |
53 | SV* sv = *svp++; |
54 | HV* basestash = gv_stashsv(sv, FALSE); |
55 | if (!basestash) { |
d008e5eb |
56 | dTHR; |
599cee73 |
57 | if (ckWARN(WARN_MISC)) |
58 | warner(WARN_SYNTAX, |
59 | "Can't locate package %s for @%s::ISA", |
6d4a7be2 |
60 | SvPVX(sv), HvNAME(stash)); |
61 | continue; |
62 | } |
3280af22 |
63 | if(&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) { |
64 | (void)hv_store(hv,name,len,&PL_sv_yes,0); |
65 | return &PL_sv_yes; |
6d4a7be2 |
66 | } |
67 | } |
3280af22 |
68 | (void)hv_store(hv,name,len,&PL_sv_no,0); |
6d4a7be2 |
69 | } |
70 | } |
71 | |
e09f3e01 |
72 | return boolSV(strEQ(name, "UNIVERSAL")); |
6d4a7be2 |
73 | } |
74 | |
55497cff |
75 | bool |
08105a92 |
76 | sv_derived_from(SV *sv, const char *name) |
55497cff |
77 | { |
78 | SV *rv; |
79 | char *type; |
80 | HV *stash; |
81 | |
82 | stash = Nullhv; |
83 | type = Nullch; |
84 | |
85 | if (SvGMAGICAL(sv)) |
86 | mg_get(sv) ; |
87 | |
88 | if (SvROK(sv)) { |
89 | sv = SvRV(sv); |
90 | type = sv_reftype(sv,0); |
91 | if(SvOBJECT(sv)) |
92 | stash = SvSTASH(sv); |
93 | } |
94 | else { |
95 | stash = gv_stashsv(sv, FALSE); |
96 | } |
97 | |
98 | return (type && strEQ(type,name)) || |
3280af22 |
99 | (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes) |
55497cff |
100 | ? TRUE |
101 | : FALSE ; |
102 | |
103 | } |
104 | |
565764a8 |
105 | #ifdef PERL_OBJECT |
106 | #define NO_XSLOCKS |
107 | #endif /* PERL_OBJECT */ |
108 | |
76e3520e |
109 | #include "XSUB.h" |
55497cff |
110 | |
6d4a7be2 |
111 | XS(XS_UNIVERSAL_isa) |
112 | { |
113 | dXSARGS; |
55497cff |
114 | SV *sv; |
115 | char *name; |
2d8e6c8d |
116 | STRLEN n_a; |
6d4a7be2 |
117 | |
118 | if (items != 2) |
119 | croak("Usage: UNIVERSAL::isa(reference, kind)"); |
120 | |
121 | sv = ST(0); |
2d8e6c8d |
122 | name = (char *)SvPV(ST(1),n_a); |
6d4a7be2 |
123 | |
54310121 |
124 | ST(0) = boolSV(sv_derived_from(sv, name)); |
6d4a7be2 |
125 | XSRETURN(1); |
126 | } |
127 | |
6d4a7be2 |
128 | XS(XS_UNIVERSAL_can) |
129 | { |
130 | dXSARGS; |
131 | SV *sv; |
132 | char *name; |
133 | SV *rv; |
6f08146e |
134 | HV *pkg = NULL; |
2d8e6c8d |
135 | STRLEN n_a; |
6d4a7be2 |
136 | |
137 | if (items != 2) |
138 | croak("Usage: UNIVERSAL::can(object-ref, method)"); |
139 | |
140 | sv = ST(0); |
2d8e6c8d |
141 | name = (char *)SvPV(ST(1),n_a); |
3280af22 |
142 | rv = &PL_sv_undef; |
6d4a7be2 |
143 | |
6f08146e |
144 | if(SvROK(sv)) { |
145 | sv = (SV*)SvRV(sv); |
146 | if(SvOBJECT(sv)) |
147 | pkg = SvSTASH(sv); |
148 | } |
149 | else { |
150 | pkg = gv_stashsv(sv, FALSE); |
151 | } |
152 | |
153 | if (pkg) { |
dc848c6f |
154 | GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE); |
155 | if (gv && isGV(gv)) |
156 | rv = sv_2mortal(newRV((SV*)GvCV(gv))); |
6d4a7be2 |
157 | } |
158 | |
159 | ST(0) = rv; |
160 | XSRETURN(1); |
161 | } |
162 | |
6d4a7be2 |
163 | XS(XS_UNIVERSAL_VERSION) |
164 | { |
165 | dXSARGS; |
166 | HV *pkg; |
167 | GV **gvp; |
168 | GV *gv; |
169 | SV *sv; |
170 | char *undef; |
13826f2c |
171 | double req; |
6d4a7be2 |
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 | |
3280af22 |
185 | if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (sv = GvSV(gv))) { |
6d4a7be2 |
186 | SV *nsv = sv_newmortal(); |
187 | sv_setsv(nsv, sv); |
188 | sv = nsv; |
189 | undef = Nullch; |
190 | } |
191 | else { |
3280af22 |
192 | sv = (SV*)&PL_sv_undef; |
6d4a7be2 |
193 | undef = "(undef)"; |
194 | } |
195 | |
2d8e6c8d |
196 | if (items > 1 && (undef || (req = SvNV(ST(1)), req > SvNV(sv)))) { |
197 | STRLEN n_a; |
6d4a7be2 |
198 | croak("%s version %s required--this is only version %s", |
2d8e6c8d |
199 | HvNAME(pkg), SvPV(ST(1),n_a), undef ? undef : SvPV(sv,n_a)); |
200 | } |
6d4a7be2 |
201 | |
202 | ST(0) = sv; |
203 | |
204 | XSRETURN(1); |
205 | } |
206 | |
76e3520e |
207 | #ifdef PERL_OBJECT |
208 | #undef boot_core_UNIVERSAL |
209 | #define boot_core_UNIVERSAL CPerlObj::Perl_boot_core_UNIVERSAL |
210 | #define pPerl this |
211 | #endif |
212 | |
6d4a7be2 |
213 | void |
8ac85365 |
214 | boot_core_UNIVERSAL(void) |
6d4a7be2 |
215 | { |
216 | char *file = __FILE__; |
217 | |
218 | newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); |
219 | newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); |
6d4a7be2 |
220 | newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); |
221 | } |