diff options
| -rw-r--r-- | MANIFEST | 2 | ||||
| -rw-r--r-- | Makefile.SH | 4 | ||||
| -rw-r--r-- | embed.h | 12 | ||||
| -rwxr-xr-x | embed.pl | 5 | ||||
| -rw-r--r-- | locale.c | 549 | ||||
| -rw-r--r-- | numeric.c | 691 | ||||
| -rw-r--r-- | objXSUB.h | 2 | ||||
| -rw-r--r-- | perlapi.c | 2 | ||||
| -rw-r--r-- | pod/perlapi.pod | 4 | ||||
| -rw-r--r-- | proto.h | 5 | ||||
| -rw-r--r-- | util.c | 1199 |
11 files changed, 1267 insertions, 1208 deletions
@@ -1193,6 +1193,7 @@ lib/validate.pl Perl library supporting wholesale file mode validation lib/vars.pm Declare pseudo-imported global variables lib/warnings.pm For "use warnings" lib/warnings/register.pm For "use warnings::register" +locale.c locale-specific utility functions makeaperl.SH perl script that produces a new perl binary makedef.pl Create symbol export lists for linking makedepend.SH Precursor to makedepend @@ -1215,6 +1216,7 @@ mpeix/relink MPE/iX port mv-if-diff Script to mv a file if it changed myconfig.SH Prints summary of the current configuration nostdio.h Cause compile error on stdio calls +numeric.c Miscellaneous numeric conversion routines objXSUB.h Scoping macros for Perl Object in extensions op.c Opcode syntax tree code op.h Opcode syntax tree header diff --git a/Makefile.SH b/Makefile.SH index 23b0e46b63..d56b1205d5 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -263,13 +263,13 @@ h = $(h1) $(h2) $(h3) $(h4) $(h5) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c c2 = perl.c perly.c pp.c pp_hot.c pp_ctl.c pp_sys.c regcomp.c regexec.c utf8.c c3 = gv.c sv.c taint.c toke.c util.c deb.c run.c universal.c xsutils.c -c4 = globals.c perlio.c perlapi.c +c4 = globals.c perlio.c perlapi.c numeric.c locale.c c = $(c1) $(c2) $(c3) $(c4) miniperlmain.c perlmain.c obj1 = $(mallocobj) gv$(OBJ_EXT) toke$(OBJ_EXT) perly$(OBJ_EXT) op$(OBJ_EXT) regcomp$(OBJ_EXT) dump$(OBJ_EXT) util$(OBJ_EXT) mg$(OBJ_EXT) obj2 = hv$(OBJ_EXT) av$(OBJ_EXT) run$(OBJ_EXT) pp_hot$(OBJ_EXT) sv$(OBJ_EXT) pp$(OBJ_EXT) scope$(OBJ_EXT) pp_ctl$(OBJ_EXT) pp_sys$(OBJ_EXT) -obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) +obj3 = doop$(OBJ_EXT) doio$(OBJ_EXT) regexec$(OBJ_EXT) utf8$(OBJ_EXT) taint$(OBJ_EXT) deb$(OBJ_EXT) universal$(OBJ_EXT) xsutils$(OBJ_EXT) globals$(OBJ_EXT) perlio$(OBJ_EXT) perlapi$(OBJ_EXT) numeric$(OBJ_EXT) locale$(OBJ_EXT) obj = $(obj1) $(obj2) $(obj3) $(ARCHOBJS) @@ -1170,8 +1170,10 @@ #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) #define isa_lookup S_isa_lookup #endif -#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) #define stdize_locale S_stdize_locale +#endif +#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #define mess_alloc S_mess_alloc # if defined(LEAKTEST) #define xstat S_xstat @@ -2665,8 +2667,10 @@ #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) #define isa_lookup(a,b,c,d) S_isa_lookup(aTHX_ a,b,c,d) #endif -#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) #define stdize_locale(a) S_stdize_locale(aTHX_ a) +#endif +#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #define mess_alloc() S_mess_alloc(aTHX) # if defined(LEAKTEST) #define xstat(a) S_xstat(aTHX_ a) @@ -5182,9 +5186,11 @@ #define S_isa_lookup CPerlObj::S_isa_lookup #define isa_lookup S_isa_lookup #endif -#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) #define S_stdize_locale CPerlObj::S_stdize_locale #define stdize_locale S_stdize_locale +#endif +#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) #define S_mess_alloc CPerlObj::S_mess_alloc #define mess_alloc S_mess_alloc # if defined(LEAKTEST) @@ -2584,8 +2584,11 @@ s |I32 |cr_textfilter |int idx|SV *sv|int maxlen s |SV*|isa_lookup |HV *stash|const char *name|int len|int level #endif -#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) s |char* |stdize_locale |char* locs +#endif + +#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) s |SV* |mess_alloc # if defined(LEAKTEST) s |void |xstat |int diff --git a/locale.c b/locale.c new file mode 100644 index 0000000000..aefcc344a5 --- /dev/null +++ b/locale.c @@ -0,0 +1,549 @@ +/* locale.c + * + * Copyright (c) 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. + * + */ + +/* + * A Elbereth Gilthoniel, + * silivren penna míriel + * o menel aglar elenath! + * Na-chaered palan-díriel + * o galadhremmin ennorath, + * Fanuilos, le linnathon + * nef aear, si nef aearon! + */ + +#include "EXTERN.h" +#define PERL_IN_LOCALE_C +#include "perl.h" + +#ifdef I_LOCALE +# include <locale.h> +#endif + +/* + * 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; +} + +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 */ +} + +/* + * 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 */ +} + +/* + * 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 */ +} + +/* + * 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 */ + diff --git a/numeric.c b/numeric.c new file mode 100644 index 0000000000..a22f813e64 --- /dev/null +++ b/numeric.c @@ -0,0 +1,691 @@ +/* numeric.c + * + * Copyright (c) 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. + * + */ + +/* + * "That only makes eleven (plus one mislaid) and not fourteen, unless + * wizards count differently to other people." + */ + +#include "EXTERN.h" +#define PERL_IN_NUMERIC_C +#include "perl.h" + +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 */; +} + +#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 + +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; +} + +/* +=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; +} + +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; +} + +NV +Perl_my_atof(pTHX_ const char* s) +{ + NV x = 0.0; +#ifdef USE_LOCALE_NUMERIC + if (PL_numeric_local && IN_LOCALE) { + NV y; + + /* 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(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* 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; +} + @@ -2402,6 +2402,8 @@ #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) #endif +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +#endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) # if defined(LEAKTEST) # endif @@ -4267,6 +4267,8 @@ Perl_sys_intern_init(pTHXo) #endif #if defined(PERL_IN_UNIVERSAL_C) || defined(PERL_DECL_PROT) #endif +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) +#endif #if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) # if defined(LEAKTEST) # endif diff --git a/pod/perlapi.pod b/pod/perlapi.pod index d67da131f9..f950bd0321 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -561,7 +561,7 @@ of the number can fit an in UV, it is returned in the *valuep. int grok_number(const char *pv, STRLEN len, UV *valuep) =for hackers -Found in file util.c +Found in file numeric.c =item grok_numeric_radix @@ -570,7 +570,7 @@ Scan and skip for a numeric decimal separator (radix). bool grok_numeric_radix(const char **sp, const char *send) =for hackers -Found in file util.c +Found in file numeric.c =item GvSV @@ -1304,8 +1304,11 @@ STATIC I32 S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen); STATIC SV* S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level); #endif -#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) +#if defined(PERL_IN_LOCALE_C) || defined(PERL_DECL_PROT) STATIC char* S_stdize_locale(pTHX_ char* locs); +#endif + +#if defined(PERL_IN_UTIL_C) || defined(PERL_DECL_PROT) STATIC SV* S_mess_alloc(pTHX); # if defined(LEAKTEST) STATIC void S_xstat(pTHX_ int); @@ -41,10 +41,6 @@ # include <sys/wait.h> #endif -#ifdef I_LOCALE -# include <locale.h> -#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 @@ -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,380 +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_numeric_local && IN_LOCALE) { - NV y; - - /* 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(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; -} - -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) { |