This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Version object patch #1
[perl5.git] / universal.c
CommitLineData
d6376244
JH
1/* universal.c
2 *
3 * Copyright (c) 1997-2002, Larry Wall
4 *
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
7 *
8 */
9
d31a8517
AT
10/*
11 * "The roots of those mountains must be roots indeed; there must be
12 * great secrets buried there which have not been discovered since the
13 * beginning." --Gandalf, relating Gollum's story
14 */
15
6d4a7be2 16#include "EXTERN.h"
864dbfa3 17#define PERL_IN_UNIVERSAL_C
6d4a7be2 18#include "perl.h"
6d4a7be2
PP
19
20/*
21 * Contributed by Graham Barr <Graham.Barr@tiuk.ti.com>
22 * The main guts of traverse_isa was actually copied from gv_fetchmeth
23 */
24
76e3520e 25STATIC SV *
301daebc
MS
26S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash,
27 int len, int level)
6d4a7be2
PP
28{
29 AV* av;
30 GV* gv;
31 GV** gvp;
32 HV* hv = Nullhv;
46e4b22b 33 SV* subgen = Nullsv;
6d4a7be2 34
301daebc
MS
35 /* A stash/class can go by many names (ie. User == main::User), so
36 we compare the stash itself just in case */
37 if (name_stash && (stash == name_stash))
38 return &PL_sv_yes;
6d4a7be2 39
46e4b22b 40 if (strEQ(HvNAME(stash), name))
3280af22 41 return &PL_sv_yes;
6d4a7be2
PP
42
43 if (level > 100)
46e4b22b
GS
44 Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
45 HvNAME(stash));
6d4a7be2
PP
46
47 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
48
46e4b22b
GS
49 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
50 && (hv = GvHV(gv)))
51 {
eb160463 52 if (SvIV(subgen) == (IV)PL_sub_generation) {
46e4b22b
GS
53 SV* sv;
54 SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
55 if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
56 DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
57 name, HvNAME(stash)) );
58 return sv;
59 }
60 }
61 else {
62 DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
63 HvNAME(stash)) );
64 hv_clear(hv);
65 sv_setiv(subgen, PL_sub_generation);
66 }
6d4a7be2
PP
67 }
68
69 gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
46e4b22b 70
3280af22 71 if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
46e4b22b 72 if (!hv || !subgen) {
6d4a7be2
PP
73 gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
74
75 gv = *gvp;
76
77 if (SvTYPE(gv) != SVt_PVGV)
78 gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
79
46e4b22b
GS
80 if (!hv)
81 hv = GvHVn(gv);
82 if (!subgen) {
83 subgen = newSViv(PL_sub_generation);
84 GvSV(gv) = subgen;
85 }
6d4a7be2 86 }
46e4b22b 87 if (hv) {
6d4a7be2 88 SV** svp = AvARRAY(av);
93965878
NIS
89 /* NOTE: No support for tied ISA */
90 I32 items = AvFILLp(av) + 1;
6d4a7be2
PP
91 while (items--) {
92 SV* sv = *svp++;
93 HV* basestash = gv_stashsv(sv, FALSE);
94 if (!basestash) {
599cee73 95 if (ckWARN(WARN_MISC))
9014280d 96 Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
599cee73 97 "Can't locate package %s for @%s::ISA",
6d4a7be2
PP
98 SvPVX(sv), HvNAME(stash));
99 continue;
100 }
301daebc
MS
101 if (&PL_sv_yes == isa_lookup(basestash, name, name_stash,
102 len, level + 1)) {
3280af22
NIS
103 (void)hv_store(hv,name,len,&PL_sv_yes,0);
104 return &PL_sv_yes;
6d4a7be2
PP
105 }
106 }
3280af22 107 (void)hv_store(hv,name,len,&PL_sv_no,0);
6d4a7be2
PP
108 }
109 }
110
e09f3e01 111 return boolSV(strEQ(name, "UNIVERSAL"));
6d4a7be2
PP
112}
113
954c1994 114/*
ccfc67b7
JH
115=head1 SV Manipulation Functions
116
954c1994
GS
117=for apidoc sv_derived_from
118
119Returns a boolean indicating whether the SV is derived from the specified
120class. This is the function that implements C<UNIVERSAL::isa>. It works
121for class names as well as for objects.
122
123=cut
124*/
125
55497cff 126bool
864dbfa3 127Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
55497cff 128{
55497cff
PP
129 char *type;
130 HV *stash;
301daebc 131 HV *name_stash;
46e4b22b 132
55497cff
PP
133 stash = Nullhv;
134 type = Nullch;
46e4b22b 135
55497cff
PP
136 if (SvGMAGICAL(sv))
137 mg_get(sv) ;
138
139 if (SvROK(sv)) {
140 sv = SvRV(sv);
141 type = sv_reftype(sv,0);
46e4b22b 142 if (SvOBJECT(sv))
55497cff
PP
143 stash = SvSTASH(sv);
144 }
145 else {
146 stash = gv_stashsv(sv, FALSE);
147 }
46e4b22b 148
301daebc
MS
149 name_stash = gv_stashpv(name, FALSE);
150
55497cff 151 return (type && strEQ(type,name)) ||
301daebc
MS
152 (stash && isa_lookup(stash, name, name_stash, strlen(name), 0)
153 == &PL_sv_yes)
55497cff
PP
154 ? TRUE
155 : FALSE ;
55497cff
PP
156}
157
1b026014
NIS
158#include "XSUB.h"
159
acfe0abc
GS
160void XS_UNIVERSAL_isa(pTHX_ CV *cv);
161void XS_UNIVERSAL_can(pTHX_ CV *cv);
162void XS_UNIVERSAL_VERSION(pTHX_ CV *cv);
1b026014
NIS
163XS(XS_utf8_valid);
164XS(XS_utf8_encode);
165XS(XS_utf8_decode);
166XS(XS_utf8_upgrade);
167XS(XS_utf8_downgrade);
168XS(XS_utf8_unicode_to_native);
169XS(XS_utf8_native_to_unicode);
29569577
JH
170XS(XS_Internals_SvREADONLY);
171XS(XS_Internals_SvREFCNT);
f044d0d1 172XS(XS_Internals_hv_clear_placehold);
0cb96387
GS
173
174void
175Perl_boot_core_UNIVERSAL(pTHX)
176{
177 char *file = __FILE__;
178
179 newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file);
180 newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file);
181 newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file);
1b026014
NIS
182 newXS("utf8::valid", XS_utf8_valid, file);
183 newXS("utf8::encode", XS_utf8_encode, file);
184 newXS("utf8::decode", XS_utf8_decode, file);
185 newXS("utf8::upgrade", XS_utf8_upgrade, file);
186 newXS("utf8::downgrade", XS_utf8_downgrade, file);
187 newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file);
188 newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file);
29569577
JH
189 newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$");
190 newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$");
dfd4ef2f 191 newXSproto("Internals::hv_clear_placeholders",
f044d0d1 192 XS_Internals_hv_clear_placehold, file, "\\%");
0cb96387
GS
193}
194
55497cff 195
6d4a7be2
PP
196XS(XS_UNIVERSAL_isa)
197{
198 dXSARGS;
55497cff
PP
199 SV *sv;
200 char *name;
2d8e6c8d 201 STRLEN n_a;
6d4a7be2
PP
202
203 if (items != 2)
cea2e8a9 204 Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
6d4a7be2
PP
205
206 sv = ST(0);
f8f70380 207
d3f7f2b2
GS
208 if (SvGMAGICAL(sv))
209 mg_get(sv);
210
aca069ec 211 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
f8f70380
GS
212 XSRETURN_UNDEF;
213
2d8e6c8d 214 name = (char *)SvPV(ST(1),n_a);
6d4a7be2 215
54310121 216 ST(0) = boolSV(sv_derived_from(sv, name));
6d4a7be2
PP
217 XSRETURN(1);
218}
219
6d4a7be2
PP
220XS(XS_UNIVERSAL_can)
221{
222 dXSARGS;
223 SV *sv;
224 char *name;
225 SV *rv;
6f08146e 226 HV *pkg = NULL;
2d8e6c8d 227 STRLEN n_a;
6d4a7be2
PP
228
229 if (items != 2)
cea2e8a9 230 Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
6d4a7be2
PP
231
232 sv = ST(0);
f8f70380 233
d3f7f2b2
GS
234 if (SvGMAGICAL(sv))
235 mg_get(sv);
236
aca069ec 237 if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv))))
f8f70380
GS
238 XSRETURN_UNDEF;
239
2d8e6c8d 240 name = (char *)SvPV(ST(1),n_a);
3280af22 241 rv = &PL_sv_undef;
6d4a7be2 242
46e4b22b 243 if (SvROK(sv)) {
6f08146e 244 sv = (SV*)SvRV(sv);
46e4b22b 245 if (SvOBJECT(sv))
6f08146e
NIS
246 pkg = SvSTASH(sv);
247 }
248 else {
249 pkg = gv_stashsv(sv, FALSE);
250 }
251
252 if (pkg) {
dc848c6f
PP
253 GV *gv = gv_fetchmethod_autoload(pkg, name, FALSE);
254 if (gv && isGV(gv))
255 rv = sv_2mortal(newRV((SV*)GvCV(gv)));
6d4a7be2
PP
256 }
257
258 ST(0) = rv;
259 XSRETURN(1);
260}
261
6d4a7be2
PP
262XS(XS_UNIVERSAL_VERSION)
263{
264 dXSARGS;
265 HV *pkg;
266 GV **gvp;
267 GV *gv;
268 SV *sv;
269 char *undef;
270
1571675a 271 if (SvROK(ST(0))) {
6d4a7be2 272 sv = (SV*)SvRV(ST(0));
1571675a 273 if (!SvOBJECT(sv))
cea2e8a9 274 Perl_croak(aTHX_ "Cannot find version of an unblessed reference");
6d4a7be2
PP
275 pkg = SvSTASH(sv);
276 }
277 else {
278 pkg = gv_stashsv(ST(0), FALSE);
279 }
280
281 gvp = pkg ? (GV**)hv_fetch(pkg,"VERSION",7,FALSE) : Null(GV**);
282
d4bea2fb 283 if (gvp && isGV(gv = *gvp) && SvOK(sv = GvSV(gv))) {
6d4a7be2
PP
284 SV *nsv = sv_newmortal();
285 sv_setsv(nsv, sv);
286 sv = nsv;
287 undef = Nullch;
288 }
289 else {
3280af22 290 sv = (SV*)&PL_sv_undef;
6d4a7be2
PP
291 undef = "(undef)";
292 }
293
1571675a
GS
294 if (items > 1) {
295 STRLEN len;
296 SV *req = ST(1);
297
62658f4d
PM
298 if (undef) {
299 if (pkg)
300 Perl_croak(aTHX_
301 "%s does not define $%s::VERSION--version check failed",
302 HvNAME(pkg), HvNAME(pkg));
303 else {
304 char *str = SvPVx(ST(0), len);
305
306 Perl_croak(aTHX_
307 "%s defines neither package nor VERSION--version check failed", str);
308 }
309 }
1571675a
GS
310 if (!SvNIOK(sv) && SvPOK(sv)) {
311 char *str = SvPVx(sv,len);
312 while (len) {
313 --len;
314 /* XXX could DWIM "1.2.3" here */
315 if (!isDIGIT(str[len]) && str[len] != '.' && str[len] != '_')
316 break;
317 }
318 if (len) {
4305d8ab 319 if (SvNOK(req) && SvPOK(req)) {
1571675a
GS
320 /* they said C<use Foo v1.2.3> and $Foo::VERSION
321 * doesn't look like a float: do string compare */
322 if (sv_cmp(req,sv) == 1) {
d2560b70
RB
323 Perl_croak(aTHX_ "%s v%"VDf" required--"
324 "this is only v%"VDf,
1571675a
GS
325 HvNAME(pkg), req, sv);
326 }
327 goto finish;
328 }
329 /* they said C<use Foo 1.002_003> and $Foo::VERSION
330 * doesn't look like a float: force numeric compare */
155aba94 331 (void)SvUPGRADE(sv, SVt_PVNV);
1571675a
GS
332 SvNVX(sv) = str_to_version(sv);
333 SvPOK_off(sv);
334 SvNOK_on(sv);
335 }
336 }
337 /* if we get here, we're looking for a numeric comparison,
338 * so force the required version into a float, even if they
339 * said C<use Foo v1.2.3> */
4305d8ab 340 if (SvNOK(req) && SvPOK(req)) {
1571675a
GS
341 NV n = SvNV(req);
342 req = sv_newmortal();
343 sv_setnv(req, n);
344 }
345
f6eb1a96 346 if (SvNV(req) > SvNV(sv))
1571675a 347 Perl_croak(aTHX_ "%s version %s required--this is only version %s",
f6eb1a96 348 HvNAME(pkg), SvPV_nolen(req), SvPV_nolen(sv));
2d8e6c8d 349 }
6d4a7be2 350
1571675a 351finish:
6d4a7be2
PP
352 ST(0) = sv;
353
354 XSRETURN(1);
355}
356
1b026014
NIS
357XS(XS_utf8_valid)
358{
359 dXSARGS;
360 if (items != 1)
361 Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
362 {
363 SV * sv = ST(0);
364 {
365 STRLEN len;
366 char *s = SvPV(sv,len);
367 if (!SvUTF8(sv) || is_utf8_string((U8*)s,len))
368 XSRETURN_YES;
369 else
370 XSRETURN_NO;
371 }
372 }
373 XSRETURN_EMPTY;
374}
375
376XS(XS_utf8_encode)
377{
378 dXSARGS;
379 if (items != 1)
380 Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
381 {
382 SV * sv = ST(0);
383
384 sv_utf8_encode(sv);
385 }
386 XSRETURN_EMPTY;
387}
388
389XS(XS_utf8_decode)
390{
391 dXSARGS;
392 if (items != 1)
393 Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
394 {
395 SV * sv = ST(0);
396 bool RETVAL;
397
398 RETVAL = sv_utf8_decode(sv);
399 ST(0) = boolSV(RETVAL);
400 sv_2mortal(ST(0));
401 }
402 XSRETURN(1);
403}
404
405XS(XS_utf8_upgrade)
406{
407 dXSARGS;
408 if (items != 1)
409 Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
410 {
411 SV * sv = ST(0);
412 STRLEN RETVAL;
413 dXSTARG;
414
415 RETVAL = sv_utf8_upgrade(sv);
416 XSprePUSH; PUSHi((IV)RETVAL);
417 }
418 XSRETURN(1);
419}
420
421XS(XS_utf8_downgrade)
422{
423 dXSARGS;
424 if (items < 1 || items > 2)
425 Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
426 {
427 SV * sv = ST(0);
428 bool failok;
429 bool RETVAL;
430
431 if (items < 2)
432 failok = 0;
433 else {
434 failok = (int)SvIV(ST(1));
435 }
436
437 RETVAL = sv_utf8_downgrade(sv, failok);
438 ST(0) = boolSV(RETVAL);
439 sv_2mortal(ST(0));
440 }
441 XSRETURN(1);
442}
443
444XS(XS_utf8_native_to_unicode)
445{
446 dXSARGS;
447 UV uv = SvUV(ST(0));
b7953727
JH
448
449 if (items > 1)
450 Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
451
1b026014
NIS
452 ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
453 XSRETURN(1);
454}
455
456XS(XS_utf8_unicode_to_native)
457{
458 dXSARGS;
459 UV uv = SvUV(ST(0));
b7953727
JH
460
461 if (items > 1)
462 Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
463
1b026014
NIS
464 ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
465 XSRETURN(1);
466}
467
14a976d6 468XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */
29569577
JH
469{
470 dXSARGS;
471 SV *sv = SvRV(ST(0));
472 if (items == 1) {
473 if (SvREADONLY(sv))
474 XSRETURN_YES;
475 else
476 XSRETURN_NO;
477 }
478 else if (items == 2) {
479 if (SvTRUE(ST(1))) {
480 SvREADONLY_on(sv);
481 XSRETURN_YES;
482 }
483 else {
14a976d6 484 /* I hope you really know what you are doing. */
29569577
JH
485 SvREADONLY_off(sv);
486 XSRETURN_NO;
487 }
488 }
14a976d6 489 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
490}
491
14a976d6 492XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */
29569577
JH
493{
494 dXSARGS;
495 SV *sv = SvRV(ST(0));
496 if (items == 1)
14a976d6 497 XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
29569577 498 else if (items == 2) {
14a976d6 499 /* I hope you really know what you are doing. */
29569577
JH
500 SvREFCNT(sv) = SvIV(ST(1));
501 XSRETURN_IV(SvREFCNT(sv));
502 }
14a976d6 503 XSRETURN_UNDEF; /* Can't happen. */
29569577
JH
504}
505
dfd4ef2f
NC
506/* Maybe this should return the number of placeholders found in scalar context,
507 and a list of them in list context. */
f044d0d1 508XS(XS_Internals_hv_clear_placehold)
dfd4ef2f
NC
509{
510 dXSARGS;
511 HV *hv = (HV *) SvRV(ST(0));
512
513 /* I don't care how many parameters were passed in, but I want to avoid
514 the unused variable warning. */
515
eb160463 516 items = (I32)HvPLACEHOLDERS(hv);
dfd4ef2f
NC
517
518 if (items) {
519 HE *entry;
520 I32 riter = HvRITER(hv);
521 HE *eiter = HvEITER(hv);
522 hv_iterinit(hv);
fe7bca90
NC
523 /* This may look suboptimal with the items *after* the iternext, but
524 it's quite deliberate. We only get here with items==0 if we've
525 just deleted the last placeholder in the hash. If we've just done
526 that then it means that the hash is in lazy delete mode, and the
527 HE is now only referenced in our iterator. If we just quit the loop
528 and discarded our iterator then the HE leaks. So we do the && the
529 other way to ensure iternext is called just one more time, which
530 has the side effect of triggering the lazy delete. */
531 while ((entry = hv_iternext_flags(hv, HV_ITERNEXT_WANTPLACEHOLDERS))
532 && items) {
dfd4ef2f
NC
533 SV *val = hv_iterval(hv, entry);
534
535 if (val == &PL_sv_undef) {
536
537 /* It seems that I have to go back in the front of the hash
538 API to delete a hash, even though I have a HE structure
539 pointing to the very entry I want to delete, and could hold
540 onto the previous HE that points to it. And it's easier to
541 go in with SVs as I can then specify the precomputed hash,
542 and don't have fun and games with utf8 keys. */
543 SV *key = hv_iterkeysv(entry);
544
545 hv_delete_ent (hv, key, G_DISCARD, HeHASH(entry));
546 items--;
547 }
548 }
549 HvRITER(hv) = riter;
550 HvEITER(hv) = eiter;
551 }
552
553 XSRETURN(0);
554}