The R Project SVN R

/*

 *  R : A Computer Language for Statistical Data Analysis

 *  Copyright (C) 1997-2019   The R Core Team

 *  Copyright (C) 1995-1996   Robert Gentleman and Ross Ihaka

 *

 *  This program is free software; you can redistribute it and/or modify

 *  it under the terms of the GNU General Public License as published by

 *  the Free Software Foundation; either version 2 of the License, or

 *  (at your option) any later version.

 *

 *  This program is distributed in the hope that it will be useful,

 *  but WITHOUT ANY WARRANTY; without even the implied warranty of

 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

 *  GNU General Public License for more details.

 *

 *  You should have received a copy of the GNU General Public License

 *  along with this program; if not, a copy is available at

 *  https://www.R-project.org/Licenses/

 */

#ifdef HAVE_CONFIG_H

#include <config.h>

#endif

#include <stdlib.h> /* for putenv */

#define R_USE_SIGNALS 1

#include <Defn.h>

#include <Internal.h>

#include <R_ext/Riconv.h>

#include <Rinterface.h>

#include <errno.h>

#include <rlocale.h>

/*

  See ../unix/system.txt for a description of some of these functions.

  Formally part of ../unix/sys-common.c.

 */

/*

 * FILESYSTEM INTERACTION

 */

/*

 * This call provides a simple interface to the "stat" system call.

 */

#ifdef HAVE_SYS_TYPES_H

# include <sys/types.h>

#endif

#ifdef HAVE_SYS_STAT_H

# include <sys/stat.h>

#endif

static int isDir(char *path);

#ifdef HAVE_AQUA

int (*ptr_CocoaSystem)(const char*);

#endif

#ifdef Win32

Rboolean R_FileExists(const char *path)

{

    struct _stati64 sb;

    return _stati64(R_ExpandFileName(path), &sb) == 0;

}

double attribute_hidden R_FileMtime(const char *path)

{

    struct _stati64 sb;

    if (_stati64(R_ExpandFileName(path), &sb) != 0)

	error(_("cannot determine file modification time of '%s'"), path);

    return sb.st_mtime;

}

#else

Rboolean R_FileExists(const char *path)

{

    struct stat sb;

    return stat(R_ExpandFileName(path), &sb) == 0;

}

double attribute_hidden R_FileMtime(const char *path)

{

    struct stat sb;

    if (stat(R_ExpandFileName(path), &sb) != 0)

	error(_("cannot determine file modification time of '%s'"), path);

    return (double) sb.st_mtime;

}

#endif

    /*

     *  Unix file names which begin with "." are invisible.

     */

Rboolean attribute_hidden R_HiddenFile(const char *name)

{

    if (name && name[0] != '.') return 0;

    else return 1;

}

/* The MSVC runtime has a global to determine whether an unspecified

   file open is in text or binary mode.  We force explicit text mode

   here to avoid depending on that global, which may have been changed

   by user code (most likely in embedded applications of R).

*/

#ifdef Win32

static char * fixmode(const char *mode)

{

    /* Rconnection can have a mode of 4 chars plus a ccs= setting plus a null; we might

     * add one char if neither b nor t is specified. */

    static char fixedmode[20];

    fixedmode[19] = '\0';

    strncpy(fixedmode, mode, 19);

    if (!strpbrk(fixedmode, "bt")) {

	strcat(fixedmode, "t");

    }

    return fixedmode;

}

static wchar_t * wcfixmode(const wchar_t *mode)

{

    static wchar_t wcfixedmode[20];

    wcfixedmode[19] = L'\0';

    wcsncpy(wcfixedmode, mode, 19);

    if (!wcspbrk(wcfixedmode, L"bt")) {

	wcscat(wcfixedmode, L"t");

    }

    return wcfixedmode;

}

#else

#define fixmode(mode) (mode)

#define wcfixmode(mode) (mode)

#endif

FILE *R_fopen(const char *filename, const char *mode)

{

    return(filename ? fopen(filename, fixmode(mode)) : NULL );

}

