/* sv.c
*
- * Copyright (c) 1991-2000, Larry Wall
+ * Copyright (c) 1991-2001, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
void
Perl_sv_setuv(pTHX_ register SV *sv, UV u)
{
+ /* With these two if statements:
+ u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
+
+ without
+ u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
+
+ If you wish to remove them, please benchmark to see what the effect is
+ */
if (u <= (UV)IV_MAX) {
sv_setiv(sv, (IV)u);
return;
void
Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
{
+ /* With these two if statements:
+ u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
+
+ without
+ u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
+
+ If you wish to remove them, please benchmark to see what the effect is
+ */
if (u <= (UV)IV_MAX) {
sv_setiv(sv, (IV)u);
} else {
Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
changes - now IV and NV together means that the two are interchangeable
SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
-
+
The benefit of this is operations such as pp_add know that if SvIOK is
true for both left and right operands, then integer addition can be
used instead of floating point. (for cases where the result won't
S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
if (nv_as_uv <= (UV)IV_MAX) {
(void)SvIOKp_on(sv);
(void)SvNOKp_on(sv);
#else
/* We've just lost integer precision, nothing we could do. */
SvUVX(sv) = nv_as_uv;
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
/* UV and NV slots equally valid only if we have casting symmetry. */
if (numtype & IS_NUMBER_NOT_INT) {
SvIsUV_on(sv);
STATIC int
S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
{
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
SvIsUV_on(sv);
SvUVX(sv) = U_V(SvNVX(sv));
if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
+ if (SvUVX(sv) == UV_MAX) {
+ /* As we know that NVs don't preserve UVs, UV_MAX cannot
+ possibly be preserved by NV. Hence, it must be overflow.
+ NOK, IOKp */
+ return IS_NUMBER_OVERFLOW_UV;
+ }
SvIOK_on(sv); /* Integer is precise. NOK, UOK */
} else {
/* Integer is imprecise. NOK, IOKp */
}
return IS_NUMBER_OVERFLOW_IV;
}
- return S_sv_2inuv_non_preserve (sv, numtype);
+ return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
}
#endif /* NV_PRESERVES_UV*/
-
IV
Perl_sv_2iv(pTHX_ register SV *sv)
{
(NV)UVX == NVX are both true, but the values differ. :-(
Hopefully for 2s complement IV_MIN is something like
0x8000000000000000 which will be exact. NWC */
- }
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
if (
(NV)UVX == NVX are both true, but the values differ. :-(
Hopefully for 2s complement IV_MIN is something like
0x8000000000000000 which will be exact. NWC */
- }
+ }
else {
SvUVX(sv) = U_V(SvNVX(sv));
if (
} else {
#ifdef HAS_STRTOUL
UV u;
+ char *num_begin = SvPVX(sv);
int save_errno = errno;
+
+ /* seems that strtoul taking numbers that start with - is
+ implementation dependant, and can't be relied upon. */
+ if (numtype & IS_NUMBER_NEG) {
+ /* Not totally defensive. assumine that looks_like_num
+ didn't lie about a - sign */
+ while (isSPACE(*num_begin))
+ num_begin++;
+ if (*num_begin == '-')
+ num_begin++;
+ }
+
/* Is it an integer that we could convert with strtoul?
So try it, and if it doesn't set errno then it's pukka.
This should be faster than going atof and then thinking. */
if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
== IS_NUMBER_TO_INT_BY_STRTOL)
&& ((errno = 0), 1) /* always true */
- && ((u = Strtoul(SvPVX(sv), Null(char**), 10)), 1) /* ditto */
+ && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
&& (errno == 0)
- /* If known to be negative, check it didn't undeflow IV */
- && ((numtype & IS_NUMBER_NEG) ? ((IV)u <= 0) : 1)) {
+ /* If known to be negative, check it didn't undeflow IV
+ XXX possibly we should put more negative values as NVs
+ direct rather than go via atof below */
+ && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
errno = save_errno;
if (SvTYPE(sv) < SVt_PVIV)
/* If it's negative must use IV.
IV-over-UV optimisation */
- if (numtype & IS_NUMBER_NEG || u <= (UV) IV_MAX) {
- /* strtoul is defined to return negated value if the
- number starts with a minus sign. Assuming 2s
- complement, this value will be in range for a negative
- IV if casting the bit pattern to IV doesn't produce
- a positive value. Allow -0 by checking it's <= 0
- hence (numtype & IS_NUMBER_NEG) test above
- */
+ if (numtype & IS_NUMBER_NEG) {
+ SvIVX(sv) = -(IV)u;
+ } else if (u <= (UV) IV_MAX) {
SvIVX(sv) = (IV)u;
} else {
/* it didn't overflow, and it was positive. */
* LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
* do this, and vendors have had 11 years to get it right.
* However, will try to make it still work with only atol
- *
+ *
* IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
* IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
* IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
nbegin = s;
/*
- * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
+ * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
* integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
* possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
* will need (int)atof().
e = SvEND(sv);
t = s;
while (t < e) {
- if ((hibit = *t++ & 0x80))
+ if ((hibit = UTF8_IS_CONTINUED(*t++)))
break;
}
return FALSE;
e = SvEND(sv);
while (c < e) {
- if (*c++ & 0x80) {
+ if (UTF8_IS_CONTINUED(*c++)) {
SvUTF8_on(sv);
break;
}
SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
SvROK_on(dstr);
if (sflags & SVp_NOK) {
- SvNOK_on(dstr);
+ SvNOKp_on(dstr);
+ /* Only set the public OK flag if the source has public OK. */
+ if (sflags & SVf_NOK)
+ SvFLAGS(dstr) |= SVf_NOK;
SvNVX(dstr) = SvNVX(sstr);
}
if (sflags & SVp_IOK) {
- (void)SvIOK_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ (void)SvIOKp_on(dstr);
+ if (sflags & SVf_IOK)
+ SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
}
if (SvAMAGIC(sstr)) {
SvAMAGIC_on(dstr);
*SvEND(dstr) = '\0';
(void)SvPOK_only(dstr);
}
- if ((sflags & SVf_UTF8) && !IN_BYTE)
+ if (sflags & SVf_UTF8)
SvUTF8_on(dstr);
/*SUPPRESS 560*/
if (sflags & SVp_NOK) {
- SvNOK_on(dstr);
+ SvNOKp_on(dstr);
+ if (sflags & SVf_NOK)
+ SvFLAGS(dstr) |= SVf_NOK;
SvNVX(dstr) = SvNVX(sstr);
}
if (sflags & SVp_IOK) {
- (void)SvIOK_on(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ (void)SvIOKp_on(dstr);
+ if (sflags & SVf_IOK)
+ SvFLAGS(dstr) |= SVf_IOK;
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
- }
- }
- else if (sflags & SVp_NOK) {
- SvNVX(dstr) = SvNVX(sstr);
- (void)SvNOK_only(dstr);
- if (sflags & SVf_IOK) {
- (void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
- /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
- if (sflags & SVf_IVisUV)
- SvIsUV_on(dstr);
}
}
else if (sflags & SVp_IOK) {
- (void)SvIOK_only(dstr);
- SvIVX(dstr) = SvIVX(sstr);
+ if (sflags & SVf_IOK)
+ (void)SvIOK_only(dstr);
+ else {
+ SvOK_off(dstr);
+ SvIOKp_on(dstr);
+ }
+ /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
if (sflags & SVf_IVisUV)
SvIsUV_on(dstr);
+ SvIVX(dstr) = SvIVX(sstr);
+ if (sflags & SVp_NOK) {
+ if (sflags & SVf_NOK)
+ (void)SvNOK_on(dstr);
+ else
+ (void)SvNOKp_on(dstr);
+ SvNVX(dstr) = SvNVX(sstr);
+ }
+ }
+ else if (sflags & SVp_NOK) {
+ if (sflags & SVf_NOK)
+ (void)SvNOK_only(dstr);
+ else {
+ SvOK_off(dstr);
+ SvNOKp_on(dstr);
+ }
+ SvNVX(dstr) = SvNVX(sstr);
}
else {
if (dtype == SVt_PVGV) {
Move(ptr,dptr,len,char);
dptr[len] = '\0';
SvCUR_set(sv, len);
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
SvGROW(sv, len + 1);
Move(ptr,SvPVX(sv),len+1,char);
SvCUR_set(sv, len);
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
SvCUR_set(sv, len);
SvLEN_set(sv, len+1);
*SvEND(sv) = '\0';
- (void)SvPOK_only(sv); /* validate pointer */
+ (void)SvPOK_only_UTF8(sv); /* validate pointer */
SvTAINT(sv);
}
/*
=for apidoc sv_catsv
-Concatenates the string from SV C<ssv> onto the end of the string in SV
-C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
+not 'set' magic. See C<sv_catsv_mg>.
-=cut
-*/
+=cut */
void
-Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
{
- char *s;
- STRLEN len;
- if (!sstr)
+ char *spv;
+ STRLEN slen;
+ if (!ssv)
return;
- if ((s = SvPV(sstr, len))) {
- if (DO_UTF8(sstr)) {
- sv_utf8_upgrade(dstr);
- sv_catpvn(dstr,s,len);
- SvUTF8_on(dstr);
+ if ((spv = SvPV(ssv, slen))) {
+ bool dutf8 = DO_UTF8(dsv);
+ bool sutf8 = DO_UTF8(ssv);
+
+ if (dutf8 == sutf8)
+ sv_catpvn(dsv,spv,slen);
+ else {
+ if (dutf8) {
+ /* Not modifying source SV, so taking a temporary copy. */
+ SV* csv = sv_2mortal(newSVsv(ssv));
+ char *cpv;
+ STRLEN clen;
+
+ sv_utf8_upgrade(csv);
+ cpv = SvPV(csv,clen);
+ sv_catpvn(dsv,cpv,clen);
+ }
+ else {
+ sv_utf8_upgrade(dsv);
+ sv_catpvn(dsv,spv,slen);
+ SvUTF8_on(dsv); /* If dsv has no wide characters. */
+ }
}
- else
- sv_catpvn(dstr,s,len);
}
}
*/
void
-Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
+Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
{
- sv_catsv(dstr,sstr);
- SvSETMAGIC(dstr);
+ sv_catsv(dsv,ssv);
+ SvSETMAGIC(dsv);
}
/*
mg->mg_virtual = &PL_vtbl_amagicelem;
break;
case 'c':
- mg->mg_virtual = 0;
+ mg->mg_virtual = &PL_vtbl_ovrld;
break;
case 'B':
mg->mg_virtual = &PL_vtbl_bm;
SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
SvREFCNT(&tmpref) = 1;
- do {
+ do {
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
if (!sv)
return 0;
-#ifdef NOTYET
if (SvGMAGICAL(sv))
return mg_length(sv);
else
-#endif
{
STRLEN len;
U8 *s = (U8*)SvPV(sv, len);
s = (U8*)SvPV(sv, len);
if (len < *offsetp)
- Perl_croak(aTHX_ "panic: bad byte offset");
+ Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
send = s + *offsetp;
len = 0;
while (s < send) {
- s += UTF8SKIP(s);
- ++len;
- }
- if (s != send) {
- if (ckWARN_d(WARN_UTF8))
- Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
- --len;
+ STRLEN n;
+
+ if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
+ s += n;
+ len++;
+ }
+ else
+ break;
}
*offsetp = len;
return;
/* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ if (PL_hints & HINT_UTF8_DISTINCT)
+ return FALSE;
+
if (SvUTF8(sv1)) {
- pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
- pv2tmp = TRUE;
+ (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
+ {
+ IV scur1 = cur1;
+ if (scur1 < 0) {
+ Safefree(pv1);
+ return 0;
+ }
+ }
+ pv1tmp = TRUE;
}
else {
- pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
- pv1tmp = TRUE;
+ (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
+ {
+ IV scur2 = cur2;
+ if (scur2 < 0) {
+ Safefree(pv2);
+ return 0;
+ }
+ }
+ pv2tmp = TRUE;
}
}
/* do not utf8ize the comparands as a side-effect */
if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
+ if (PL_hints & HINT_UTF8_DISTINCT)
+ return SvUTF8(sv1) ? 1 : -1;
+
if (SvUTF8(sv1)) {
pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
pv2tmp = TRUE;
if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
/* It's (privately or publicly) a float, but not tested as an
integer, so test it to see. */
- (void) SvIV(sv);
+ (void) SvIV(sv);
flags = SvFLAGS(sv);
}
if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
so $a="9.22337203685478e+18"; $a+0; $a++
needs to be the same as $a="9.22337203685478e+18"; $a++
or we go insane. */
-
+
(void) sv_2iv(sv);
if (SvIOK(sv))
goto oops_its_int;
so $a="9.22337203685478e+18"; $a+0; $a--
needs to be the same as $a="9.22337203685478e+18"; $a--
or we go insane. */
-
+
(void) sv_2iv(sv);
if (SvIOK(sv))
goto oops_its_int;
projects / p5sagit/p5-mst-13.2.git / blobdiff