Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
}
-/* the number can be converted to _integer_ with atol() */
+/* the number can be converted to integer with atol() or atoll() */
#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() */
return SvIV(tmpstr);
return (IV)SvRV(sv);
}
- if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) {
- return I_V(SvNVX(sv));
- }
- if (SvPOKp(sv) && SvLEN(sv))
- return asIV(sv);
- {
- dTHR;
- if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
- }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
return 0;
}
}
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?
+ * NV over IV/UV.
*/
if (SvTYPE(sv) == SVt_NV)
SvUVX(sv) = U_V(SvNVX(sv));
SvIsUV_on(sv);
ret_iv_max:
+#ifdef IV_IS_QUAD
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n",
+ (UV)sv,
+ (UV)SvUVX(sv), (IV)SvUVX(sv)));
+#else
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)));
+#endif
return (IV)SvUVX(sv);
}
}
(void)SvNOK_on(sv);
(void)SvIOK_on(sv);
#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
(unsigned long)sv, SvNVX(sv)));
#else
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
if (SvTYPE(sv) == SVt_PV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
- SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
+ SvIVX(sv) = Atol(SvPVX(sv));
}
else { /* Not a number. Cache 0. */
dTHR;
return SvUV(tmpstr);
return (UV)SvRV(sv);
}
- if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) {
- return U_V(SvNVX(sv));
- }
- if (SvPOKp(sv) && SvLEN(sv))
- return asUV(sv);
- {
- dTHR;
- if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
- }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
return 0;
}
}
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?
+ * NV over IV/UV.
*/
if (SvTYPE(sv) == SVt_NV)
sv_upgrade(sv, SVt_PVNV);
else {
SvIVX(sv) = I_V(SvNVX(sv));
ret_zero:
+#ifdef IV_IS_QUAD
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n",
+ (unsigned long)sv,(long)SvIVX(sv),
+ (long)(UV)SvIVX(sv)));
+#else
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)));
+#endif
return (UV)SvIVX(sv);
}
}
* - otherwise future conversion to NV will be wrong. */
NV d;
- d = Atof(SvPVX(sv)); /* XXXX 64-bit? */
+ d = Atof(SvPVX(sv));
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
(void)SvNOK_on(sv);
(void)SvIOK_on(sv);
#if defined(USE_LONG_DOUBLE)
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIg64 ")\n",
(unsigned long)sv, SvNVX(sv)));
#else
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
if (SvTYPE(sv) == SVt_PV)
sv_upgrade(sv, SVt_PVIV);
(void)SvIOK_on(sv);
- SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
+ SvIVX(sv) = (IV)Atol(SvPVX(sv));
}
else if (numtype) { /* Non-negative */
/* The NV may be reconstructed from UV - safe to cache UV,
(void)SvIOK_on(sv);
(void)SvIsUV_on(sv);
#ifdef HAS_STRTOUL
- SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
+ SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
#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? */
+ SvUVX(sv) = (UV)Atol(SvPVX(sv));
#endif
}
else { /* Not a number. Cache 0. */
return SvNV(tmpstr);
return (NV)(unsigned long)SvRV(sv);
}
- if (SvREADONLY(sv)) {
+ if (SvREADONLY(sv) && !SvOK(sv)) {
dTHR;
- if (SvPOKp(sv) && SvLEN(sv)) {
- if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
- not_a_number(sv);
- return Atof(SvPVX(sv));
- }
- if (SvIOKp(sv)) {
- if (SvIsUV(sv))
- return (NV)SvUVX(sv);
- else
- return (NV)SvIVX(sv);
- }
if (ckWARN(WARN_UNINITIALIZED))
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
return 0.0;
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
RESTORE_NUMERIC_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n",
+ PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIg64 ")\n",
(unsigned long)sv, SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
#if defined(USE_LONG_DOUBLE)
DEBUG_c({
RESTORE_NUMERIC_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
+ PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIg64 ")\n",
(unsigned long)sv, SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
NV d;
if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
- return atol(SvPVX(sv)); /* XXXX 64-bit? */
+ return Atol(SvPVX(sv));
if (!numtype) {
dTHR;
if (ckWARN(WARN_NUMERIC))
#ifdef HAS_STRTOUL
if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
- return strtoul(SvPVX(sv), Null(char**), 10);
+ return Strtoul(SvPVX(sv), Null(char**), 10);
#endif
if (!numtype) {
dTHR;
I32
Perl_looks_like_number(pTHX_ 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;
*lp = SvCUR(sv);
return SvPVX(sv);
}
- if (SvIOKp(sv)) { /* XXXX 64-bit? */
+ if (SvIOKp(sv)) {
+#ifdef IV_IS_QUAD
+ if (SvIsUV(sv))
+ (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv));
+ else
+ (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv));
+#else
if (SvIsUV(sv))
(void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
else
(void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+#endif
tsv = Nullsv;
goto tokensave;
}
Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
else
sv_setpv(tsv, s);
- /* XXXX 64-bit? */
+#ifdef IV_IS_QUAD
+ Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)sv);
+#else
Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
+#endif
goto tokensaveref;
}
*lp = strlen(s);
return s;
}
- if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) { /* See note in sv_2uv() */
- /* XXXX 64-bit? IV may have better precision... */
- Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
- tsv = Nullsv;
- goto tokensave;
- }
- if (SvIOKp(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;
- }
- {
- dTHR;
- if (ckWARN(WARN_UNINITIALIZED))
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
- }
+ if (SvREADONLY(sv) && !SvOK(sv)) {
+ dTHR;
+ if (ckWARN(WARN_UNINITIALIZED))
+ Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
*lp = 0;
return "";
}
}
else if (SvIOKp(sv)) {
U32 isIOK = SvIOK(sv);
+ U32 isUIOK = SvIsUV(sv);
char buf[TYPE_CHARS(UV)];
char *ebuf, *ptr;
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- if (SvIsUV(sv)) {
+ if (isUIOK)
ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
- sv_setpvn(sv, ptr, ebuf - ptr);
- SvIsUV_on(sv);
- }
- else {
+ else
ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
- sv_setpvn(sv, ptr, ebuf - ptr);
- }
+ SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
+ Move(ptr,SvPVX(sv),ebuf - ptr,char);
+ SvCUR_set(sv, ebuf - ptr);
s = SvEND(sv);
+ *s = '\0';
if (isIOK)
SvIOK_on(sv);
else
SvIOKp_on(sv);
+ if (isUIOK)
+ SvIsUV_on(sv);
+ SvPOK_on(sv);
}
else {
dTHR;
- if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ if (ckWARN(WARN_UNINITIALIZED)
+ && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ {
Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
+ }
*lp = 0;
if (SvTYPE(sv) < SVt_PV)
/* Typically the caller expects that sv_any is not NULL now. */
*lp = s - SvPVX(sv);
SvCUR_set(sv, *lp);
SvPOK_on(sv);
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
+ (unsigned long)sv,SvPVX(sv)));
return SvPVX(sv);
tokensave:
IoIFP(sv) != PerlIO_stdout() &&
IoIFP(sv) != PerlIO_stderr())
{
- io_close((IO*)sv);
+ io_close((IO*)sv, FALSE);
}
if (IoDIRP(sv)) {
PerlDir_close(IoDIRP(sv));
register I32 i;
register PMOP *pm;
register I32 max;
- char todo[256];
+ char todo[PERL_UCHAR_MAX+1];
if (!stash)
return;
Zero(todo, 256, char);
while (*s) {
- i = *s;
+ i = (unsigned char)*s;
if (s[1] == '-') {
s += 2;
}
- max = *s++;
+ max = (unsigned char)*s++;
for ( ; i <= max; i++) {
todo[i] = 1;
}
switch (*q) {
case 'l':
-#if 0 /* when quads have better support within Perl */
- if (*(q + 1) == 'l') {
+#ifdef HAS_QUAD
+ if (*(q + 1) == 'l') { /* lld */
intsize = 'q';
q += 2;
break;
- }
+ }
+ case 'L': /* Ld */
+ case 'q': /* qd */
+ intsize = 'q';
+ q++;
+ break;
#endif
- /* FALL THROUGH */
case 'h':
+ /* FALL THROUGH */
case 'V':
intsize = *q++;
break;
goto integer;
case 'D':
+#ifdef IV_IS_QUAD
+ /* nothing */
+#else
intsize = 'l';
+#endif
/* FALL THROUGH */
case 'd':
case 'i':
if (args) {
switch (intsize) {
case 'h': iv = (short)va_arg(*args, int); break;
+#ifdef IV_IS_QUAD
+ default: iv = va_arg(*args, IV); break;
+#else
default: iv = va_arg(*args, int); break;
+#endif
case 'l': iv = va_arg(*args, long); break;
case 'V': iv = va_arg(*args, IV); break;
+#ifdef HAS_QUAD
+ case 'q': iv = va_arg(*args, Quad_t); break;
+#endif
}
}
else {
iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
switch (intsize) {
case 'h': iv = (short)iv; break;
+#ifdef IV_IS_QUAD
+ default: break;
+#else
default: iv = (int)iv; break;
+#endif
case 'l': iv = (long)iv; break;
case 'V': break;
+#ifdef HAS_QUAD
+ case 'q': iv = (Quad_t)iv; break;
+#endif
}
}
if (iv >= 0) {
goto integer;
case 'U':
+#ifdef IV_IS_QUAD
+ /* nothing */
+#else
intsize = 'l';
+#endif
/* FALL THROUGH */
case 'u':
base = 10;
goto uns_integer;
case 'O':
+#ifdef IV_IS_QUAD
+ /* nothing */
+#else
intsize = 'l';
+#endif
/* FALL THROUGH */
case 'o':
base = 8;
if (args) {
switch (intsize) {
case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
+#ifdef UV_IS_QUAD
+ default: uv = va_arg(*args, UV); break;
+#else
default: uv = va_arg(*args, unsigned); break;
+#endif
case 'l': uv = va_arg(*args, unsigned long); break;
case 'V': uv = va_arg(*args, UV); break;
+#ifdef HAS_QUAD
+ case 'q': uv = va_arg(*args, Quad_t); break;
+#endif
}
}
else {
uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
switch (intsize) {
case 'h': uv = (unsigned short)uv; break;
+#ifdef UV_IS_QUAD
+ default: break;
+#else
default: uv = (unsigned)uv; break;
+#endif
case 'l': uv = (unsigned long)uv; break;
case 'V': break;
+#ifdef HAS_QUAD
+ case 'q': uv = (Quad_t)uv; break;
+#endif
}
}
*--eptr = '\0';
*--eptr = c;
#ifdef USE_LONG_DOUBLE
- *--eptr = 'L';
+ {
+ char* p = PRIfldbl + sizeof(PRIfldbl) - 3;
+ while (p >= PRIfldbl) { *--eptr = *p-- }
+ }
#endif
if (has_precis) {
base = precis;
if (args) {
switch (intsize) {
case 'h': *(va_arg(*args, short*)) = i; break;
+#ifdef IV_IS_QUAD
+ default: *(va_arg(*args, IV*)) = i; break;
+#else
default: *(va_arg(*args, int*)) = i; break;
+#endif
case 'l': *(va_arg(*args, long*)) = i; break;
case 'V': *(va_arg(*args, IV*)) = i; break;
+#ifdef HAS_QUAD
+ case 'q': *(va_arg(*args, Quad_t*)) = i; break;
+#endif
}
}
else if (svix < svmax)
SV *msg = sv_newmortal();
Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
(PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
- if (c)
- Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
- c & 0xFF);
- else
+ if (c) {
+#ifdef UV_IS_QUAD
+ if (isPRINT(c))
+ Perl_sv_catpvf(aTHX_ msg,
+ "\"%%%c\"", c & 0xFF);
+ else
+ Perl_sv_catpvf(aTHX_ msg,
+ "\"%%\\%03" PERL_PRIo64 "\"",
+ (UV)c & 0xFF);
+#else
+ Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ?
+ "\"%%%c\"" : "\"%%\\%03o\"",
+ c & 0xFF);
+#endif
+ } else
sv_catpv(msg, "end of string");
Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
}
projects / p5sagit/p5-mst-13.2.git / blobdiff