/* The point of this function is to allow file names in foreign

   character sets.  On Unix-alikes in a UTF-8 locale all that is

   needed is to convert file names to UTF-8, since they will be stored

   in UTF-8.  For other locales, it seems that there is no way to specify

   a file name in UTF-8.

   On NT-based versions of Windows, file names are stored in 'Unicode'

   (UCS-2), and _wfopen is provided to access them by UCS-2 names.

*/

#if defined(Win32)

#define BSIZE 100000

wchar_t *filenameToWchar(const SEXP fn, const Rboolean expand)

{

    static wchar_t filename[BSIZE+1];

    void *obj;

    const char *from = "", *inbuf;

    char *outbuf;

    size_t inb, outb, res;

    if(!strlen(CHAR(fn))) {

	wcscpy(filename, L"");

	return filename;

    }

    if(IS_LATIN1(fn))

#ifdef HAVE_ICONV_CP1252

	from = "CP1252";

#else

	from = "latin1";

#endif

    if(IS_UTF8(fn)) from = "UTF-8";

    if(IS_BYTES(fn)) error(_("encoding of a filename cannot be 'bytes'"));

    obj = Riconv_open("UCS-2LE", from);

    if(obj == (void *)(-1))

	error(_("unsupported conversion from '%s' in codepage %d"),

	      from, localeCP);

    if(expand) inbuf = R_ExpandFileName(CHAR(fn)); else inbuf = CHAR(fn);

    inb = strlen(inbuf)+1; outb = 2*BSIZE;

    outbuf = (char *) filename;

    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);

    Riconv_close(obj);

    if(inb > 0) error(_("file name conversion problem -- name too long?"));

    if(res == -1) error(_("file name conversion problem"));

    return filename;

}

FILE *R_wfopen(const wchar_t *filename, const wchar_t *mode)

{

    return filename ? _wfopen(filename, wcfixmode(mode)) : NULL;

}

FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)

{

    wchar_t wmode[10];

    if(fn == NA_STRING) return NULL;

    mbstowcs(wmode, fixmode(mode), 10);

    return _wfopen(filenameToWchar(fn, expand), wmode);

}

#else

FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)

{

    const void *vmax = vmaxget();

    const char *filename = translateCharFP(fn), *res;

    if(fn == NA_STRING || !filename) return NULL;

    if(expand) res = R_ExpandFileName(filename);

    else res = filename;

    vmaxset(vmax);

    return fopen(res, mode);

}

#endif

/*

 *  SYSTEM INFORMATION

 */

	  /* The location of the R system files */

char *R_HomeDir(void)

{

    return getenv("R_HOME");

}

/* This is a primitive (with no arguments) */

SEXP attribute_hidden do_interactive(SEXP call, SEXP op, SEXP args, SEXP rho)

{

    checkArity(op, args);

    return ScalarLogical( (R_Interactive) ? 1 : 0 );

}

SEXP attribute_hidden do_tempdir(SEXP call, SEXP op, SEXP args, SEXP env)

{

    checkArity(op, args);

    Rboolean check = asLogical(CAR(args));

    if(check && !isDir(R_TempDir)) {

	R_TempDir = NULL;

	R_reInitTempDir(/* die_on_fail = */ FALSE);

    }

    return mkString(R_TempDir);

}

SEXP attribute_hidden do_tempfile(SEXP call, SEXP op, SEXP args, SEXP env)

{

    SEXP  ans, pattern, fileext, tempdir;

    const char *tn, *td, *te;

    char *tm;

    int i, n1, n2, n3, slen;

    checkArity(op, args);

    pattern = CAR(args); n1 = length(pattern); args = CDR(args);

    tempdir = CAR(args); n2 = length(tempdir); args = CDR(args);

    fileext = CAR(args); n3 = length(fileext);

    if (!isString(pattern))

	error(_("invalid filename pattern"));

    if (!isString(tempdir))

	error(_("invalid '%s' value"), "tempdir");

    if (!isString(fileext))

	error(_("invalid file extension"));

    if (n1 < 1)

	error(_("no 'pattern'"));

    if (n2 < 1)

	error(_("no 'tempdir'"));

    if (n3 < 1)

	error(_("no 'fileext'"));

    slen = (n1 > n2) ? n1 : n2;

    slen = (n3 > slen) ? n3 : slen;

    PROTECT(ans = allocVector(STRSXP, slen));

    for(i = 0; i < slen; i++) {

	tn = translateCharFP( STRING_ELT( pattern , i%n1 ) );

	td = translateCharFP( STRING_ELT( tempdir , i%n2 ) );

	te = translateCharFP( STRING_ELT( fileext , i%n3 ) );

	/* try to get a new file name */

	tm = R_tmpnam2(tn, td, te);

	SET_STRING_ELT(ans, i, mkChar(tm));

	if(tm) free(tm);

    }

    UNPROTECT(1);

    return (ans);

}

