static void del_xpv _((XPV* p));
static void del_xrv _((XRV* p));
static void sv_unglob _((SV* sv));
+static void sv_add_backref _((SV *tsv, SV *sv));
+static void sv_del_backref _((SV *sv));
#ifndef PURIFY
static void *my_safemalloc(MEM_SIZE size);
void
sv_setuv(register SV *sv, UV u)
{
- if (u <= IV_MAX)
- sv_setiv(sv, u);
- else
- sv_setnv(sv, (double)u);
+ sv_setiv(sv, 0);
+ SvIsUV_on(sv);
+ SvUVX(sv) = u;
}
void
warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
}
+/* the number can be converted to _integer_ with atol() */
+#define IS_NUMBER_TO_INT_BY_ATOL 0x01
+#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
+#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
+#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
+
+/* Actually, ISO C leaves conversion of UV to IV undefined, but
+ until proven guilty, assume that things are not that bad... */
+
IV
sv_2iv(register SV *sv)
{
if (SvIOKp(sv))
return SvIVX(sv);
if (SvNOKp(sv)) {
- if (SvNVX(sv) < 0.0)
- return I_V(SvNVX(sv));
- else
- return (IV) U_V(SvNVX(sv));
+ return I_V(SvNVX(sv));
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
}
if (SvREADONLY(sv)) {
if (SvNOKp(sv)) {
- if (SvNVX(sv) < 0.0)
- return I_V(SvNVX(sv));
- else
- return (IV) U_V(SvNVX(sv));
+ return I_V(SvNVX(sv));
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
return 0;
}
}
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- sv_upgrade(sv, SVt_IV);
- break;
- case SVt_PV:
- sv_upgrade(sv, SVt_PVIV);
- break;
- case SVt_NV:
- sv_upgrade(sv, SVt_PVNV);
- break;
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv)) {
+ return (IV)(SvUVX(sv));
+ }
+ else {
+ return SvIVX(sv);
+ }
}
if (SvNOKp(sv)) {
+ /* We can cache the IV/UV value even if it not good enough
+ * to reconstruct NV, since the conversion to PV will prefer
+ * NV over IV/UV. XXXX 64-bit?
+ */
+
+ if (SvTYPE(sv) == SVt_NV)
+ sv_upgrade(sv, SVt_PVNV);
+
(void)SvIOK_on(sv);
- if (SvNVX(sv) < 0.0)
+ if (SvNVX(sv) < (double)IV_MAX + 0.5)
SvIVX(sv) = I_V(SvNVX(sv));
- else
+ else {
SvUVX(sv) = U_V(SvNVX(sv));
+ SvIsUV_on(sv);
+ ret_iv_max:
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
+ (unsigned long)sv,
+ (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
+ return (IV)SvUVX(sv);
+ }
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- (void)SvIOK_on(sv);
- SvIVX(sv) = asIV(sv);
+ I32 numtype = looks_like_number(sv);
+
+ /* We want to avoid a possible problem when we cache an IV which
+ may be later translated to an NV, and the resulting NV is not
+ the translation of the initial data.
+
+ This means that if we cache such an IV, we need to cache the
+ NV as well. Moreover, we trade speed for space, and do not
+ cache the NV if not needed.
+ */
+ if (numtype & IS_NUMBER_NOT_IV) {
+ /* May be not an integer. Need to cache NV if we cache IV
+ * - otherwise future conversion to NV will be wrong. */
+ double d;
+
+ SET_NUMERIC_STANDARD();
+ d = atof(SvPVX(sv));
+
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNVX(sv) = d;
+ (void)SvNOK_on(sv);
+ (void)SvIOK_on(sv);
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2nv(%g)\n",(unsigned long)sv,
+ SvNVX(sv)));
+ if (SvNVX(sv) < (double)IV_MAX + 0.5)
+ SvIVX(sv) = I_V(SvNVX(sv));
+ else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ SvIsUV_on(sv);
+ goto ret_iv_max;
+ }
+ }
+ else if (numtype) {
+ /* The NV may be reconstructed from IV - safe to cache IV,
+ which may be calculated by atol(). */
+ if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
+ }
+ else { /* Not a number. Cache 0. */
+ dTHR;
+
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ SvIVX(sv) = 0;
+ (void)SvIOK_on(sv);
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
}
else {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ if (SvTYPE(sv) < SVt_IV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_IV);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
(unsigned long)sv,(long)SvIVX(sv)));
- return SvIVX(sv);
+ return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
UV
return 0;
}
}
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- sv_upgrade(sv, SVt_IV);
- break;
- case SVt_PV:
- sv_upgrade(sv, SVt_PVIV);
- break;
- case SVt_NV:
- sv_upgrade(sv, SVt_PVNV);
- break;
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv)) {
+ return SvUVX(sv);
+ }
+ else {
+ return (UV)SvIVX(sv);
+ }
}
if (SvNOKp(sv)) {
+ /* We can cache the IV/UV value even if it not good enough
+ * to reconstruct NV, since the conversion to PV will prefer
+ * NV over IV/UV. XXXX 64-bit?
+ */
+ if (SvTYPE(sv) == SVt_NV)
+ sv_upgrade(sv, SVt_PVNV);
(void)SvIOK_on(sv);
- SvUVX(sv) = U_V(SvNVX(sv));
+ if (SvNVX(sv) >= -0.5) {
+ SvIsUV_on(sv);
+ SvUVX(sv) = U_V(SvNVX(sv));
+ }
+ else {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ ret_zero:
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2uv(%ld => %lu) (as signed)\n",
+ (unsigned long)sv,(long)SvIVX(sv),
+ (long)(UV)SvIVX(sv)));
+ return (UV)SvIVX(sv);
+ }
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- (void)SvIOK_on(sv);
- SvUVX(sv) = asUV(sv);
+ I32 numtype = looks_like_number(sv);
+
+ /* We want to avoid a possible problem when we cache a UV which
+ may be later translated to an NV, and the resulting NV is not
+ the translation of the initial data.
+
+ This means that if we cache such a UV, we need to cache the
+ NV as well. Moreover, we trade speed for space, and do not
+ cache the NV if not needed.
+ */
+ if (numtype & IS_NUMBER_NOT_IV) {
+ /* May be not an integer. Need to cache NV if we cache IV
+ * - otherwise future conversion to NV will be wrong. */
+ double d;
+
+ SET_NUMERIC_STANDARD();
+ d = atof(SvPVX(sv)); /* XXXX 64-bit? */
+
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNVX(sv) = d;
+ (void)SvNOK_on(sv);
+ (void)SvIOK_on(sv);
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2nv(%g)\n",(unsigned long)sv,
+ SvNVX(sv)));
+ if (SvNVX(sv) < -0.5) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ goto ret_zero;
+ } else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ SvIsUV_on(sv);
+ }
+ }
+ else if (numtype & IS_NUMBER_NEG) {
+ /* The NV may be reconstructed from IV - safe to cache IV,
+ which may be calculated by atol(). */
+ if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
+ }
+ else if (numtype) { /* Non-negative */
+ /* The NV may be reconstructed from UV - safe to cache UV,
+ which may be calculated by strtoul()/atol. */
+ if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ (void)SvIsUV_on(sv);
+#ifdef HAS_STRTOUL
+ SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
+#else /* no atou(), but we know the number fits into IV... */
+ /* The only problem may be if it is negative... */
+ SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
+#endif
+ }
+ else { /* Not a number. Cache 0. */
+ dTHR;
+
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ SvUVX(sv) = 0; /* We assume that 0s have the
+ same bitmap in IV and UV. */
+ (void)SvIOK_on(sv);
+ (void)SvIsUV_on(sv);
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
}
else {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
+ if (SvTYPE(sv) < SVt_IV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_IV);
return 0;
}
+
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
(unsigned long)sv,SvUVX(sv)));
- return SvUVX(sv);
+ return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
double
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
- if (SvIOKp(sv))
- return (double)SvIVX(sv);
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv))
+ return (double)SvUVX(sv);
+ else
+ return (double)SvIVX(sv);
+ }
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
- if (SvIOKp(sv))
- return (double)SvIVX(sv);
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv))
+ return (double)SvUVX(sv);
+ else
+ return (double)SvIVX(sv);
+ }
if (ckWARN(WARN_UNINITIALIZED))
warner(WARN_UNINITIALIZED, PL_warn_uninit);
return 0.0;
if (SvIOKp(sv) &&
(!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
{
- SvNVX(sv) = (double)SvIVX(sv);
+ SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
dTHR;
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ if (SvTYPE(sv) < SVt_NV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_NV);
return 0.0;
}
SvNOK_on(sv);
I32 numtype = looks_like_number(sv);
double d;
- if (numtype == 1)
- return atol(SvPVX(sv));
+ if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
+ return atol(SvPVX(sv)); /* XXXX 64-bit? */
if (!numtype) {
dTHR;
if (ckWARN(WARN_NUMERIC))
}
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
- if (d < 0.0)
- return I_V(d);
- else
- return (IV) U_V(d);
+ return I_V(d);
}
STATIC UV
I32 numtype = looks_like_number(sv);
#ifdef HAS_STRTOUL
- if (numtype == 1)
+ if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
return strtoul(SvPVX(sv), Null(char**), 10);
#endif
if (!numtype) {
return U_V(atof(SvPVX(sv)));
}
+/*
+ * Returns a combination of (advisory only - can get false negatives)
+ * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
+ * IS_NUMBER_NEG
+ * 0 if does not look like number.
+ *
+ * In fact possible values are 0 and
+ * IS_NUMBER_TO_INT_BY_ATOL 123
+ * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
+ * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
+ * with a possible addition of IS_NUMBER_NEG.
+ */
+
I32
looks_like_number(SV *sv)
{
+ /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
+ * using atof() may lose precision. */
register char *s;
register char *send;
register char *sbegin;
- I32 numtype;
+ register char *nbegin;
+ I32 numtype = 0;
STRLEN len;
if (SvPOK(sv)) {
s = sbegin;
while (isSPACE(*s))
s++;
- if (*s == '+' || *s == '-')
+ if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
s++;
+ nbegin = s;
+ /*
+ * we return 1 if the number can be converted to _integer_ with atol()
+ * and 2 if you need (int)atof().
+ */
+
/* next must be digit or '.' */
if (isDIGIT(*s)) {
do {
s++;
} while (isDIGIT(*s));
+
+ if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
+ numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
+ else
+ numtype |= IS_NUMBER_TO_INT_BY_ATOL;
+
if (*s == '.') {
s++;
+ numtype |= IS_NUMBER_NOT_IV;
while (isDIGIT(*s)) /* optional digits after "." */
s++;
}
}
else if (*s == '.') {
s++;
+ numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
/* no digits before '.' means we need digits after it */
if (isDIGIT(*s)) {
do {
else
return 0;
- /*
- * we return 1 if the number can be converted to _integer_ with atol()
- * and 2 if you need (int)atof().
- */
- numtype = 1;
-
/* we can have an optional exponent part */
if (*s == 'e' || *s == 'E') {
- numtype = 2;
+ numtype &= ~IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
s++;
if (*s == '+' || *s == '-')
s++;
if (s >= send)
return numtype;
if (len == 10 && memEQ(sbegin, "0 but true", 10))
- return 1;
+ return IS_NUMBER_TO_INT_BY_ATOL;
return 0;
}
return sv_2pv(sv, &n_a);
}
+/* We assume that buf is at least TYPE_CHARS(UV) long. */
+STATIC char *
+uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+{
+ STRLEN len;
+ char *ptr = buf + TYPE_CHARS(UV);
+ char *ebuf = ptr;
+ int sign;
+ char *p;
+
+ if (is_uv)
+ sign = 0;
+ else if (iv >= 0) {
+ uv = iv;
+ sign = 0;
+ } else {
+ uv = -iv;
+ sign = 1;
+ }
+ do {
+ *--ptr = '0' + (uv % 10);
+ } while (uv /= 10);
+ if (sign)
+ *--ptr = '-';
+ *peob = ebuf;
+ return ptr;
+}
+
char *
sv_2pv(register SV *sv, STRLEN *lp)
{
register char *s;
int olderrno;
SV *tsv;
- char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
+ char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
+ char *tmpbuf = tbuf;
if (!sv) {
*lp = 0;
*lp = SvCUR(sv);
return SvPVX(sv);
}
- if (SvIOKp(sv)) {
- (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+ if (SvIOKp(sv)) { /* XXXX 64-bit? */
+ if (SvIsUV(sv))
+ (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
+ else
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
tsv = Nullsv;
goto tokensave;
}
sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
else
sv_setpv(tsv, s);
+ /* XXXX 64-bit? */
sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
goto tokensaveref;
}
return s;
}
if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) {
+ if (SvNOKp(sv)) { /* See note in sv_2uv() */
+ /* XXXX 64-bit? IV may have better precision... */
SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
if (SvIOKp(sv)) {
- (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+ char *ebuf;
+
+ if (SvIsUV(sv))
+ tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
+ else
+ tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
+ *ebuf = 0;
tsv = Nullsv;
goto tokensave;
}
return "";
}
}
- (void)SvUPGRADE(sv, SVt_PV);
- if (SvNOKp(sv)) {
+ if (SvNOKp(sv)) { /* See note in sv_2uv() */
+ /* XXXX 64-bit? IV may have better precision... */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvGROW(sv, 28);
#endif
}
else if (SvIOKp(sv)) {
- U32 oldIOK = SvIOK(sv);
+ U32 isIOK = SvIOK(sv);
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf, *ptr;
+
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- olderrno = errno; /* some Xenix systems wipe out errno here */
- sv_setpviv(sv, SvIVX(sv));
- errno = olderrno;
+ if (SvIsUV(sv)) {
+ ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ SvIsUV_on(sv);
+ }
+ else {
+ ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ }
s = SvEND(sv);
- if (oldIOK)
+ if (isIOK)
SvIOK_on(sv);
else
SvIOKp_on(sv);
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
warner(WARN_UNINITIALIZED, PL_warn_uninit);
*lp = 0;
+ if (SvTYPE(sv) < SVt_PV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_PV);
return "";
}
*lp = s - SvPVX(sv);
}
(void)SvIOK_only(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
SvTAINT(dstr);
return;
}
}
if (SvPVX(dstr)) {
(void)SvOOK_off(dstr); /* backoff */
- Safefree(SvPVX(dstr));
+ if (SvLEN(dstr))
+ Safefree(SvPVX(dstr));
SvLEN(dstr)=SvCUR(dstr)=0;
}
}
if (sflags & SVp_IOK) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
if (SvAMAGIC(sstr)) {
SvAMAGIC_on(dstr);
SvFLAGS(dstr) &= ~SVf_OOK;
Safefree(SvPVX(dstr) - SvIVX(dstr));
}
- else
+ else if (SvLEN(dstr))
Safefree(SvPVX(dstr));
}
(void)SvPOK_only(dstr);
if (sflags & SVp_IOK) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
}
else if (sflags & SVp_NOK) {
if (SvIOK(sstr)) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
}
else if (sflags & SVp_IOK) {
(void)SvIOK_only(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
else {
if (dtype == SVt_PVGV) {
return;
}
(void)SvOOK_off(sv);
- if (SvPVX(sv))
+ if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
Renew(ptr, len+1, char);
SvPVX(sv) = ptr;
sv_upgrade(sv,SVt_PVIV);
if (!SvOOK(sv)) {
+ if (!SvLEN(sv)) { /* make copy of shared string */
+ char *pvx = SvPVX(sv);
+ STRLEN len = SvCUR(sv);
+ SvGROW(sv, len + 1);
+ Move(pvx,SvPVX(sv),len,char);
+ *SvEND(sv) = '\0';
+ }
SvIVX(sv) = 0;
SvFLAGS(sv) |= SVf_OOK;
}
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK);
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
delta = ptr - SvPVX(sv);
SvLEN(sv) -= delta;
SvCUR(sv) -= delta;
case '.':
mg->mg_virtual = &PL_vtbl_pos;
break;
+ case '<':
+ mg->mg_virtual = &PL_vtbl_backref;
+ break;
case '~': /* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
/* Note that multiple extensions may clash if magical scalars */
return 0;
}
+SV *
+sv_rvweaken(SV *sv)
+{
+ SV *tsv;
+ if (!SvOK(sv)) /* let undefs pass */
+ return sv;
+ if (!SvROK(sv))
+ croak("Can't weaken a nonreference");
+ else if (SvWEAKREF(sv)) {
+ dTHR;
+ if (ckWARN(WARN_MISC))
+ warner(WARN_MISC, "Reference is already weak");
+ return sv;
+ }
+ tsv = SvRV(sv);
+ sv_add_backref(tsv, sv);
+ SvWEAKREF_on(sv);
+ SvREFCNT_dec(tsv);
+ return sv;
+}
+
+STATIC void
+sv_add_backref(SV *tsv, SV *sv)
+{
+ AV *av;
+ MAGIC *mg;
+ if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
+ av = (AV*)mg->mg_obj;
+ else {
+ av = newAV();
+ sv_magic(tsv, (SV*)av, '<', NULL, 0);
+ SvREFCNT_dec(av); /* for sv_magic */
+ }
+ av_push(av,sv);
+}
+
+STATIC void
+sv_del_backref(SV *sv)
+{
+ AV *av;
+ SV **svp;
+ I32 i;
+ SV *tsv = SvRV(sv);
+ MAGIC *mg;
+ if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
+ croak("panic: del_backref");
+ av = (AV *)mg->mg_obj;
+ svp = AvARRAY(av);
+ i = AvFILLp(av);
+ while (i >= 0) {
+ if (svp[i] == sv) {
+ svp[i] = &PL_sv_undef; /* XXX */
+ }
+ i--;
+ }
+}
+
void
sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
{
/* FALL THROUGH */
case SVt_PV:
case SVt_RV:
- if (SvROK(sv))
- SvREFCNT_dec(SvRV(sv));
+ if (SvROK(sv)) {
+ if (SvWEAKREF(sv))
+ sv_del_backref(sv);
+ else
+ SvREFCNT_dec(SvRV(sv));
+ }
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
break;
return;
}
if (flags & SVp_IOK) {
- if (SvIVX(sv) == IV_MAX)
- sv_setnv(sv, (double)IV_MAX + 1.0);
- else {
- (void)SvIOK_only(sv);
- ++SvIVX(sv);
+ if (SvIsUV(sv)) {
+ if (SvUVX(sv) == UV_MAX)
+ sv_setnv(sv, (double)UV_MAX + 1.0);
+ else
+ (void)SvIOK_only_UV(sv);
+ ++SvUVX(sv);
+ } else {
+ if (SvIVX(sv) == IV_MAX)
+ sv_setnv(sv, (double)IV_MAX + 1.0);
+ else {
+ (void)SvIOK_only(sv);
+ ++SvIVX(sv);
+ }
}
return;
}
return;
}
if (flags & SVp_IOK) {
- if (SvIVX(sv) == IV_MIN)
- sv_setnv(sv, (double)IV_MIN - 1.0);
- else {
- (void)SvIOK_only(sv);
- --SvIVX(sv);
+ if (SvIsUV(sv)) {
+ if (SvUVX(sv) == 0) {
+ (void)SvIOK_only(sv);
+ SvIVX(sv) = -1;
+ }
+ else {
+ (void)SvIOK_only_UV(sv);
+ --SvUVX(sv);
+ }
+ } else {
+ if (SvIVX(sv) == IV_MIN)
+ sv_setnv(sv, (double)IV_MIN - 1.0);
+ else {
+ (void)SvIOK_only(sv);
+ --SvIVX(sv);
+ }
}
return;
}
ENTER;
tmpsv = NEWSV(704,0);
gv_efullname3(tmpsv, gv, Nullch);
+ /* XXX this is probably not what they think they're getting.
+ * It has the same effect as "sub name;", i.e. just a forward
+ * declaration! */
newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, tmpsv),
Nullop,
IV
sv_iv(register SV *sv)
{
- if (SvIOK(sv))
+ if (SvIOK(sv)) {
+ if (SvIsUV(sv))
+ return (IV)SvUVX(sv);
return SvIVX(sv);
+ }
return sv_2iv(sv);
}
UV
sv_uv(register SV *sv)
{
- if (SvIOK(sv))
- return SvUVX(sv);
+ if (SvIOK(sv)) {
+ if (SvIsUV(sv))
+ return SvUVX(sv);
+ return (UV)SvIVX(sv);
+ }
return sv_2uv(sv);
}
sv_unref(SV *sv)
{
SV* rv = SvRV(sv);
-
+
+ if (SvWEAKREF(sv)) {
+ sv_del_backref(sv);
+ SvWEAKREF_off(sv);
+ SvRV(sv) = 0;
+ return;
+ }
SvRV(sv) = 0;
SvROK_off(sv);
if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
void
sv_setpviv(SV *sv, IV iv)
{
- STRLEN len;
- char buf[TYPE_DIGITS(UV)];
- char *ptr = buf + sizeof(buf);
- int sign;
- UV uv;
- char *p;
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
- sv_setpvn(sv, "", 0);
- if (iv >= 0) {
- uv = iv;
- sign = 0;
- } else {
- uv = -iv;
- sign = 1;
- }
- do {
- *--ptr = '0' + (uv % 10);
- } while (uv /= 10);
- len = (buf + sizeof(buf)) - ptr;
- /* taking advantage of SvCUR(sv) == 0 */
- SvGROW(sv, sign + len + 1);
- p = SvPVX(sv);
- if (sign)
- *p++ = '-';
- memcpy(p, ptr, len);
- p += len;
- *p = '\0';
- SvCUR(sv) = p - SvPVX(sv);
+ sv_setpvn(sv, ptr, ebuf - ptr);
}
void
sv_setpviv_mg(SV *sv, IV iv)
{
- sv_setpviv(sv,iv);
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
SvSETMAGIC(sv);
}