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