FILE *R_popen(const char *command, const char *type)

{

    FILE *fp;

#ifdef OLD__APPLE__

    /* Luke recommends this to fix PR#1140 */

    /* As of 2016-01-06 on El Capitan this may no longer be needed -- LT */

    sigset_t ss;

    sigemptyset(&ss);

    sigaddset(&ss, SIGPROF);

    sigprocmask(SIG_BLOCK, &ss,  NULL);

    fp = popen(command, type);

    sigprocmask(SIG_UNBLOCK, &ss, NULL);

#else

    fp = popen(command, type);

#endif

    return fp;

}

#ifdef HAVE_SYS_WAIT_H

# include <sys/wait.h>

#endif

int R_system(const char *command)

{

    int res;

#ifdef __APPLE__

# ifdef OLD__APPLE__

    /* Luke recommends this to fix PR#1140 */

    /* As of 2016-01-06 on El Capitan this may no longer be needed -- LT */

    sigset_t ss;

    sigemptyset(&ss);

    sigaddset(&ss, SIGPROF);

    sigprocmask(SIG_BLOCK, &ss,  NULL);

# endif

#ifdef HAVE_AQUA

    if(ptr_CocoaSystem) res = ptr_CocoaSystem(command); else

#endif

    res = system(command);

# ifdef OLD__APPLE__

    sigprocmask(SIG_UNBLOCK, &ss, NULL);

# endif

#else // not APPLE

    res = system(command);

#endif

#ifdef HAVE_SYS_WAIT_H

    if (WIFEXITED(res)) res = WEXITSTATUS(res);

#else

    /* assume that this is shifted if a multiple of 256 */

    if ((res % 256) == 0) res = res/256;

#endif

    if (res == -1) {

	/* this means that system() failed badly - it didn't

	   even get to try to run the shell */

	warning(_("system call failed: %s"), strerror(errno));

	/* R system() is documented to return 127 on failure, and a lot of

	   code relies on that - it will misinterpret -1 as success */

	res = 127;

    }

    return res;

}

#if defined(__APPLE__)

# include <crt_externs.h>

# define environ (*_NSGetEnviron())

#else

extern char ** environ;

#endif

#ifdef Win32

/* _wenviron is declared in stdlib.h */

# define WIN32_LEAN_AND_MEAN 1

# include <windows.h> /* _wgetenv etc */

#endif

SEXP attribute_hidden do_getenv(SEXP call, SEXP op, SEXP args, SEXP env)

