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
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
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)
#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
#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)
#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)
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
--- /dev/null
+/* 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 */
+
--- /dev/null
+/* 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;
+}
+
#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
#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
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
bool grok_numeric_radix(const char **sp, const char *send)
=for hackers
-Found in file util.c
+Found in file numeric.c
=item GvSV
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);
# include <sys/wait.h>
#endif
-#ifdef I_LOCALE
-# include <locale.h>
-#endif
-
#define FLUSH
#ifdef LEAKTEST
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
}
}
-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)
}
#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)
{
}
#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)
#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)
{
projects / p5sagit/p5-mst-13.2.git / commitdiff