extern void _fwalk(int (*)(FILE *));
_fwalk(&fflush);
return 0;
-# else
- long open_max = -1;
+# else
# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
+ long open_max = -1;
# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
# else
-# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
+# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
open_max = sysconf(_SC_OPEN_MAX);
-# else
-# ifdef FOPEN_MAX
+# else
+# ifdef FOPEN_MAX
open_max = FOPEN_MAX;
-# else
-# ifdef OPEN_MAX
+# else
+# ifdef OPEN_MAX
open_max = OPEN_MAX;
-# else
-# ifdef _NFILE
+# else
+# ifdef _NFILE
open_max = _NFILE;
+# endif
+# endif
# endif
# endif
# endif
-# endif
-# endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
{
NV x = 0.0;
#ifdef USE_LOCALE_NUMERIC
- if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
+ if (PL_numeric_local && IN_LOCALE) {
NV y;
- Perl_atof2(s, x);
+ /* Scan the number twice; once using locale and once without;
+ * choose the larger result (in absolute value). */
+ Perl_atof2(aTHX_ s, &x);
SET_NUMERIC_STANDARD();
- Perl_atof2(s, y);
+ Perl_atof2(aTHX_ s, &y);
SET_NUMERIC_LOCAL();
if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
return y;
}
else
- Perl_atof2(s, x);
+ Perl_atof2(aTHX_ s, &x);
#else
- Perl_atof2(s, x);
+ Perl_atof2(aTHX_ s, &x);
#endif
return x;
}
+NV
+S_mulexp10(NV value, I32 exponent)
+{
+ NV result = 1.0;
+ NV power = 10.0;
+ bool negative = 0;
+ I32 bit;
+
+ if (exponent == 0)
+ return value;
+ else if (exponent < 0) {
+ negative = 1;
+ exponent = -exponent;
+ }
+ for (bit = 1; exponent; bit <<= 1) {
+ if (exponent & bit) {
+ exponent ^= bit;
+ result *= power;
+ }
+ power *= power;
+ }
+ return negative ? value / result : value * result;
+}
+
+/*
+=for apidoc grok_numeric_radix
+
+Scan and skip for a numeric decimal separator (radix).
+
+=cut
+ */
+bool
+Perl_grok_numeric_radix(pTHX_ const char **sp, const char *send)
+{
+#ifdef USE_LOCALE_NUMERIC
+ if (PL_numeric_radix_sv && IN_LOCALE) {
+ STRLEN len;
+ char* radix = SvPV(PL_numeric_radix_sv, len);
+ if (*sp + len <= send && memEQ(*sp, radix, len)) {
+ *sp += len;
+ return TRUE;
+ }
+ }
+ /* always try "." if numeric radix didn't match because
+ * we may have data from different locales mixed */
+#endif
+ if (*sp < send && **sp == '.') {
+ ++*sp;
+ return TRUE;
+ }
+ return FALSE;
+}
+
+/*
+=for apidoc grok_number
+
+Recognise (or not) a number. The type of the number is returned
+(0 if unrecognised), otherwise it is a bit-ORed combination of
+IS_NUMBER_IN_UV, IS_NUMBER_GREATER_THAN_UV_MAX, IS_NUMBER_NOT_INT,
+IS_NUMBER_NEG, IS_NUMBER_INFINITY (defined in perl.h). If the value
+of the number can fit an in UV, it is returned in the *valuep.
+
+=cut
+ */
+int
+Perl_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
+{
+ const char *s = pv;
+ const char *send = pv + len;
+ const UV max_div_10 = UV_MAX / 10;
+ const char max_mod_10 = UV_MAX % 10 + '0';
+ int numtype = 0;
+ int sawinf = 0;
+
+ while (isSPACE(*s))
+ s++;
+ if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
+ s++;
+
+ /* next must be digit or the radix separator or beginning of infinity */
+ if (isDIGIT(*s)) {
+ /* UVs are at least 32 bits, so the first 9 decimal digits cannot
+ overflow. */
+ UV value = *s - '0';
+ /* This construction seems to be more optimiser friendly.
+ (without it gcc does the isDIGIT test and the *s - '0' separately)
+ With it gcc on arm is managing 6 instructions (6 cycles) per digit.
+ In theory the optimiser could deduce how far to unroll the loop
+ before checking for overflow. */
+ int digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ if (digit >= 0 && digit <= 9) {
+ value = value * 10 + digit;
+ /* Now got 9 digits, so need to check
+ each time for overflow. */
+ digit = *++s - '0';
+ while (digit >= 0 && digit <= 9
+ && (value < max_div_10
+ || (value == max_div_10
+ && *s <= max_mod_10))) {
+ value = value * 10 + digit;
+ digit = *++s - '0';
+ }
+ if (digit >= 0 && digit <= 9) {
+ /* value overflowed.
+ skip the remaining digits, don't
+ worry about setting *valuep. */
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ numtype |=
+ IS_NUMBER_GREATER_THAN_UV_MAX;
+ goto skip_value;
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ }
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep)
+ *valuep = value;
+
+ skip_value:
+ if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ while (isDIGIT(*s)) /* optional digits after the radix */
+ s++;
+ }
+ }
+ else if (GROK_NUMERIC_RADIX(&s, send)) {
+ numtype |= IS_NUMBER_NOT_INT;
+ /* no digits before the radix means we need digits after it */
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ numtype |= IS_NUMBER_IN_UV;
+ if (valuep) {
+ /* integer approximation is valid - it's 0. */
+ *valuep = 0;
+ }
+ }
+ else
+ return 0;
+ }
+ else if (*s == 'I' || *s == 'i') {
+ s++; if (*s != 'N' && *s != 'n') return 0;
+ s++; if (*s != 'F' && *s != 'f') return 0;
+ s++; if (*s == 'I' || *s == 'i') {
+ s++; if (*s != 'N' && *s != 'n') return 0;
+ s++; if (*s != 'I' && *s != 'i') return 0;
+ s++; if (*s != 'T' && *s != 't') return 0;
+ s++; if (*s != 'Y' && *s != 'y') return 0;
+ s++;
+ }
+ sawinf = 1;
+ }
+ else /* Add test for NaN here. */
+ return 0;
+
+ if (sawinf) {
+ numtype &= IS_NUMBER_NEG; /* Keep track of sign */
+ numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
+ } else {
+ /* we can have an optional exponent part */
+ if (*s == 'e' || *s == 'E') {
+ /* The only flag we keep is sign. Blow away any "it's UV" */
+ numtype &= IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_NOT_INT;
+ s++;
+ if (*s == '-' || *s == '+')
+ s++;
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ }
+ while (isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(pv, "0 but true", 10)) {
+ if (valuep)
+ *valuep = 0;
+ return IS_NUMBER_IN_UV;
+ }
+ return 0;
+}
+
+char*
+Perl_my_atof2(pTHX_ const char* orig, NV* value)
+{
+ NV result = 0.0;
+ bool negative = 0;
+ char* s = (char*)orig;
+ char* send = s + strlen(orig) - 1;
+ bool seendigit = 0;
+ I32 expextra = 0;
+ I32 exponent = 0;
+ I32 i;
+/* this is arbitrary */
+#define PARTLIM 6
+/* we want the largest integers we can usefully use */
+#if defined(HAS_QUAD) && defined(USE_64_BIT_INT)
+# define PARTSIZE ((int)TYPE_DIGITS(U64)-1)
+ U64 part[PARTLIM];
+#else
+# define PARTSIZE ((int)TYPE_DIGITS(U32)-1)
+ U32 part[PARTLIM];
+#endif
+ I32 ipart = 0; /* index into part[] */
+ I32 offcount; /* number of digits in least significant part */
+
+ /* sign */
+ switch (*s) {
+ case '-':
+ negative = 1;
+ /* fall through */
+ case '+':
+ ++s;
+ }
+
+ part[0] = offcount = 0;
+ if (isDIGIT(*s)) {
+ seendigit = 1; /* get this over with */
+
+ /* skip leading zeros */
+ while (*s == '0')
+ ++s;
+ }
+
+ /* integer digits */
+ while (isDIGIT(*s)) {
+ if (++offcount > PARTSIZE) {
+ if (++ipart < PARTLIM) {
+ part[ipart] = 0;
+ offcount = 1; /* ++0 */
+ }
+ else {
+ /* limits of precision reached */
+ --ipart;
+ --offcount;
+ if (*s >= '5')
+ ++part[ipart];
+ while (isDIGIT(*s)) {
+ ++expextra;
+ ++s;
+ }
+ /* warn of loss of precision? */
+ break;
+ }
+ }
+ part[ipart] = part[ipart] * 10 + (*s++ - '0');
+ }
+
+ /* decimal point */
+ if (GROK_NUMERIC_RADIX((const char **)&s, send)) {
+ if (isDIGIT(*s))
+ seendigit = 1; /* get this over with */
+
+ /* decimal digits */
+ while (isDIGIT(*s)) {
+ if (++offcount > PARTSIZE) {
+ if (++ipart < PARTLIM) {
+ part[ipart] = 0;
+ offcount = 1; /* ++0 */
+ }
+ else {
+ /* limits of precision reached */
+ --ipart;
+ --offcount;
+ if (*s >= '5')
+ ++part[ipart];
+ while (isDIGIT(*s))
+ ++s;
+ /* warn of loss of precision? */
+ break;
+ }
+ }
+ --expextra;
+ part[ipart] = part[ipart] * 10 + (*s++ - '0');
+ }
+ }
+
+ /* combine components of mantissa */
+ for (i = 0; i <= ipart; ++i)
+ result += S_mulexp10((NV)part[ipart - i],
+ i ? offcount + (i - 1) * PARTSIZE : 0);
+
+ if (seendigit && (*s == 'e' || *s == 'E')) {
+ bool expnegative = 0;
+
+ ++s;
+ switch (*s) {
+ case '-':
+ expnegative = 1;
+ /* fall through */
+ case '+':
+ ++s;
+ }
+ while (isDIGIT(*s))
+ exponent = exponent * 10 + (*s++ - '0');
+ if (expnegative)
+ exponent = -exponent;
+ }
+
+ /* now apply the exponent */
+ exponent += expextra;
+ result = S_mulexp10(result, exponent);
+
+ /* now apply the sign */
+ if (negative)
+ result = -result;
+ *value = result;
+ return s;
+}
+
void
Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op)
{
New(0, buf, buflen, char);
len = strftime(buf, buflen, fmt, &mytm);
/*
- ** The following is needed to handle to the situation where
+ ** The following is needed to handle to the situation where
** tmpbuf overflows. Basically we want to allocate a buffer
** and try repeatedly. The reason why it is so complicated
** is that getting a return value of 0 from strftime can indicate
/* Possibly buf overflowed - try again with a bigger buf */
int fmtlen = strlen(fmt);
int bufsize = fmtlen + buflen;
-
+
New(0, buf, bufsize, char);
while (buf) {
buflen = strftime(buf, bufsize, fmt, &mytm);
int
Perl_sv_getcwd(pTHX_ register SV *sv)
{
+#ifndef PERL_MICRO
+
#ifndef HAS_GETCWD
struct stat statbuf;
int orig_cdev, orig_cino, cdev, cino, odev, oino, tdev, tino;
#else
if (PerlLIO_lstat(".", &statbuf) < 0) {
- CWDXS_RETURN_SVUNDEF(sv);
+ SV_CWD_RETURN_UNDEF;
}
orig_cdev = statbuf.st_dev;
namelen = strlen(dp->d_name);
#endif
/* skip . and .. */
- if (SV_CWD_ISDOT(dp)) {dp->d_name[0] == '.'
+ if (SV_CWD_ISDOT(dp)) {
continue;
}
#endif
return TRUE;
+#else
+ return FALSE;
+#endif
}
/*
=for apidoc sv_realpath
-Emulate realpath(3)
+Wrap or emulate realpath(3).
-XXX: add configure test for realpath(3) and prefer if available
=cut
*/
int
Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len)
{
+#ifndef PERL_MICRO
+ char name[MAXPATHLEN] = { 0 }, *s;
+ STRLEN pathlen, namelen;
+
+#ifdef HAS_REALPATH
+ /* Be paranoid about the use of realpath(),
+ * it is an infamous source of buffer overruns. */
+
+ /* Is the source buffer too long?
+ * Don't use strlen() to avoid running off the end. */
+ s = memchr(path, '\0', MAXPATHLEN);
+ pathlen = s ? s - path : MAXPATHLEN;
+ if (pathlen == MAXPATHLEN) {
+ Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)",
+ path, s ? '=' : '>', MAXPATHLEN);
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ /* Here goes nothing. */
+ if (realpath(path, name) == NULL) {
+ Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %s",
+ path, Strerror(errno));
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ /* Is the destination buffer too long?
+ * Don't use strlen() to avoid running off the end. */
+ s = memchr(name, '\0', MAXPATHLEN);
+ namelen = s ? s - name : MAXPATHLEN;
+ if (namelen == MAXPATHLEN) {
+ Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)",
+ path, s ? '=' : '>', MAXPATHLEN);
+ SV_CWD_RETURN_UNDEF;
+ }
+
+ /* The coast is clear? */
+ sv_setpvn(sv, name, namelen);
+ SvPOK_only(sv);
+
+ return TRUE;
+#else
DIR *parent;
Direntry_t *dp;
char dotdots[MAXPATHLEN] = { 0 };
- char name[MAXPATHLEN] = { 0 };
- int namelen = 0, pathlen = 0;
struct stat cst, pst, tst;
if (PerlLIO_stat(path, &cst) < 0) {
dotdots, Strerror(errno));
SV_CWD_RETURN_UNDEF;
}
-
+
if (pst.st_dev == cst.st_dev && pst.st_ino == cst.st_ino) {
/* We've reached the root: previous is same as current */
break;
dotdots, Strerror(errno));
SV_CWD_RETURN_UNDEF;
}
-
+
SETERRNO(0,SS$_NORMAL); /* for readdir() */
while ((dp = PerlDir_read(parent)) != NULL) {
if (SV_CWD_ISDOT(dp)) {
continue;
}
-
+
Copy(dotdots, name, dotdotslen, char);
name[dotdotslen] = '/';
#ifdef DIRNAMLEN
#endif
Copy(dp->d_name, name + dotdotslen + 1, namelen, char);
name[dotdotslen + 1 + namelen] = 0;
-
+
if (PerlLIO_lstat(name, &tst) < 0) {
PerlDir_close(parent);
Perl_warn(aTHX_ "sv_realpath: lstat(\"%s\"): %s",
name, Strerror(errno));
SV_CWD_RETURN_UNDEF;
}
-
+
if (tst.st_dev == pst.st_dev && tst.st_ino == pst.st_ino)
break;
SvPOK_only(sv);
return TRUE;
+#endif
+#else
+ return FALSE;
+#endif
}
+
projects / p5sagit/p5-mst-13.2.git / blobdiff