{

    int i, j;

    SEXP ans;

    checkArity(op, args);

    if (!isString(CAR(args)))

	error(_("wrong type for argument"));

    if (!isString(CADR(args)) || LENGTH(CADR(args)) != 1)

	error(_("wrong type for argument"));

    i = LENGTH(CAR(args));

    if (i == 0) {

#ifdef Win32

	int n = 0, N;

	wchar_t **w;

	for (i = 0, w = _wenviron; *w != NULL; i++, w++)

	    n = max(n, wcslen(*w));

	N = 4*n+1;

	char buf[N];

	PROTECT(ans = allocVector(STRSXP, i));

	for (i = 0, w = _wenviron; *w != NULL; i++, w++) {

	    wcstoutf8(buf, *w, sizeof(buf));

	    SET_STRING_ELT(ans, i, mkCharCE(buf, CE_UTF8));

	}

#else

	char **e;

	for (i = 0, e = environ; *e != NULL; i++, e++);

	PROTECT(ans = allocVector(STRSXP, i));

	for (i = 0, e = environ; *e != NULL; i++, e++)

	    SET_STRING_ELT(ans, i, mkChar(*e));

#endif

    } else {

	PROTECT(ans = allocVector(STRSXP, i));

	for (j = 0; j < i; j++) {

#ifdef Win32

	    const wchar_t *wnm = wtransChar(STRING_ELT(CAR(args), j));

	    wchar_t *w = _wgetenv(wnm);

	    if (w == NULL)

		SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));

	    else {

		int n = wcslen(w), N = 4*n+1; /* UTF-16 maps to <= 4 UTF-8 */

		R_CheckStack2(N);

		char buf[N];

		wcstoutf8(buf, w, sizeof(buf));

		SET_STRING_ELT(ans, j, mkCharCE(buf, CE_UTF8));

	    }

#else

	    char *s = getenv(translateChar(STRING_ELT(CAR(args), j)));

	    if (s == NULL)

		SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));

	    else {

		SEXP tmp;

		if(known_to_be_latin1) tmp = mkCharCE(s, CE_LATIN1);

		else if(known_to_be_utf8) tmp = mkCharCE(s, CE_UTF8);

		else tmp = mkChar(s);

		SET_STRING_ELT(ans, j, tmp);

	    }

#endif

	}

    }

    UNPROTECT(1);

    return (ans);

}

#ifdef Win32

static int Rwputenv(const wchar_t *nm, const wchar_t *val)

{

    wchar_t *buf;

    buf = (wchar_t *) malloc((wcslen(nm) + wcslen(val) + 2) * sizeof(wchar_t));

    if(!buf) return 1;

    /* previously wsprintfW, which had a limit of 1024 chars */

    wcscpy(buf, nm); wcscat(buf, L"="); wcscat(buf, val);

    if(_wputenv(buf)) return 1;

    /* no free here: storage remains in use */

    return 0;

}

#elif !defined(HAVE_SETENV) && defined(HAVE_PUTENV)

static int Rputenv(const char *nm, const char *val)

{

    char *buf;

    buf = (char *) malloc((strlen(nm) + strlen(val) + 2) * sizeof(char));

    if(!buf) return 1;

    sprintf(buf, "%s=%s", nm, val);

    if(putenv(buf)) return 1;

    /* no free here: storage remains in use */

    return 0;

}

#endif

SEXP attribute_hidden do_setenv(SEXP call, SEXP op, SEXP args, SEXP env)

{

#if defined(HAVE_PUTENV) || defined(HAVE_SETENV)

    int i, n;

    SEXP ans, nm, vars;

    checkArity(op, args);

    if (!isString(nm = CAR(args)))

	error(_("wrong type for argument"));

    if (!isString(vars = CADR(args)))

	error(_("wrong type for argument"));

    if(LENGTH(nm) != LENGTH(vars))

	error(_("wrong length for argument"));

    n = LENGTH(vars);

    PROTECT(ans = allocVector(LGLSXP, n));

#ifdef HAVE_SETENV

    for (i = 0; i < n; i++)

	LOGICAL(ans)[i] = setenv(translateChar(STRING_ELT(nm, i)),

				 translateChar(STRING_ELT(vars, i)),

				 1) == 0;

#elif defined(Win32)

    for (i = 0; i < n; i++)

	LOGICAL(ans)[i] = Rwputenv(wtransChar(STRING_ELT(nm, i)),

				   wtransChar(STRING_ELT(vars, i))) == 0;

#else

    for (i = 0; i < n; i++)

	LOGICAL(ans)[i] = Rputenv(translateChar(STRING_ELT(nm, i)),

				  translateChar(STRING_ELT(vars, i))) == 0;

#endif

    UNPROTECT(1);

    return ans;

#else

    error(_("'Sys.setenv' is not available on this system"));

    return R_NilValue; /* -Wall */

#endif

}

SEXP attribute_hidden do_unsetenv(SEXP call, SEXP op, SEXP args, SEXP env)

