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