This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: eval not catching warnings?
[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;
46e4b22b 17 SV* subgen = Nullsv;
6d4a7be2
PP
18
19 if (!stash)
3280af22 20 return &PL_sv_undef;
6d4a7be2 21
46e4b22b 22 if (strEQ(HvNAME(stash), name))
3280af22 23 return &PL_sv_yes;
6d4a7be2
PP
24
25 if (level > 100)
46e4b22b
GS
26 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
27 HvNAME(stash));
6d4a7be2
PP
28
29 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
30
46e4b22b
GS
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 }
6d4a7be2
PP
49 }
50
51 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b 52
3280af22 53 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b 54 if (!hv || !subgen) {
6d4a7be2
PP
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
46e4b22b
GS
62 if (!hv)
63 hv = GvHVn(gv);
64 if (!subgen) {
65 subgen = newSViv(PL_sub_generation);
66 GvSV(gv) = subgen;
67 }
6d4a7be2 68 }
46e4b22b 69 if (hv) {
6d4a7be2 70 SV** svp = AvARRAY(av);
93965878
NIS
71 /* NOTE: No support for tied ISA */
72 I32 items = AvFILLp(av) + 1;
6d4a7be2
PP
73 while (items--) {
74 SV* sv = *svp++;
75 HV* basestash = gv_stashsv(sv, FALSE);
76 if (!basestash) {
599cee73 77 if (ckWARN(WARN_MISC))
cea2e8a9 78 Perl_warner(aTHX_ WARN_SYNTAX,
599cee73 79 "Can't locate package %s for @%s::ISA",
6d4a7be2
PP
80 SvPVX(sv), HvNAME(stash));
81 continue;
82 }
46e4b22b 83 if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
3280af22
NIS
84 (void)hv_store(hv,name,len,&PL_sv_yes,0);
85 return &PL_sv_yes;
6d4a7be2
PP
86 }
87 }
3280af22 88 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2
PP
89 }
90 }
91
e09f3e01 92 return boolSV(strEQ(name, "UNIVERSAL"));
6d4a7be2
PP
93}
94
954c1994 95/*
ccfc67b7
JH
96=head1 SV Manipulation Functions
97
954c1994
GS
98=for apidoc sv_derived_from
99
100Returns a boolean indicating whether the SV is derived from the specified
101class. This is the function that implements C<UNIVERSAL::isa>. It works
102for class names as well as for objects.
103
104=cut
105*/
106
55497cff 107bool
864dbfa3 108Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
55497cff 109{
55497cff
PP
110 char *type;
111 HV *stash;
46e4b22b 112
55497cff
PP
113 stash = Nullhv;
114 type = Nullch;
46e4b22b 115
55497cff
PP
116 if (SvGMAGICAL(sv))
117 mg_get(sv) ;
118
119 if (SvROK(sv)) {
120 sv = SvRV(sv);
121 type = sv_reftype(sv,0);
46e4b22b 122 if (SvOBJECT(sv))
55497cff
PP
123 stash = SvSTASH(sv);
124 }
125 else {
126 stash = gv_stashsv(sv, FALSE);
127 }
46e4b22b 128
55497cff 129 return (type && strEQ(type,name)) ||
3280af22 130 (stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
55497cff
PP
131 ? TRUE
132 : FALSE ;
55497cff
PP
133}
134
1b026014
NIS
135#include "XSUB.h"
136
acfe0abc
GS
137void XS_UNIVERSAL_isa(pTHX_ CV *cv);
138void XS_UNIVERSAL_can(pTHX_ CV *cv);
139void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
1b026014
NIS
140XS(XS_utf8_valid);
141XS(XS_utf8_encode);
142XS(XS_utf8_decode);
143XS(XS_utf8_upgrade);
144XS(XS_utf8_downgrade);
145XS(XS_utf8_unicode_to_native);
146XS(XS_utf8_native_to_unicode);
1b1f1335 147XS(XS_access_readonly);
0cb96387
GS
148
149void
150Perl_boot_core_UNIVERSAL(pTHX)
151{
152 char *file = __FILE__;
153
154 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
155 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
156 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
1b026014
NIS
157 newXS("utf8::valid", XS_utf8_valid, file);
158 newXS("utf8::encode", XS_utf8_encode, file);
159 newXS("utf8::decode", XS_utf8_decode, file);
160 newXS("utf8::upgrade", XS_utf8_upgrade, file);
161 newXS("utf8::downgrade", XS_utf8_downgrade, file);
162 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
163 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
1b1f1335 164 newXSproto("access::readonly",XS_access_readonly, file, "\\[$%@];$");
0cb96387
GS
165}
166
55497cff 167
6d4a7be2
PP
168XS(XS_UNIVERSAL_isa)
169{
170 dXSARGS;
55497cff
PP
171 SV *sv;
172 char *name;
2d8e6c8d 173 STRLEN n_a;
6d4a7be2
PP
174
175 if (items != 2)
cea2e8a9 176 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2
PP
177
178 sv = ST(0);
f8f70380 179
d3f7f2b2
GS
180 if (SvGMAGICAL(sv))
181 mg_get(sv);
182
aca069ec 183 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
f8f70380
GS
184 XSRETURN_UNDEF;
185
2d8e6c8d 186 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 187
54310121 188 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2
PP
189 XSRETURN(1);
190}
191
6d4a7be2
PP
192XS(XS_UNIVERSAL_can)
193{
194 dXSARGS;
195 SV *sv;
196 char *name;
197 SV *rv;
6f08146e 198 HV *pkg = NULL;
2d8e6c8d 199 STRLEN n_a;
6d4a7be2
PP
200
201 if (items != 2)
cea2e8a9 202 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
203
204 sv = ST(0);
f8f70380 205
d3f7f2b2
GS
206 if (SvGMAGICAL(sv))
207 mg_get(sv);
208
aca069ec 209 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
f8f70380
GS
210 XSRETURN_UNDEF;
211
2d8e6c8d 212 name = (char *)SvPV(ST(1),n_a);
3280af22 213 rv = &PL_sv_undef;
6d4a7be2 214
46e4b22b 215 if (SvROK(sv)) {
6f08146e 216 sv = (SV*)SvRV(sv);
46e4b22b 217 if (SvOBJECT(sv))
6f08146e
NIS
218 pkg = SvSTASH(sv);
219 }
220 else {
221 pkg = gv_stashsv(sv, FALSE);
222 }
223
224 if (pkg) {
dc848c6f
PP
225 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
226 if (gv && isGV(gv))
227 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
228 }
229
230 ST(0) = rv;
231 XSRETURN(1);
232}
233
6d4a7be2
PP
234XS(XS_UNIVERSAL_VERSION)
235{
236 dXSARGS;
237 HV *pkg;
238 GV **gvp;
239 GV *gv;
240 SV *sv;
241 char *undef;
242
1571675a 243 if (SvROK(ST(0))) {
6d4a7be2 244 sv = (SV*)SvRV(ST(0));
1571675a 245 if (!SvOBJECT(sv))
cea2e8a9 246 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
247 pkg = SvSTASH(sv);
248 }
249 else {
250 pkg = gv_stashsv(ST(0), FALSE);
251 }
252
253 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
254
d4bea2fb 255 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2
PP
256 SV *nsv = sv_newmortal();
257 sv_setsv(nsv, sv);
258 sv = nsv;
259 undef = Nullch;
260 }
261 else {
3280af22 262 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
263 undef = "(undef)";
264 }
265
1571675a
GS
266 if (items > 1) {
267 STRLEN len;
268 SV *req = ST(1);
269
270 if (undef)
271 Perl_croak(aTHX_ "%s does not define $%s::VERSION--version check failed",
272 HvNAME(pkg), HvNAME(pkg));
273
274 if (!SvNIOK(sv) && SvPOK(sv)) {
275 char *str = SvPVx(sv,len);
276 while (len) {
277 --len;
278 /* XXX could DWIM "1.2.3" here */
279 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
280 break;
281 }
282 if (len) {
4305d8ab 283 if (SvNOK(req) && SvPOK(req)) {
1571675a
GS
284 /* they said C<use Foo v1.2.3> and $Foo::VERSION
285 * doesn't look like a float: do string compare */
286 if (sv_cmp(req,sv) == 1) {
d2560b70
RB
287 Perl_croak(aTHX_ "%s v%"VDf" required--"
288 "this is only v%"VDf,
1571675a
GS
289 HvNAME(pkg), req, sv);
290 }
291 goto finish;
292 }
293 /* they said C<use Foo 1.002_003> and $Foo::VERSION
294 * doesn't look like a float: force numeric compare */
155aba94 295 (void)SvUPGRADE(sv, SVt_PVNV);
1571675a
GS
296 SvNVX(sv) = str_to_version(sv);
297 SvPOK_off(sv);
298 SvNOK_on(sv);
299 }
300 }
301 /* if we get here, we're looking for a numeric comparison,
302 * so force the required version into a float, even if they
303 * said C<use Foo v1.2.3> */
4305d8ab 304 if (SvNOK(req) && SvPOK(req)) {
1571675a
GS
305 NV n = SvNV(req);
306 req = sv_newmortal();
307 sv_setnv(req, n);
308 }
309
f6eb1a96 310 if (SvNV(req) > SvNV(sv))
1571675a 311 Perl_croak(aTHX_ "%s version %s required--this is only version %s",
f6eb1a96 312 HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
2d8e6c8d 313 }
6d4a7be2 314
1571675a 315finish:
6d4a7be2
PP
316 ST(0) = sv;
317
318 XSRETURN(1);
319}
320
1b026014
NIS
321XS(XS_utf8_valid)
322{
323 dXSARGS;
324 if (items != 1)
325 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
326 {
327 SV * sv = ST(0);
328 {
329 STRLEN len;
330 char *s = SvPV(sv,len);
331 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
332 XSRETURN_YES;
333 else
334 XSRETURN_NO;
335 }
336 }
337 XSRETURN_EMPTY;
338}
339
340XS(XS_utf8_encode)
341{
342 dXSARGS;
343 if (items != 1)
344 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
345 {
346 SV * sv = ST(0);
347
348 sv_utf8_encode(sv);
349 }
350 XSRETURN_EMPTY;
351}
352
353XS(XS_utf8_decode)
354{
355 dXSARGS;
356 if (items != 1)
357 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
358 {
359 SV * sv = ST(0);
360 bool RETVAL;
361
362 RETVAL = sv_utf8_decode(sv);
363 ST(0) = boolSV(RETVAL);
364 sv_2mortal(ST(0));
365 }
366 XSRETURN(1);
367}
368
369XS(XS_utf8_upgrade)
370{
371 dXSARGS;
372 if (items != 1)
373 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
374 {
375 SV * sv = ST(0);
376 STRLEN RETVAL;
377 dXSTARG;
378
379 RETVAL = sv_utf8_upgrade(sv);
380 XSprePUSH; PUSHi((IV)RETVAL);
381 }
382 XSRETURN(1);
383}
384
385XS(XS_utf8_downgrade)
386{
387 dXSARGS;
388 if (items < 1 || items > 2)
389 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
390 {
391 SV * sv = ST(0);
392 bool failok;
393 bool RETVAL;
394
395 if (items < 2)
396 failok = 0;
397 else {
398 failok = (int)SvIV(ST(1));
399 }
400
401 RETVAL = sv_utf8_downgrade(sv, failok);
402 ST(0) = boolSV(RETVAL);
403 sv_2mortal(ST(0));
404 }
405 XSRETURN(1);
406}
407
408XS(XS_utf8_native_to_unicode)
409{
410 dXSARGS;
411 UV uv = SvUV(ST(0));
b7953727
JH
412
413 if (items > 1)
414 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
415
1b026014
NIS
416 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
417 XSRETURN(1);
418}
419
420XS(XS_utf8_unicode_to_native)
421{
422 dXSARGS;
423 UV uv = SvUV(ST(0));
b7953727
JH
424
425 if (items > 1)
426 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
427
1b026014
NIS
428 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
429 XSRETURN(1);
430}
431
1b1f1335
NIS
432XS(XS_access_readonly)
433{
434 dXSARGS;
435 SV *sv = SvRV(ST(0));
436 IV old = SvREADONLY(sv);
437 if (items == 2) {
438 if (SvTRUE(ST(1))) {
439 SvREADONLY_on(sv);
440 }
441 else {
442 SvREADONLY_off(sv);
443 }
444 }
445 if (old)
446 XSRETURN_YES;
447 else
448 XSRETURN_NO;
449}
1b026014 450