{

    int i, n;

    SEXP ans, vars;

    checkArity(op, args);

    if (!isString(vars = CAR(args)))

	error(_("wrong type for argument"));

    n = LENGTH(vars);

#if defined(HAVE_UNSETENV) || defined(HAVE_PUTENV_UNSET) || defined(HAVE_PUTENV_UNSET2)

#ifdef HAVE_UNSETENV

    for (i = 0; i < n; i++) unsetenv(translateChar(STRING_ELT(vars, i)));

#elif defined(HAVE_PUTENV_UNSET)

    for (i = 0; i < n; i++) {

	char buf[1000];

	snprintf(buf, 1000, "%s",  translateChar(STRING_ELT(vars, i)));

	putenv(buf);

    }

#elif defined(HAVE_PUTENV_UNSET2)

# ifdef Win32

    for (i = 0; i < n; i++) {

	const wchar_t *w = wtransChar(STRING_ELT(vars, i));

	wchar_t buf[2*wcslen(w)];

	wcscpy(buf, w);

	wcscat(buf, L"=");

	_wputenv(buf);

    }

# else

    for (i = 0; i < n; i++) {

	char buf[1000];

	snprintf(buf, 1000, "%s=", translateChar(STRING_ELT(vars, i)));

	putenv(buf);

    }

# endif

#endif

#elif defined(HAVE_PUTENV) || defined(HAVE_SETENV)

    warning(_("this system cannot unset environment variables: setting to \"\""));

    n = LENGTH(vars);

    for (i = 0; i < n; i++) {

#ifdef HAVE_SETENV

	setenv(translateChar(STRING_ELT(vars, i)), "", 1);

#else

	Rputenv(translateChar(STRING_ELT(vars, i)), "");

#endif

    }

#else

    warning(_("'Sys.unsetenv' is not available on this system"));

#endif

    PROTECT(ans = allocVector(LGLSXP, n));

    for (i = 0; i < n; i++)

	LOGICAL(ans)[i] = !getenv(translateChar(STRING_ELT(vars, i)));

    UNPROTECT(1);

    return ans;

}

#include <iconv.h>

#ifdef HAVE_ICONVLIST

static unsigned int cnt;

static int

count_one (unsigned int namescount, const char * const *names, void *data)

{

    cnt += namescount;

    return 0;

}

static int

write_one (unsigned int namescount, const char * const *names, void *data)

{

  unsigned int i;

  SEXP ans = (SEXP) data;

  for (i = 0; i < namescount; i++)

      SET_STRING_ELT(ans, cnt++, mkChar(names[i]));

  return 0;

}

#endif

#include "RBufferUtils.h"

/* iconv(x, from, to, sub, mark) */

SEXP attribute_hidden do_iconv(SEXP call, SEXP op, SEXP args, SEXP env)

