splitting util.c

Message-Id: <200106132341.AAA24935@crypt.compulink.co.uk>

p4raw-id: //depot/perl@10579

1 files changed, 549 insertions, 0 deletions

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 */
+