[p5sagit/p5-mst-13.2.git] / locale.c

/*    locale.c
 *
 *    Copyright (c) 2001-2002, 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 */
Commit	Line	Data
98994639	1	/* locale.c
98994639	2	*
be3c0a43	3	* Copyright (c) 2001-2002, Larry Wall
98994639	4	*
	5	* You may distribute under the terms of either the GNU General Public
	6	* License or the Artistic License, as specified in the README file.
	7	*
	8	*/
	9
	10	/*
	11	* A Elbereth Gilthoniel,
	12	* silivren penna míriel
	13	* o menel aglar elenath!
	14	* Na-chaered palan-díriel
	15	* o galadhremmin ennorath,
	16	* Fanuilos, le linnathon
	17	* nef aear, si nef aearon!
	18	*/
	19
	20	#include "EXTERN.h"
	21	#define PERL_IN_LOCALE_C
	22	#include "perl.h"
	23
	24	#ifdef I_LOCALE
	25	# include <locale.h>
	26	#endif
	27
	28	/*
	29	* Standardize the locale name from a string returned by 'setlocale'.
	30	*
	31	* The standard return value of setlocale() is either
	32	* (1) "xx_YY" if the first argument of setlocale() is not LC_ALL
	33	* (2) "xa_YY xb_YY ..." if the first argument of setlocale() is LC_ALL
	34	* (the space-separated values represent the various sublocales,
	35	* in some unspecificed order)
	36	*
	37	* In some platforms it has a form like "LC_SOMETHING=Lang_Country.866\n",
	38	* which is harmful for further use of the string in setlocale().
	39	*
	40	*/
	41	STATIC char *
	42	S_stdize_locale(pTHX_ char *locs)
	43	{
	44	char *s;
	45	bool okay = TRUE;
	46
	47	if ((s = strchr(locs, '='))) {
	48	char *t;
	49
	50	okay = FALSE;
	51	if ((t = strchr(s, '.'))) {
	52	char *u;
	53
	54	if ((u = strchr(t, '\n'))) {
	55
	56	if (u[1] == 0) {
	57	STRLEN len = u - s;
	58	Move(s + 1, locs, len, char);
	59	locs[len] = 0;
	60	okay = TRUE;
	61	}
	62	}
	63	}
	64	}
	65
	66	if (!okay)
	67	Perl_croak(aTHX_ "Can't fix broken locale name \"%s\"", locs);
68
69	return locs;
70	}
71
72	void
73	Perl_set_numeric_radix(pTHX)
74	{
75	#ifdef USE_LOCALE_NUMERIC
76	# ifdef HAS_LOCALECONV
77	struct lconv* lc;
78
79	lc = localeconv();
80	if (lc && lc->decimal_point) {
81	if (lc->decimal_point[0] == '.' && lc->decimal_point[1] == 0) {
82	SvREFCNT_dec(PL_numeric_radix_sv);
83	PL_numeric_radix_sv = Nullsv;
84	}
85	else {
86	if (PL_numeric_radix_sv)
87	sv_setpv(PL_numeric_radix_sv, lc->decimal_point);
88	else
89	PL_numeric_radix_sv = newSVpv(lc->decimal_point, 0);
90	}
91	}
92	else
93	PL_numeric_radix_sv = Nullsv;
94	# endif /* HAS_LOCALECONV */
95	#endif /* USE_LOCALE_NUMERIC */
96	}
97
98	/*
99	* Set up for a new numeric locale.
100	*/
101	void
102	Perl_new_numeric(pTHX_ char *newnum)
103	{
104	#ifdef USE_LOCALE_NUMERIC
105
106	if (! newnum) {
107	if (PL_numeric_name) {
108	Safefree(PL_numeric_name);
109	PL_numeric_name = NULL;
110	}
111	PL_numeric_standard = TRUE;
112	PL_numeric_local = TRUE;
113	return;
114	}
115
116	if (! PL_numeric_name \|\| strNE(PL_numeric_name, newnum)) {
117	Safefree(PL_numeric_name);
118	PL_numeric_name = stdize_locale(savepv(newnum));
119	PL_numeric_standard = (strEQ(newnum, "C") \|\| strEQ(newnum, "POSIX"));
120	PL_numeric_local = TRUE;
121	set_numeric_radix();
122	}
123
124	#endif /* USE_LOCALE_NUMERIC */
125	}
126
127	void
128	Perl_set_numeric_standard(pTHX)
129	{
130	#ifdef USE_LOCALE_NUMERIC
131
132	if (! PL_numeric_standard) {
133	setlocale(LC_NUMERIC, "C");
134	PL_numeric_standard = TRUE;
135	PL_numeric_local = FALSE;
136	set_numeric_radix();
137	}
138
139	#endif /* USE_LOCALE_NUMERIC */
140	}
141
142	void
143	Perl_set_numeric_local(pTHX)
144	{
145	#ifdef USE_LOCALE_NUMERIC
146
147	if (! PL_numeric_local) {
148	setlocale(LC_NUMERIC, PL_numeric_name);
149	PL_numeric_standard = FALSE;
150	PL_numeric_local = TRUE;
151	set_numeric_radix();
152	}
153
154	#endif /* USE_LOCALE_NUMERIC */
155	}
156
157	/*
158	* Set up for a new ctype locale.
159	*/
160	void
161	Perl_new_ctype(pTHX_ char *newctype)
162	{
163	#ifdef USE_LOCALE_CTYPE
164
165	int i;
166
167	for (i = 0; i < 256; i++) {
168	if (isUPPER_LC(i))
169	PL_fold_locale[i] = toLOWER_LC(i);
170	else if (isLOWER_LC(i))
171	PL_fold_locale[i] = toUPPER_LC(i);
172	else
173	PL_fold_locale[i] = i;
174	}
175
176	#endif /* USE_LOCALE_CTYPE */
177	}
178
179	/*
180	* Set up for a new collation locale.
181	*/
182	void
183	Perl_new_collate(pTHX_ char *newcoll)
184	{
185	#ifdef USE_LOCALE_COLLATE
186
187	if (! newcoll) {
188	if (PL_collation_name) {
189	++PL_collation_ix;
190	Safefree(PL_collation_name);
191	PL_collation_name = NULL;
192	}
193	PL_collation_standard = TRUE;
194	PL_collxfrm_base = 0;
195	PL_collxfrm_mult = 2;
196	return;
197	}
198
199	if (! PL_collation_name \|\| strNE(PL_collation_name, newcoll)) {
200	++PL_collation_ix;
201	Safefree(PL_collation_name);
202	PL_collation_name = stdize_locale(savepv(newcoll));
203	PL_collation_standard = (strEQ(newcoll, "C") \|\| strEQ(newcoll, "POSIX"));
204
205	{
206	/* 2: at most so many chars ('a', 'b'). */
207	/* 50: surely no system expands a char more. */
208	#define XFRMBUFSIZE (2 * 50)
209	char xbuf[XFRMBUFSIZE];
210	Size_t fa = strxfrm(xbuf, "a", XFRMBUFSIZE);
211	Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
212	SSize_t mult = fb - fa;
213	if (mult < 1)
214	Perl_croak(aTHX_ "strxfrm() gets absurd");
215	PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
216	PL_collxfrm_mult = mult;
217	}
218	}
219
220	#endif /* USE_LOCALE_COLLATE */
221	}
222
223	/*
224	* Initialize locale awareness.
225	*/
226	int
227	Perl_init_i18nl10n(pTHX_ int printwarn)
228	{
229	int ok = 1;
230	/* returns
231	* 1 = set ok or not applicable,
232	* 0 = fallback to C locale,
233	* -1 = fallback to C locale failed
234	*/
235
236	#if defined(USE_LOCALE)
237
238	#ifdef USE_LOCALE_CTYPE
239	char *curctype = NULL;
240	#endif /* USE_LOCALE_CTYPE */
241	#ifdef USE_LOCALE_COLLATE
242	char *curcoll = NULL;
243	#endif /* USE_LOCALE_COLLATE */
244	#ifdef USE_LOCALE_NUMERIC
245	char *curnum = NULL;
246	#endif /* USE_LOCALE_NUMERIC */
247	#ifdef __GLIBC__
248	char *language = PerlEnv_getenv("LANGUAGE");
249	#endif
250	char *lc_all = PerlEnv_getenv("LC_ALL");
251	char *lang = PerlEnv_getenv("LANG");
252	bool setlocale_failure = FALSE;
253
254	#ifdef LOCALE_ENVIRON_REQUIRED
255
256	/*
257	* Ultrix setlocale(..., "") fails if there are no environment
258	* variables from which to get a locale name.
259	*/
260
261	bool done = FALSE;
262
263	#ifdef LC_ALL
264	if (lang) {
265	if (setlocale(LC_ALL, ""))
266	done = TRUE;
267	else
268	setlocale_failure = TRUE;
269	}
270	if (!setlocale_failure) {
271	#ifdef USE_LOCALE_CTYPE
272	if (! (curctype =
273	setlocale(LC_CTYPE,
274	(!done && (lang \|\| PerlEnv_getenv("LC_CTYPE")))
275	? "" : Nullch)))
276	setlocale_failure = TRUE;
277	else
278	curctype = savepv(curctype);
279	#endif /* USE_LOCALE_CTYPE */
280	#ifdef USE_LOCALE_COLLATE
281	if (! (curcoll =
282	setlocale(LC_COLLATE,
283	(!done && (lang \|\| PerlEnv_getenv("LC_COLLATE")))
284	? "" : Nullch)))
285	setlocale_failure = TRUE;
286	else
287	curcoll = savepv(curcoll);
288	#endif /* USE_LOCALE_COLLATE */
289	#ifdef USE_LOCALE_NUMERIC
290	if (! (curnum =
291	setlocale(LC_NUMERIC,
292	(!done && (lang \|\| PerlEnv_getenv("LC_NUMERIC")))
293	? "" : Nullch)))
294	setlocale_failure = TRUE;
295	else
296	curnum = savepv(curnum);
297	#endif /* USE_LOCALE_NUMERIC */
298	}
299
300	#endif /* LC_ALL */
301
302	#endif /* !LOCALE_ENVIRON_REQUIRED */
303
304	#ifdef LC_ALL
305	if (! setlocale(LC_ALL, ""))
306	setlocale_failure = TRUE;
307	#endif /* LC_ALL */
308
309	if (!setlocale_failure) {
310	#ifdef USE_LOCALE_CTYPE
311	if (! (curctype = setlocale(LC_CTYPE, "")))
312	setlocale_failure = TRUE;
313	else
314	curctype = savepv(curctype);
315	#endif /* USE_LOCALE_CTYPE */
316	#ifdef USE_LOCALE_COLLATE
317	if (! (curcoll = setlocale(LC_COLLATE, "")))
318	setlocale_failure = TRUE;
319	else
320	curcoll = savepv(curcoll);
321	#endif /* USE_LOCALE_COLLATE */
322	#ifdef USE_LOCALE_NUMERIC
323	if (! (curnum = setlocale(LC_NUMERIC, "")))
324	setlocale_failure = TRUE;
325	else
326	curnum = savepv(curnum);
327	#endif /* USE_LOCALE_NUMERIC */
328	}
329
330	if (setlocale_failure) {
331	char *p;
332	bool locwarn = (printwarn > 1 \|\|
333	(printwarn &&
334	(!(p = PerlEnv_getenv("PERL_BADLANG")) \|\| atoi(p))));
335
336	if (locwarn) {
337	#ifdef LC_ALL
338
339	PerlIO_printf(Perl_error_log,
340	"perl: warning: Setting locale failed.\n");
341
342	#else /* !LC_ALL */
343
344	PerlIO_printf(Perl_error_log,
345	"perl: warning: Setting locale failed for the categories:\n\t");
346	#ifdef USE_LOCALE_CTYPE
347	if (! curctype)
348	PerlIO_printf(Perl_error_log, "LC_CTYPE ");
349	#endif /* USE_LOCALE_CTYPE */
350	#ifdef USE_LOCALE_COLLATE
351	if (! curcoll)
352	PerlIO_printf(Perl_error_log, "LC_COLLATE ");
353	#endif /* USE_LOCALE_COLLATE */
354	#ifdef USE_LOCALE_NUMERIC
355	if (! curnum)
356	PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
357	#endif /* USE_LOCALE_NUMERIC */
358	PerlIO_printf(Perl_error_log, "\n");
359
360	#endif /* LC_ALL */
361
362	PerlIO_printf(Perl_error_log,
363	"perl: warning: Please check that your locale settings:\n");
364
365	#ifdef __GLIBC__
366	PerlIO_printf(Perl_error_log,
367	"\tLANGUAGE = %c%s%c,\n",
368	language ? '"' : '(',
369	language ? language : "unset",
370	language ? '"' : ')');
371	#endif
372
373	PerlIO_printf(Perl_error_log,
374	"\tLC_ALL = %c%s%c,\n",
375	lc_all ? '"' : '(',
376	lc_all ? lc_all : "unset",
377	lc_all ? '"' : ')');
378
379	#if defined(USE_ENVIRON_ARRAY)
380	{
381	char **e;
382	for (e = environ; *e; e++) {
383	if (strnEQ(*e, "LC_", 3)
384	&& strnNE(*e, "LC_ALL=", 7)
385	&& (p = strchr(*e, '=')))
386	PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
387	(int)(p - e), e, p + 1);
388	}
389	}
390	#else
391	PerlIO_printf(Perl_error_log,
392	"\t(possibly more locale environment variables)\n");
393	#endif
394
395	PerlIO_printf(Perl_error_log,
396	"\tLANG = %c%s%c\n",
397	lang ? '"' : '(',
398	lang ? lang : "unset",
399	lang ? '"' : ')');
400
401	PerlIO_printf(Perl_error_log,
402	" are supported and installed on your system.\n");
403	}
404
405	#ifdef LC_ALL
406
407	if (setlocale(LC_ALL, "C")) {
408	if (locwarn)
409	PerlIO_printf(Perl_error_log,
410	"perl: warning: Falling back to the standard locale (\"C\").\n");
411	ok = 0;
412	}
413	else {
414	if (locwarn)
415	PerlIO_printf(Perl_error_log,
416	"perl: warning: Failed to fall back to the standard locale (\"C\").\n");
417	ok = -1;
418	}
419
420	#else /* ! LC_ALL */
421
422	if (0
423	#ifdef USE_LOCALE_CTYPE
424	\|\| !(curctype \|\| setlocale(LC_CTYPE, "C"))
425	#endif /* USE_LOCALE_CTYPE */
426	#ifdef USE_LOCALE_COLLATE
427	\|\| !(curcoll \|\| setlocale(LC_COLLATE, "C"))
428	#endif /* USE_LOCALE_COLLATE */
429	#ifdef USE_LOCALE_NUMERIC
430	\|\| !(curnum \|\| setlocale(LC_NUMERIC, "C"))
431	#endif /* USE_LOCALE_NUMERIC */
432	)
433	{
434	if (locwarn)
435	PerlIO_printf(Perl_error_log,
436	"perl: warning: Cannot fall back to the standard locale (\"C\").\n");
437	ok = -1;
438	}
439
440	#endif /* ! LC_ALL */
441
442	#ifdef USE_LOCALE_CTYPE
443	curctype = savepv(setlocale(LC_CTYPE, Nullch));
444	#endif /* USE_LOCALE_CTYPE */
445	#ifdef USE_LOCALE_COLLATE
446	curcoll = savepv(setlocale(LC_COLLATE, Nullch));
447	#endif /* USE_LOCALE_COLLATE */
448	#ifdef USE_LOCALE_NUMERIC
449	curnum = savepv(setlocale(LC_NUMERIC, Nullch));
450	#endif /* USE_LOCALE_NUMERIC */
451	}
452	else {
453
454	#ifdef USE_LOCALE_CTYPE
455	new_ctype(curctype);
456	#endif /* USE_LOCALE_CTYPE */
457
458	#ifdef USE_LOCALE_COLLATE
459	new_collate(curcoll);
460	#endif /* USE_LOCALE_COLLATE */
461
462	#ifdef USE_LOCALE_NUMERIC
463	new_numeric(curnum);
464	#endif /* USE_LOCALE_NUMERIC */
465	}
466
467	#endif /* USE_LOCALE */
468
469	#ifdef USE_LOCALE_CTYPE
470	if (curctype != NULL)
471	Safefree(curctype);
472	#endif /* USE_LOCALE_CTYPE */
473	#ifdef USE_LOCALE_COLLATE
474	if (curcoll != NULL)
475	Safefree(curcoll);
476	#endif /* USE_LOCALE_COLLATE */
477	#ifdef USE_LOCALE_NUMERIC
478	if (curnum != NULL)
479	Safefree(curnum);
480	#endif /* USE_LOCALE_NUMERIC */
481	return ok;
482	}
483
484	/* Backwards compatibility. */
485	int
486	Perl_init_i18nl14n(pTHX_ int printwarn)
487	{
488	return init_i18nl10n(printwarn);
489	}
490
491	#ifdef USE_LOCALE_COLLATE
492
493	/*
494	* mem_collxfrm() is a bit like strxfrm() but with two important
495	* differences. First, it handles embedded NULs. Second, it allocates
496	* a bit more memory than needed for the transformed data itself.
497	* The real transformed data begins at offset sizeof(collationix).
498	* Please see sv_collxfrm() to see how this is used.
499	*/
500	char *
501	Perl_mem_collxfrm(pTHX_ const char s, STRLEN len, STRLEN xlen)
502	{
503	char *xbuf;
504	STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
505
506	/* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
507	/* the +1 is for the terminating NUL. */
508
509	xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
510	New(171, xbuf, xAlloc, char);
511	if (! xbuf)
512	goto bad;
513
514	(U32)xbuf = PL_collation_ix;
515	xout = sizeof(PL_collation_ix);
516	for (xin = 0; xin < len; ) {
517	SSize_t xused;
518
519	for (;;) {
520	xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
521	if (xused == -1)
522	goto bad;
523	if (xused < xAlloc - xout)
524	break;
525	xAlloc = (2 * xAlloc) + 1;
526	Renew(xbuf, xAlloc, char);
527	if (! xbuf)
528	goto bad;
529	}
530
531	xin += strlen(s + xin) + 1;
532	xout += xused;
533
534	/* Embedded NULs are understood but silently skipped
535	* because they make no sense in locale collation. */
536	}
537
538	xbuf[xout] = '\0';
539	*xlen = xout - sizeof(PL_collation_ix);
540	return xbuf;
541
542	bad:
543	Safefree(xbuf);
544	*xlen = 0;
545	return NULL;
546	}
547
548	#endif /* USE_LOCALE_COLLATE */
549