{

    SEXP ans, x = CAR(args), si;

    void * obj;

    const char *inbuf;

    char *outbuf;

    const char *sub;

    size_t inb, outb, res;

    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};

    Rboolean isRawlist = FALSE;

    checkArity(op, args);

    if(isNull(x)) {  /* list locales */

#ifdef HAVE_ICONVLIST

	cnt = 0;

	iconvlist(count_one, NULL);

	PROTECT(ans = allocVector(STRSXP, cnt));

	cnt = 0;

	iconvlist(write_one, (void *)ans);

#else

	PROTECT(ans = R_NilValue);

#endif

    } else {

	int mark, toRaw;

	const char *from, *to;

	Rboolean isLatin1 = FALSE, isUTF8 = FALSE, fromUTF8 = FALSE;

	args = CDR(args);

	if(!isString(CAR(args)) || length(CAR(args)) != 1)

	    error(_("invalid '%s' argument"), "from");

	from = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */

	args = CDR(args);

	if(!isString(CAR(args)) || length(CAR(args)) != 1)

	    error(_("invalid '%s' argument"), "to");

	to = CHAR(STRING_ELT(CAR(args), 0));

	args = CDR(args);

	if(!isString(CAR(args)) || length(CAR(args)) != 1)

	    error(_("invalid '%s' argument"), "sub");

	if(STRING_ELT(CAR(args), 0) == NA_STRING) sub = NULL;

	else sub = translateChar(STRING_ELT(CAR(args), 0));

	args = CDR(args);

	mark = asLogical(CAR(args));

	if(mark == NA_LOGICAL)

	    error(_("invalid '%s' argument"), "mark");

	args = CDR(args);

	toRaw = asLogical(CAR(args));

	if(toRaw == NA_LOGICAL)

	    error(_("invalid '%s' argument"), "toRaw");

	/* some iconv's allow "UTF8", but libiconv does not */

	if(streql(from, "UTF8") || streql(from, "utf8") ) from = "UTF-8";

	if(streql(from, "UTF-8") || (streql(from, "") && known_to_be_utf8))

	    fromUTF8 = TRUE;

	if(streql(to, "UTF8") || streql(to, "utf8") ) to = "UTF-8";

	/* Should we do something about marked CHARSXPs in 'from = ""'? */

	if(streql(to, "UTF-8")) isUTF8 = TRUE;

	if(streql(to, "latin1") || streql(to, "ISO_8859-1")

	    || streql(to, "CP1252")) isLatin1 = TRUE;

	if(streql(to, "") && known_to_be_latin1) isLatin1 = TRUE;

	if(streql(to, "") && known_to_be_utf8) isUTF8 = TRUE;

	obj = Riconv_open(to, from);

	if(obj == (iconv_t)(-1))

#ifdef Win32

	    error(_("unsupported conversion from '%s' to '%s' in codepage %d"),

		  from, to, localeCP);

#else

	    error(_("unsupported conversion from '%s' to '%s'"), from, to);

#endif

	isRawlist = (TYPEOF(x) == VECSXP);

	if(isRawlist) {

	    if(toRaw)

		PROTECT(ans = duplicate(x));

	    else {

		PROTECT(ans = allocVector(STRSXP, LENGTH(x)));

		SHALLOW_DUPLICATE_ATTRIB(ans, x);

	    }

	} else {

	    if(TYPEOF(x) != STRSXP) {

		Riconv_close(obj);

		error(_("'x' must be a character vector"));

	    }

	    if(toRaw) {

		PROTECT(ans = allocVector(VECSXP, LENGTH(x)));

		SHALLOW_DUPLICATE_ATTRIB(ans, x);

	    } else

		PROTECT(ans = duplicate(x));

	}

	R_AllocStringBuffer(0, &cbuff);  /* 0 -> default */

	for(R_xlen_t i = 0; i < XLENGTH(x); i++) {

	    if (isRawlist) {

		si = VECTOR_ELT(x, i);

		if (TYPEOF(si) == NILSXP) {

		    if (!toRaw) SET_STRING_ELT(ans, i, NA_STRING);

		    continue;

		} else if (TYPEOF(si) != RAWSXP) {

		    Riconv_close(obj);

		    error(_("'x' must be a character vector or a list of NULL or raw vectors"));

		}

	    } else {

		si = STRING_ELT(x, i);

		if (si == NA_STRING) {

		    if(!toRaw) SET_STRING_ELT(ans, i, NA_STRING);

		    continue;

		}

	    }

	top_of_loop:

	    inbuf = isRawlist ? (const char *) RAW(si) : CHAR(si);

	    inb = LENGTH(si);

	    outbuf = cbuff.data; outb = cbuff.bufsize - 1;

	    /* First initialize output */

	    Riconv (obj, NULL, NULL, &outbuf, &outb);

	next_char:

	    /* Then convert input  */

	    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);

	    *outbuf = '\0';

	    /* other possible error conditions are

	       incomplete and invalid multibyte chars */

	    if(res == -1 && errno == E2BIG) {

		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);

		goto top_of_loop;

	    } else if(res == -1 && sub &&

		      (errno == EILSEQ || errno == EINVAL)) {

		/* it seems this gets thrown for non-convertible input too */

		if(fromUTF8 && streql(sub, "Unicode")) {

		    if(outb < 13) {

			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);

			goto top_of_loop;

		    }

		    wchar_t wc;

		    size_t clen = utf8toucs(&wc, inbuf);

		    if(clen > 0 && inb >= clen) {

			Rwchar_t ucs;

			if (IS_HIGH_SURROGATE(wc))

			    ucs = utf8toucs32(wc, inbuf);

			else

			    ucs = (Rwchar_t) wc;

			inbuf += clen; inb -= clen;

			if(ucs < 65536) {

			    // gcc 7 objects to this with unsigned int

			    snprintf(outbuf, 9, "<U+%04X>", (unsigned short) ucs);

			    outbuf += 8; outb -= 8;

			} else {

			    /* Rwchar_t is unsigned int on Windows, 

			       otherwise wchar_t (usually int).

			       In any case Unicode points <= 0x10FFFF

			    */

			    snprintf(outbuf, 13, "<U+%08X>", (unsigned int) ucs);

			    outbuf += 12; outb -= 12;

			}

		    }

		    goto next_char;

		}  else if(strcmp(sub, "byte") == 0) {

		    if(outb < 5) {

			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);

			goto top_of_loop;

		    }

		    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);

		    outbuf += 4; outb -= 4;

		} else {

		    size_t sub_len = strlen(sub);

		    if(outb < sub_len) {

			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);

			goto top_of_loop;

		    }

		    memcpy(outbuf, sub, sub_len);

		    outbuf += sub_len; outb -= sub_len;

		}

		inbuf++; inb--;

		goto next_char;

	    }

	    if(toRaw) {

		if(res != -1 && inb == 0) {

		    size_t nout = cbuff.bufsize - 1 - outb;

		    SEXP el = allocVector(RAWSXP, nout);

		    memcpy(RAW(el), cbuff.data, nout);

		    SET_VECTOR_ELT(ans, i, el);

		} /* otherwise is already NULL */

	    } else {

		if(res != -1 && inb == 0) {

		    cetype_t ienc = CE_NATIVE;

		    size_t nout = cbuff.bufsize - 1 - outb;

		    if(mark) {

			if(isLatin1) ienc = CE_LATIN1;

			else if(isUTF8) ienc = CE_UTF8;

		    }

		    SET_STRING_ELT(ans, i,

				   mkCharLenCE(cbuff.data, (int) nout, ienc));

		} else SET_STRING_ELT(ans, i, NA_STRING);

	    }

	}

	Riconv_close(obj);

	R_FreeStringBuffer(&cbuff);

    }

    UNPROTECT(1);

    return ans;

}

