X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8fa7f3676ed75809365905727fbae97dc8767f29..40ff561f31d4dfe206b69dd70d61c002ce5fc6be:/util.c diff --git a/util.c b/util.c index 9786081..7a8b815 100644 --- a/util.c +++ b/util.c @@ -41,10 +41,6 @@ # include #endif -#ifdef I_LOCALE -# include -#endif - #define FLUSH #ifdef LEAKTEST @@ -457,528 +453,6 @@ Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *lit return Nullch; } -/* - * Set up for a new ctype locale. - */ -void -Perl_new_ctype(pTHX_ char *newctype) -{ -#ifdef USE_LOCALE_CTYPE - - int i; - - for (i = 0; i < 256; i++) { - if (isUPPER_LC(i)) - PL_fold_locale[i] = toLOWER_LC(i); - else if (isLOWER_LC(i)) - PL_fold_locale[i] = toUPPER_LC(i); - else - PL_fold_locale[i] = i; - } - -#endif /* USE_LOCALE_CTYPE */ -} - -/* - * Standardize the locale name from a string returned by 'setlocale'. - * - * The standard return value of setlocale() is either - * (1) "xx_YY" if the first argument of setlocale() is not LC_ALL - * (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL - * (the space-separated values represent the various sublocales, - * in some unspecificed order) - * - * In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n", - * which is harmful for further use of the string in setlocale(). - * - */ -STATIC char * -S_stdize_locale(pTHX_ char *locs) -{ - char *s; - bool okay = TRUE; - - if ((s = strchr(locs, '='))) { - char *t; - - okay = FALSE; - if ((t = strchr(s, '.'))) { - char *u; - - if ((u = strchr(t, '\n'))) { - - if (u[1] == 0) { - STRLEN len = u - s; - Move(s + 1, locs, len, char); - locs[len] = 0; - okay = TRUE; - } - } - } - } - - if (!okay) - Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs); - - return locs; -} - -/* - * Set up for a new collation locale. - */ -void -Perl_new_collate(pTHX_ char *newcoll) -{ -#ifdef USE_LOCALE_COLLATE - - if (! newcoll) { - if (PL_collation_name) { - ++PL_collation_ix; - Safefree(PL_collation_name); - PL_collation_name = NULL; - } - PL_collation_standard = TRUE; - PL_collxfrm_base = 0; - PL_collxfrm_mult = 2; - return; - } - - if (! PL_collation_name || strNE(PL_collation_name, newcoll)) { - ++PL_collation_ix; - Safefree(PL_collation_name); - PL_collation_name = stdize_locale(savepv(newcoll)); - PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX")); - - { - /* 2: at most so many chars ('a', 'b'). */ - /* 50: surely no system expands a char more. */ -#define XFRMBUFSIZE (2 * 50) - char xbuf[XFRMBUFSIZE]; - Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE); - Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE); - SSize_t mult = fb - fa; - if (mult < 1) - Perl_croak(aTHX_ "strxfrm() gets absurd"); - PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0; - PL_collxfrm_mult = mult; - } - } - -#endif /* USE_LOCALE_COLLATE */ -} - -void -Perl_set_numeric_radix(pTHX) -{ -#ifdef USE_LOCALE_NUMERIC -# ifdef HAS_LOCALECONV - struct lconv* lc; - - lc = localeconv(); - if (lc && lc->decimal_point) { - if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) { - SvREFCNT_dec(PL_numeric_radix_sv); - PL_numeric_radix_sv = Nullsv; - } - else { - if (PL_numeric_radix_sv) - sv_setpv(PL_numeric_radix_sv, lc->decimal_point); - else - PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0); - } - } - else - PL_numeric_radix_sv = Nullsv; -# endif /* HAS_LOCALECONV */ -#endif /* USE_LOCALE_NUMERIC */ -} - -/* - * Set up for a new numeric locale. - */ -void -Perl_new_numeric(pTHX_ char *newnum) -{ -#ifdef USE_LOCALE_NUMERIC - - if (! newnum) { - if (PL_numeric_name) { - Safefree(PL_numeric_name); - PL_numeric_name = NULL; - } - PL_numeric_standard = TRUE; - PL_numeric_local = TRUE; - return; - } - - if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) { - Safefree(PL_numeric_name); - PL_numeric_name = stdize_locale(savepv(newnum)); - PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX")); - PL_numeric_local = TRUE; - set_numeric_radix(); - } - -#endif /* USE_LOCALE_NUMERIC */ -} - -void -Perl_set_numeric_standard(pTHX) -{ -#ifdef USE_LOCALE_NUMERIC - - if (! PL_numeric_standard) { - setlocale(LC_NUMERIC, "C"); - PL_numeric_standard = TRUE; - PL_numeric_local = FALSE; - set_numeric_radix(); - } - -#endif /* USE_LOCALE_NUMERIC */ -} - -void -Perl_set_numeric_local(pTHX) -{ -#ifdef USE_LOCALE_NUMERIC - - if (! PL_numeric_local) { - setlocale(LC_NUMERIC, PL_numeric_name); - PL_numeric_standard = FALSE; - PL_numeric_local = TRUE; - set_numeric_radix(); - } - -#endif /* USE_LOCALE_NUMERIC */ -} - -/* - * Initialize locale awareness. - */ -int -Perl_init_i18nl10n(pTHX_ int printwarn) -{ - int ok = 1; - /* returns - * 1 = set ok or not applicable, - * 0 = fallback to C locale, - * -1 = fallback to C locale failed - */ - -#if defined(USE_LOCALE) - -#ifdef USE_LOCALE_CTYPE - char *curctype = NULL; -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - char *curcoll = NULL; -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - char *curnum = NULL; -#endif /* USE_LOCALE_NUMERIC */ -#ifdef __GLIBC__ - char *language = PerlEnv_getenv("LANGUAGE"); -#endif - char *lc_all = PerlEnv_getenv("LC_ALL"); - char *lang = PerlEnv_getenv("LANG"); - bool setlocale_failure = FALSE; - -#ifdef LOCALE_ENVIRON_REQUIRED - - /* - * Ultrix setlocale(..., "") fails if there are no environment - * variables from which to get a locale name. - */ - - bool done = FALSE; - -#ifdef LC_ALL - if (lang) { - if (setlocale(LC_ALL, "")) - done = TRUE; - else - setlocale_failure = TRUE; - } - if (!setlocale_failure) { -#ifdef USE_LOCALE_CTYPE - if (! (curctype = - setlocale(LC_CTYPE, - (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) - ? "" : Nullch))) - setlocale_failure = TRUE; - else - curctype = savepv(curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (! (curcoll = - setlocale(LC_COLLATE, - (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) - ? "" : Nullch))) - setlocale_failure = TRUE; - else - curcoll = savepv(curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (! (curnum = - setlocale(LC_NUMERIC, - (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) - ? "" : Nullch))) - setlocale_failure = TRUE; - else - curnum = savepv(curnum); -#endif /* USE_LOCALE_NUMERIC */ - } - -#endif /* LC_ALL */ - -#endif /* !LOCALE_ENVIRON_REQUIRED */ - -#ifdef LC_ALL - if (! setlocale(LC_ALL, "")) - setlocale_failure = TRUE; -#endif /* LC_ALL */ - - if (!setlocale_failure) { -#ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, ""))) - setlocale_failure = TRUE; - else - curctype = savepv(curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, ""))) - setlocale_failure = TRUE; - else - curcoll = savepv(curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, ""))) - setlocale_failure = TRUE; - else - curnum = savepv(curnum); -#endif /* USE_LOCALE_NUMERIC */ - } - - if (setlocale_failure) { - char *p; - bool locwarn = (printwarn > 1 || - (printwarn && - (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); - - if (locwarn) { -#ifdef LC_ALL - - PerlIO_printf(Perl_error_log, - "perl: warning: Setting locale failed.\n"); - -#else /* !LC_ALL */ - - PerlIO_printf(Perl_error_log, - "perl: warning: Setting locale failed for the categories:\n\t"); -#ifdef USE_LOCALE_CTYPE - if (! curctype) - PerlIO_printf(Perl_error_log, "LC_CTYPE "); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (! curcoll) - PerlIO_printf(Perl_error_log, "LC_COLLATE "); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (! curnum) - PerlIO_printf(Perl_error_log, "LC_NUMERIC "); -#endif /* USE_LOCALE_NUMERIC */ - PerlIO_printf(Perl_error_log, "\n"); - -#endif /* LC_ALL */ - - PerlIO_printf(Perl_error_log, - "perl: warning: Please check that your locale settings:\n"); - -#ifdef __GLIBC__ - PerlIO_printf(Perl_error_log, - "\tLANGUAGE = %c%s%c,\n", - language ? '"' : '(', - language ? language : "unset", - language ? '"' : ')'); -#endif - - PerlIO_printf(Perl_error_log, - "\tLC_ALL = %c%s%c,\n", - lc_all ? '"' : '(', - lc_all ? lc_all : "unset", - lc_all ? '"' : ')'); - -#if defined(USE_ENVIRON_ARRAY) - { - char **e; - for (e = environ; *e; e++) { - if (strnEQ(*e, "LC_", 3) - && strnNE(*e, "LC_ALL=", 7) - && (p = strchr(*e, '='))) - PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n", - (int)(p - *e), *e, p + 1); - } - } -#else - PerlIO_printf(Perl_error_log, - "\t(possibly more locale environment variables)\n"); -#endif - - PerlIO_printf(Perl_error_log, - "\tLANG = %c%s%c\n", - lang ? '"' : '(', - lang ? lang : "unset", - lang ? '"' : ')'); - - PerlIO_printf(Perl_error_log, - " are supported and installed on your system.\n"); - } - -#ifdef LC_ALL - - if (setlocale(LC_ALL, "C")) { - if (locwarn) - PerlIO_printf(Perl_error_log, - "perl: warning: Falling back to the standard locale (\"C\").\n"); - ok = 0; - } - else { - if (locwarn) - PerlIO_printf(Perl_error_log, - "perl: warning: Failed to fall back to the standard locale (\"C\").\n"); - ok = -1; - } - -#else /* ! LC_ALL */ - - if (0 -#ifdef USE_LOCALE_CTYPE - || !(curctype || setlocale(LC_CTYPE, "C")) -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - || !(curcoll || setlocale(LC_COLLATE, "C")) -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - || !(curnum || setlocale(LC_NUMERIC, "C")) -#endif /* USE_LOCALE_NUMERIC */ - ) - { - if (locwarn) - PerlIO_printf(Perl_error_log, - "perl: warning: Cannot fall back to the standard locale (\"C\").\n"); - ok = -1; - } - -#endif /* ! LC_ALL */ - -#ifdef USE_LOCALE_CTYPE - curctype = savepv(setlocale(LC_CTYPE, Nullch)); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - curcoll = savepv(setlocale(LC_COLLATE, Nullch)); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - curnum = savepv(setlocale(LC_NUMERIC, Nullch)); -#endif /* USE_LOCALE_NUMERIC */ - } - else { - -#ifdef USE_LOCALE_CTYPE - new_ctype(curctype); -#endif /* USE_LOCALE_CTYPE */ - -#ifdef USE_LOCALE_COLLATE - new_collate(curcoll); -#endif /* USE_LOCALE_COLLATE */ - -#ifdef USE_LOCALE_NUMERIC - new_numeric(curnum); -#endif /* USE_LOCALE_NUMERIC */ - } - -#endif /* USE_LOCALE */ - -#ifdef USE_LOCALE_CTYPE - if (curctype != NULL) - Safefree(curctype); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - if (curcoll != NULL) - Safefree(curcoll); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - if (curnum != NULL) - Safefree(curnum); -#endif /* USE_LOCALE_NUMERIC */ - return ok; -} - -/* Backwards compatibility. */ -int -Perl_init_i18nl14n(pTHX_ int printwarn) -{ - return init_i18nl10n(printwarn); -} - -#ifdef USE_LOCALE_COLLATE - -/* - * mem_collxfrm() is a bit like strxfrm() but with two important - * differences. First, it handles embedded NULs. Second, it allocates - * a bit more memory than needed for the transformed data itself. - * The real transformed data begins at offset sizeof(collationix). - * Please see sv_collxfrm() to see how this is used. - */ -char * -Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen) -{ - char *xbuf; - STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */ - - /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */ - /* the +1 is for the terminating NUL. */ - - xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1; - New(171, xbuf, xAlloc, char); - if (! xbuf) - goto bad; - - *(U32*)xbuf = PL_collation_ix; - xout = sizeof(PL_collation_ix); - for (xin = 0; xin < len; ) { - SSize_t xused; - - for (;;) { - xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout); - if (xused == -1) - goto bad; - if (xused < xAlloc - xout) - break; - xAlloc = (2 * xAlloc) + 1; - Renew(xbuf, xAlloc, char); - if (! xbuf) - goto bad; - } - - xin += strlen(s + xin) + 1; - xout += xused; - - /* Embedded NULs are understood but silently skipped - * because they make no sense in locale collation. */ - } - - xbuf[xout] = '\0'; - *xlen = xout - sizeof(PL_collation_ix); - return xbuf; - - bad: - Safefree(xbuf); - *xlen = 0; - return NULL; -} - -#endif /* USE_LOCALE_COLLATE */ - #define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/ /* As a space optimization, we do not compile tables for strings of length @@ -2085,7 +1559,7 @@ Perl_unlnk(pTHX_ char *f) /* unlink all versions of a file */ #endif /* this is a drop-in replacement for bcopy() */ -#if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY) +#if (!defined(HAS_MEMCPY) && !defined(HAS_BCOPY)) || (!defined(HAS_MEMMOVE) && !defined(HAS_SAFE_MEMCPY) && !defined(HAS_SAFE_BCOPY)) char * Perl_my_bcopy(register const char *from,register char *to,register I32 len) { @@ -2929,79 +2403,6 @@ Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, regi } } -U32 -Perl_cast_ulong(pTHX_ NV f) -{ - if (f < 0.0) - return f < I32_MIN ? (U32) I32_MIN : (U32)(I32) f; - if (f < U32_MAX_P1) { -#if CASTFLAGS & 2 - if (f < U32_MAX_P1_HALF) - return (U32) f; - f -= U32_MAX_P1_HALF; - return ((U32) f) | (1 + U32_MAX >> 1); -#else - return (U32) f; -#endif - } - return f > 0 ? U32_MAX : 0 /* NaN */; -} - -I32 -Perl_cast_i32(pTHX_ NV f) -{ - if (f < I32_MAX_P1) - return f < I32_MIN ? I32_MIN : (I32) f; - if (f < U32_MAX_P1) { -#if CASTFLAGS & 2 - if (f < U32_MAX_P1_HALF) - return (I32)(U32) f; - f -= U32_MAX_P1_HALF; - return (I32)(((U32) f) | (1 + U32_MAX >> 1)); -#else - return (I32)(U32) f; -#endif - } - return f > 0 ? (I32)U32_MAX : 0 /* NaN */; -} - -IV -Perl_cast_iv(pTHX_ NV f) -{ - if (f < IV_MAX_P1) - return f < IV_MIN ? IV_MIN : (IV) f; - if (f < UV_MAX_P1) { -#if CASTFLAGS & 2 - /* For future flexibility allowing for sizeof(UV) >= sizeof(IV) */ - if (f < UV_MAX_P1_HALF) - return (IV)(UV) f; - f -= UV_MAX_P1_HALF; - return (IV)(((UV) f) | (1 + UV_MAX >> 1)); -#else - return (IV)(UV) f; -#endif - } - return f > 0 ? (IV)UV_MAX : 0 /* NaN */; -} - -UV -Perl_cast_uv(pTHX_ NV f) -{ - if (f < 0.0) - return f < IV_MIN ? (UV) IV_MIN : (UV)(IV) f; - if (f < UV_MAX_P1) { -#if CASTFLAGS & 2 - if (f < UV_MAX_P1_HALF) - return (UV) f; - f -= UV_MAX_P1_HALF; - return ((UV) f) | (1 + UV_MAX >> 1); -#else - return (UV) f; -#endif - } - return f > 0 ? UV_MAX : 0 /* NaN */; -} - #ifndef HAS_RENAME I32 Perl_same_dirent(pTHX_ char *a, char *b) @@ -3039,216 +2440,6 @@ Perl_same_dirent(pTHX_ char *a, char *b) } #endif /* !HAS_RENAME */ -NV -Perl_scan_bin(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool seenb = FALSE; - register bool overflowed = FALSE; - - for (; len-- && *s; s++) { - if (!(*s == '0' || *s == '1')) { - if (*s == '_' && len && *retlen - && (s[1] == '0' || s[1] == '1')) - { - --len; - ++s; - } - else if (seenb == FALSE && *s == 'b' && ruv == 0) { - /* Disallow 0bbb0b0bbb... */ - seenb = TRUE; - continue; - } - else { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal binary digit '%c' ignored", *s); - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 1; - - if ((xuv >> 1) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in binary number"); - } - else - ruv = xuv | (*s - '0'); - } - if (overflowed) { - rnv *= 2; - /* If an NV has not enough bits in its mantissa to - * represent an UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount. */ - rnv += (*s - '0'); - } - } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) -#endif - ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ WARN_PORTABLE, - "Binary number > 0b11111111111111111111111111111111 non-portable"); - } - *retlen = s - start; - return rnv; -} - -NV -Perl_scan_oct(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool overflowed = FALSE; - - for (; len-- && *s; s++) { - if (!(*s >= '0' && *s <= '7')) { - if (*s == '_' && len && *retlen - && (s[1] >= '0' && s[1] <= '7')) - { - --len; - ++s; - } - else { - /* Allow \octal to work the DWIM way (that is, stop scanning - * as soon as non-octal characters are seen, complain only iff - * someone seems to want to use the digits eight and nine). */ - if (*s == '8' || *s == '9') { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal octal digit '%c' ignored", *s); - } - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 3; - - if ((xuv >> 3) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in octal number"); - } - else - ruv = xuv | (*s - '0'); - } - if (overflowed) { - rnv *= 8.0; - /* If an NV has not enough bits in its mantissa to - * represent an UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount of 8-tuples. */ - rnv += (NV)(*s - '0'); - } - } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) -#endif - ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ WARN_PORTABLE, - "Octal number > 037777777777 non-portable"); - } - *retlen = s - start; - return rnv; -} - -NV -Perl_scan_hex(pTHX_ char *start, STRLEN len, STRLEN *retlen) -{ - register char *s = start; - register NV rnv = 0.0; - register UV ruv = 0; - register bool overflowed = FALSE; - char *hexdigit; - - if (len > 2) { - if (s[0] == 'x') { - s++; - len--; - } - else if (len > 3 && s[0] == '0' && s[1] == 'x') { - s+=2; - len-=2; - } - } - - for (; len-- && *s; s++) { - hexdigit = strchr((char *) PL_hexdigit, *s); - if (!hexdigit) { - if (*s == '_' && len && *retlen && s[1] - && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) - { - --len; - ++s; - } - else { - if (ckWARN(WARN_DIGIT)) - Perl_warner(aTHX_ WARN_DIGIT, - "Illegal hexadecimal digit '%c' ignored", *s); - break; - } - } - if (!overflowed) { - register UV xuv = ruv << 4; - - if ((xuv >> 4) != ruv) { - overflowed = TRUE; - rnv = (NV) ruv; - if (ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ WARN_OVERFLOW, - "Integer overflow in hexadecimal number"); - } - else - ruv = xuv | ((hexdigit - PL_hexdigit) & 15); - } - if (overflowed) { - rnv *= 16.0; - /* If an NV has not enough bits in its mantissa to - * represent an UV this summing of small low-order numbers - * is a waste of time (because the NV cannot preserve - * the low-order bits anyway): we could just remember when - * did we overflow and in the end just multiply rnv by the - * right amount of 16-tuples. */ - rnv += (NV)((hexdigit - PL_hexdigit) & 15); - } - } - if (!overflowed) - rnv = (NV) ruv; - if ( ( overflowed && rnv > 4294967295.0) -#if UVSIZE > 4 - || (!overflowed && ruv > 0xffffffff ) -#endif - ) { - if (ckWARN(WARN_PORTABLE)) - Perl_warner(aTHX_ WARN_PORTABLE, - "Hexadecimal number > 0xffffffff non-portable"); - } - *retlen = s - start; - return rnv; -} - char* Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags) { @@ -3791,22 +2982,6 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) } #endif /* USE_THREADS */ -#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) -/* - * This hack is to force load of "huge" support from libm.a - * So it is in perl for (say) POSIX to use. - * Needed for SunOS with Sun's 'acc' for example. - */ -NV -Perl_huge(void) -{ -# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) - return HUGE_VALL; -# endif - return HUGE_VAL; -} -#endif - #ifdef PERL_GLOBAL_STRUCT struct perl_vars * Perl_GetVars(pTHX) @@ -4010,96 +3185,6 @@ Perl_my_fflush_all(pTHX) #endif } -NV -Perl_my_atof(pTHX_ const char* s) -{ - NV x = 0.0; -#ifdef USE_LOCALE_NUMERIC - if ((PL_hints & HINT_LOCALE) && PL_numeric_local) { - NV y; - - Perl_atof2(aTHX_ s, &x); - SET_NUMERIC_STANDARD(); - Perl_atof2(aTHX_ s, &y); - SET_NUMERIC_LOCAL(); - if ((y < 0.0 && y < x) || (y > 0.0 && y > x)) - return y; - } - else - Perl_atof2(aTHX_ s, &x); -#else - Perl_atof2(aTHX_ s, &x); -#endif - return x; -} - -char* -Perl_my_atof2(pTHX_ const char* orig, NV* value) -{ - NV result = 0.0; - bool negative = 0; - char* s = (char*)orig; - char* point = "."; /* locale-dependent decimal point equivalent */ - STRLEN pointlen = 1; - bool seendigit = 0; - - if (PL_numeric_radix_sv) - point = SvPV(PL_numeric_radix_sv, pointlen); - - switch (*s) { - case '-': - negative = 1; - /* fall through */ - case '+': - ++s; - } - while (isDIGIT(*s)) { - result = result * 10 + (*s++ - '0'); - seendigit = 1; - } - if (memEQ(s, point, pointlen)) { - NV decimal = 0.1; - - s += pointlen; - while (isDIGIT(*s)) { - result += (*s++ - '0') * decimal; - decimal *= 0.1; - seendigit = 1; - } - } - if (seendigit && (*s == 'e' || *s == 'E')) { - I32 exponent = 0; - I32 expnegative = 0; - I32 bit; - NV power; - - ++s; - switch (*s) { - case '-': - expnegative = 1; - /* fall through */ - case '+': - ++s; - } - while (isDIGIT(*s)) - exponent = exponent * 10 + (*s++ - '0'); - - /* now apply the exponent */ - power = (expnegative) ? 0.1 : 10.0; - for (bit = 1; exponent; bit <<= 1) { - if (exponent & bit) { - exponent ^= bit; - result *= power; - } - power *= power; - } - } - if (negative) - result = -result; - *value = result; - return s; -} - void Perl_report_evil_fh(pTHX_ GV *gv, IO *io, I32 op) { @@ -4541,7 +3626,7 @@ Perl_sv_getcwd(pTHX_ register SV *sv) #else if (PerlLIO_lstat(".", &statbuf) < 0) { - CWDXS_RETURN_SVUNDEF(sv); + SV_CWD_RETURN_UNDEF; } orig_cdev = statbuf.st_dev; @@ -4577,7 +3662,7 @@ Perl_sv_getcwd(pTHX_ register SV *sv) namelen = strlen(dp->d_name); #endif /* skip . and .. */ - if (SV_CWD_ISDOT(dp)) {dp->d_name[0] == '.' + if (SV_CWD_ISDOT(dp)) { continue; } @@ -4657,14 +3742,16 @@ Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len) char name[MAXPATHLEN] = { 0 }, *s; STRLEN pathlen, namelen; + /* Don't use strlen() to avoid running off the end. */ + s = memchr(path, '\0', MAXPATHLEN); + pathlen = s ? s - path : MAXPATHLEN; + #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; + /* Is the source buffer too long? */ if (pathlen == MAXPATHLEN) { Perl_warn(aTHX_ "sv_realpath: realpath(\"%s\"): %c= (MAXPATHLEN = %d)", path, s ? '=' : '>', MAXPATHLEN); @@ -4694,6 +3781,7 @@ Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len) return TRUE; #else + { DIR *parent; Direntry_t *dp; char dotdots[MAXPATHLEN] = { 0 }; @@ -4796,8 +3884,10 @@ Perl_sv_realpath(pTHX_ SV *sv, char *path, STRLEN len) SvPOK_only(sv); return TRUE; + } #endif #else return FALSE; #endif } +