cetype_t getCharCE(SEXP x)

{

    if(TYPEOF(x) != CHARSXP)

	error(_("'%s' must be called on a CHARSXP"), "getCharCE");

    if(IS_UTF8(x)) return CE_UTF8;

    else if(IS_LATIN1(x)) return CE_LATIN1;

    else if(IS_BYTES(x)) return CE_BYTES;

    else return CE_NATIVE;

}

void * Riconv_open (const char* tocode, const char* fromcode)

{

#if defined Win32 || __APPLE__

// These two support "utf8"

# ifdef Win32

    const char *cp = "ASCII";

#  ifndef SUPPORT_UTF8_WIN32 /* Always, at present */

    char to[20] = "";

    if (localeCP > 0) {snprintf(to, 20, "CP%d", localeCP); cp = to;}

#  endif

# else /* __APPLE__ */

    const char *cp = "UTF-8";

    if (latin1locale) cp = "ISO-8859-1";

    else if (!utf8locale) cp = locale2charset(NULL);

# endif

    if (!*tocode && !*fromcode) return iconv_open(cp, cp);

    if(!*tocode)  return iconv_open(cp, fromcode);

    else if(!*fromcode) return iconv_open(tocode, cp);

    else return iconv_open(tocode, fromcode);

#else

// "utf8" is not valid but people keep on using it

    const char *to = tocode, *from = fromcode;

    if(strcasecmp(tocode, "utf8") == 0) to = "UTF-8";

    if(strcasecmp(fromcode, "utf8") == 0) from = "UTF-8";

    return iconv_open(to, from);

#endif

}

/* Should be defined in config.h, but prior to 2.13.0 was only checked

   if the NLS was enabled  */

#ifndef ICONV_CONST

# define ICONV_CONST

#endif

size_t Riconv (void *cd, const char **inbuf, size_t *inbytesleft,

	       char **outbuf, size_t *outbytesleft)

{

    /* here libiconv has const char **, glibc has char ** for inbuf */

    return iconv((iconv_t) cd, (ICONV_CONST char **) inbuf, inbytesleft,

		 outbuf, outbytesleft);

}

int Riconv_close (void *cd)

{

    return iconv_close((iconv_t) cd);

}

typedef enum {

    NT_NONE        = 0, /* no translation to native encoding is needed */

    NT_FROM_UTF8   = 1, /* need to translate from UTF8 */

    NT_FROM_LATIN1 = 2, /* need to translate from latin1 */

} nttype_t;

/* Decides whether translation to native encoding is needed. */

static R_INLINE nttype_t needsTranslation(SEXP x) {

    if (IS_ASCII(x)) return NT_NONE;

    if (IS_UTF8(x)) {

	if (utf8locale || x == NA_STRING) return NT_NONE;

	return NT_FROM_UTF8;

    }

    if (IS_LATIN1(x)) {

	if (x == NA_STRING || latin1locale) return NT_NONE;

	return NT_FROM_LATIN1;

    }

    if (IS_BYTES(x))

	error(_("translating strings with \"bytes\" encoding is not allowed"));

    return NT_NONE;

}

static void *latin1_obj = NULL, *utf8_obj=NULL, *ucsmb_obj=NULL,

    *ucsutf8_obj=NULL;

/* Translates string in "ans" to native encoding returning it in string

   buffer "cbuff" */

static int translateToNative(const char *ans, R_StringBuffer *cbuff,

			     nttype_t ttype, int mustWork)

{

    if (ttype == NT_NONE)

	error(_("internal error: no translation needed"));

    void * obj;

    const char *inbuf, *from;

    char *outbuf;

    size_t inb, outb, res;

    Rboolean failed = FALSE;

    if(ttype == NT_FROM_LATIN1) {

	if(!latin1_obj) {

#ifdef HAVE_ICONV_CP1252

	    from = "CP1252";

#else

	    from = "latin1";

#endif

	    obj = Riconv_open("", from);

	    /* should never happen */

	    if(obj == (void *)(-1))

#ifdef Win32

		error(_("unsupported conversion from '%s' in codepage %d"),

		      from, localeCP);

#else

		error(_("unsupported conversion from '%s' to '%s'"),

		      from, "");

#endif

	    latin1_obj = obj;

	}

	obj = latin1_obj;

    } else {

	if(!utf8_obj) {

	    obj = Riconv_open("", "UTF-8");

	    /* should never happen */

	    if(obj == (void *)(-1))

#ifdef Win32

		error(_("unsupported conversion from '%s' in codepage %d"),

		      "UTF-8", localeCP);

#else

		error(_("unsupported conversion from '%s' to '%s'"),

		      "UTF-8", "");

#endif

	    utf8_obj = obj;

	}

	obj = utf8_obj;

    }

    R_AllocStringBuffer(0, cbuff);

top_of_loop:

    inbuf = ans; inb = strlen(inbuf);

    outbuf = cbuff->data; outb = cbuff->bufsize - 1;

    /* First initialize output */

    Riconv (obj, NULL, NULL, &outbuf, &outb);

next_char:

    /* Then convert input  */

    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);

    if(res == -1 && errno == E2BIG) {

	R_AllocStringBuffer(2*cbuff->bufsize, cbuff);

	goto top_of_loop;

    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {

	if(outb < 13) {

	    R_AllocStringBuffer(2*cbuff->bufsize, cbuff);

	    goto top_of_loop;

	}

	failed = TRUE;

	if (ttype == NT_FROM_UTF8) {

	    /* if starting in UTF-8, use \uxxxx */

	    /* This must be the first byte */

	    wchar_t wc;

	    size_t clen = utf8toucs(&wc, inbuf);