The R Project SVN R

Rev

Rev 63219 | Rev 64516 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
29747 ripley 1 
/*
42307 ripley 2 
 *  R : A Computer Language for Statistical Data Analysis
3 
 *  Copyright (C) 1995-1996   Robert Gentleman and Ross Ihaka
62580 ripley 4 
 *  Copyright (C) 1997-2013   The R Core Team
42307 ripley 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
17 
 *  along with this program; if not, a copy is available at
18 
 *  http://www.r-project.org/Licenses/
29747 ripley 19 
 */
20 
 
21 
#ifdef HAVE_CONFIG_H
22 
#include <config.h>
23 
#endif
36612 ripley 24 
 
36622 ripley 25 
#include <stdlib.h> /* for putenv */
57538 ripley 26 
#define R_USE_SIGNALS 1
29747 ripley 27 
#include <Defn.h>
60667 ripley 28 
#include <Internal.h>
32670 ripley 29 
#include <R_ext/Riconv.h>
39866 duncan 30 
#include <Rinterface.h>
42398 ripley 31 
#include <errno.h>
29747 ripley 32 
 
33 
/*
34 
  See ../unix/system.txt for a description of some of these functions.
35 
  Formally part of ../unix/sys-common.c.
36 
 */
37 
 
38 
/*
39 
 * FILESYSTEM INTERACTION
40 
 */
41 
 
42 
/*
43 
 * This call provides a simple interface to the "stat" system call.
44 
 */
45 
 
41349 ripley 46 
#ifdef HAVE_SYS_TYPES_H
47 
# include <sys/types.h>
48 
#endif
49 
#ifdef HAVE_SYS_STAT_H
50 
# include <sys/stat.h>
51 
#endif
29747 ripley 52 
 
51388 ripley 53 
#ifdef HAVE_AQUA
61483 ripley 54 
int (*ptr_CocoaSystem)(const char*);
31499 iacus 55 
extern	Rboolean useaqua;
31157 iacus 56 
#endif
57 
 
54797 ripley 58 
#ifdef Win32
60699 ripley 59 
Rboolean R_FileExists(const char *path)
29747 ripley 60 
{
54797 ripley 61 
    struct _stati64 sb;
62 
    return _stati64(R_ExpandFileName(path), &sb) == 0;
63 
}
64 
 
65 
double attribute_hidden R_FileMtime(const char *path)
66 
{
67 
    struct _stati64 sb;
68 
    if (_stati64(R_ExpandFileName(path), &sb) != 0)
69 
	error(_("cannot determine file modification time of '%s'"), path);
70 
    return sb.st_mtime;
71 
}
72 
#else
60699 ripley 73 
Rboolean R_FileExists(const char *path)
54797 ripley 74 
{
29747 ripley 75 
    struct stat sb;
76 
    return stat(R_ExpandFileName(path), &sb) == 0;
77 
}
78 
 
41784 ripley 79 
double attribute_hidden R_FileMtime(const char *path)
29747 ripley 80 
{
81 
    struct stat sb;
82 
    if (stat(R_ExpandFileName(path), &sb) != 0)
33297 ripley 83 
	error(_("cannot determine file modification time of '%s'"), path);
59101 ripley 84 
    return (double) sb.st_mtime;
29747 ripley 85 
}
54797 ripley 86 
#endif
29747 ripley 87 
 
88 
    /*
89 
     *  Unix file names which begin with "." are invisible.
90 
     */
91 
 
41784 ripley 92 
Rboolean attribute_hidden R_HiddenFile(const char *name)
29747 ripley 93 
{
94 
    if (name && name[0] != '.') return 0;
95 
    else return 1;
96 
}
97 
 
44165 ripley 98 
/* The MSVC runtime has a global to determine whether an unspecified
99 
   file open is in text or binary mode.  We force explicit text mode
100 
   here to avoid depending on that global, which may have been changed
101 
   by user code (most likely in embedded applications of R).
44052 murdoch 102 
*/
29747 ripley 103 
 
44052 murdoch 104 
#ifdef Win32
105 
 
106 
static char * fixmode(const char *mode)
107 
{
44165 ripley 108 
    /* Rconnection can have a mode of 4 chars plus a null; we might
109 
     * add one char */
110 
    static char fixedmode[6];
44052 murdoch 111 
    fixedmode[4] = '\0';
112 
    strncpy(fixedmode, mode, 4);
113 
    if (!strpbrk(fixedmode, "bt")) {
45446 ripley 114 
	strcat(fixedmode, "t");
44052 murdoch 115 
    }
116 
    return fixedmode;
117 
}
118 
 
119 
static wchar_t * wcfixmode(const wchar_t *mode)
120 
{
44165 ripley 121 
    static wchar_t wcfixedmode[6];
44052 murdoch 122 
    wcfixedmode[4] = L'\0';
123 
    wcsncpy(wcfixedmode, mode, 4);
124 
    if (!wcspbrk(wcfixedmode, L"bt")) {
45446 ripley 125 
	wcscat(wcfixedmode, L"t");
44052 murdoch 126 
    }
127 
    return wcfixedmode;
128 
}
129 
 
130 
#else
131 
#define fixmode(mode) (mode)
132 
#define wcfixmode(mode) (mode)
133 
#endif
134 
 
29747 ripley 135 
FILE *R_fopen(const char *filename, const char *mode)
136 
{
44052 murdoch 137 
    return(filename ? fopen(filename, fixmode(mode)) : NULL );
29747 ripley 138 
}
139 
 
40700 ripley 140 
/* The point of this function is to allow file names in foreign
141 
   character sets.  On Unix-alikes in a UTF-8 locale all that is
142 
   needed is to convert file names to UTF-8, since they will be stored
143 
   in UTF-8.  For other locales, it seems that there is no way to specify
144 
   a file name in UTF-8.
145 
 
146 
   On NT-based versions of Windows, file names are stored in 'Unicode'
147 
   (UCS-2), and _wfopen is provided to access them by UCS-2 names.
148 
*/
149 
 
44008 ripley 150 
#if defined(Win32)
151 
 
54524 ripley 152 
#define BSIZE 100000
44008 ripley 153 
wchar_t *filenameToWchar(const SEXP fn, const Rboolean expand)
40700 ripley 154 
{
54524 ripley 155 
    static wchar_t filename[BSIZE+1];
40700 ripley 156 
    void *obj;
44008 ripley 157 
    const char *from = "", *inbuf;
158 
    char *outbuf;
40700 ripley 159 
    size_t inb, outb, res;
44008 ripley 160 
 
44761 ripley 161 
    if(!strlen(CHAR(fn))) {
162 
	wcscpy(filename, L"");
163 
	return filename;
164 
    }
40700 ripley 165 
    if(IS_LATIN1(fn)) from = "latin1";
44054 ripley 166 
    if(IS_UTF8(fn)) from = "UTF-8";
54753 ripley 167 
    if(IS_BYTES(fn)) error(_("encoding of a filename cannot be 'bytes'"));
40700 ripley 168 
    obj = Riconv_open("UCS-2LE", from);
44008 ripley 169 
    if(obj == (void *)(-1))
54753 ripley 170 
	error(_("unsupported conversion from '%s' in codepage %d"),
45680 ripley 171 
	      from, localeCP);
40700 ripley 172 
 
173 
    if(expand) inbuf = R_ExpandFileName(CHAR(fn)); else inbuf = CHAR(fn);
174 
 
54524 ripley 175 
    inb = strlen(inbuf)+1; outb = 2*BSIZE;
40700 ripley 176 
    outbuf = (char *) filename;
177 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
178 
    Riconv_close(obj);
54524 ripley 179 
    if(inb > 0) error(_("file name conversion problem -- name too long?"));
44762 ripley 180 
    if(res == -1) error(_("file name conversion problem"));
40700 ripley 181 
 
44008 ripley 182 
    return filename;
183 
}
184 
 
44016 ripley 185 
FILE *R_wfopen(const wchar_t *filename, const wchar_t *mode)
186 
{
44695 ripley 187 
    return filename ? _wfopen(filename, wcfixmode(mode)) : NULL;
44016 ripley 188 
}
189 
 
190 
 
44008 ripley 191 
FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)
192 
{
193 
    wchar_t wmode[10];
194 
 
44695 ripley 195 
    if(fn == NA_STRING) return NULL;
44052 murdoch 196 
    mbstowcs(wmode, fixmode(mode), 10);
44008 ripley 197 
    return _wfopen(filenameToWchar(fn, expand), wmode);
40700 ripley 198 
}
199 
#else
200 
FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)
201 
{
63181 ripley 202 
    const void *vmax = vmaxget();
203 
    const char *filename = translateChar(fn), *res;
44695 ripley 204 
    if(fn == NA_STRING || !filename) return NULL;
63181 ripley 205 
    if(expand) res = R_ExpandFileName(filename);
206 
    else res = filename;
207 
    vmaxset(vmax);
208 
    return fopen(res, mode);
40700 ripley 209 
}
210 
#endif
211 
 
29747 ripley 212 
/*
213 
 *  SYSTEM INFORMATION
214 
 */
215 
 
45446 ripley 216 
	  /* The location of the R system files */
29747 ripley 217 
 
44201 ripley 218 
char *R_HomeDir(void)
29747 ripley 219 
{
220 
    return getenv("R_HOME");
221 
}
222 
 
51245 ripley 223 
/* This is a primitive (with no arguments) */
36990 ripley 224 
SEXP attribute_hidden do_interactive(SEXP call, SEXP op, SEXP args, SEXP rho)
29747 ripley 225 
{
51245 ripley 226 
    checkArity(op, args);
41894 ripley 227 
    return ScalarLogical( (R_Interactive) ? 1 : 0 );
29747 ripley 228 
}
229 
 
36990 ripley 230 
SEXP attribute_hidden do_tempdir(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 231 
{
41894 ripley 232 
    checkArity(op, args);
233 
    return mkString(R_TempDir);
29747 ripley 234 
}
235 
 
236 
 
36990 ripley 237 
SEXP attribute_hidden do_tempfile(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 238 
{
54876 murdoch 239 
    SEXP  ans, pattern, fileext, tempdir;
240 
    const char *tn, *td, *te;
41783 ripley 241 
    char *tm;
54876 murdoch 242 
    int i, n1, n2, n3, slen;
29747 ripley 243 
 
244 
    checkArity(op, args);
54876 murdoch 245 
    pattern = CAR(args); n1 = length(pattern); args = CDR(args);
246 
    tempdir = CAR(args); n2 = length(tempdir); args = CDR(args);
247 
    fileext = CAR(args); n3 = length(fileext);
29747 ripley 248 
    if (!isString(pattern))
45446 ripley 249 
	error(_("invalid filename pattern"));
29747 ripley 250 
    if (!isString(tempdir))
45446 ripley 251 
	error(_("invalid '%s' value"), "tempdir");
54876 murdoch 252 
    if (!isString(fileext))
253 
	error(_("invalid file extension"));
29747 ripley 254 
    if (n1 < 1)
41686 ripley 255 
	error(_("no 'pattern'"));
29747 ripley 256 
    if (n2 < 1)
41686 ripley 257 
	error(_("no 'tempdir'"));
54876 murdoch 258 
    if (n3 < 1)
259 
        error(_("no 'fileext'"));
29747 ripley 260 
    slen = (n1 > n2) ? n1 : n2;
54876 murdoch 261 
    slen = (n3 > slen) ? n3 : slen;
29747 ripley 262 
    PROTECT(ans = allocVector(STRSXP, slen));
263 
    for(i = 0; i < slen; i++) {
40705 ripley 264 
	tn = translateChar( STRING_ELT( pattern , i%n1 ) );
265 
	td = translateChar( STRING_ELT( tempdir , i%n2 ) );
54876 murdoch 266 
	te = translateChar( STRING_ELT( fileext , i%n3 ) );
29747 ripley 267 
	/* try to get a new file name */
54876 murdoch 268 
	tm = R_tmpnam2(tn, td, te);
29747 ripley 269 
	SET_STRING_ELT(ans, i, mkChar(tm));
270 
	if(tm) free(tm);
271 
    }
272 
    UNPROTECT(1);
273 
    return (ans);
274 
}
275 
 
41781 ripley 276 
FILE *R_popen(const char *command, const char *type)
29747 ripley 277 
{
278 
    FILE *fp;
61027 ripley 279 
#ifdef __APPLE__
29747 ripley 280 
    /* Luke recommends this to fix PR#1140 */
281 
    sigset_t ss;
39757 urbaneks 282 
    sigemptyset(&ss);
29747 ripley 283 
    sigaddset(&ss, SIGPROF);
284 
    sigprocmask(SIG_BLOCK, &ss,  NULL);
285 
    fp = popen(command, type);
286 
    sigprocmask(SIG_UNBLOCK, &ss, NULL);
287 
#else
288 
    fp = popen(command, type);
289 
#endif
290 
    return fp;
291 
}
292 
 
53147 ripley 293 
#ifdef HAVE_SYS_WAIT_H
294 
# include <sys/wait.h>
295 
#endif
296 
 
41781 ripley 297 
int R_system(const char *command)
29747 ripley 298 
{
52799 ripley 299 
    int res;
61027 ripley 300 
#ifdef __APPLE__
29747 ripley 301 
    /* Luke recommends this to fix PR#1140 */
302 
    sigset_t ss;
39754 urbaneks 303 
    sigemptyset(&ss);
29747 ripley 304 
    sigaddset(&ss, SIGPROF);
305 
    sigprocmask(SIG_BLOCK, &ss,  NULL);
31157 iacus 306 
#ifdef HAVE_AQUA
61483 ripley 307 
    if(ptr_CocoaSystem) res = ptr_CocoaSystem(command); else
40376 ripley 308 
#endif
52799 ripley 309 
    res = system(command);
29747 ripley 310 
    sigprocmask(SIG_UNBLOCK, &ss, NULL);
61472 ripley 311 
#else // not APPLE
52799 ripley 312 
    res = system(command);
29747 ripley 313 
#endif
53147 ripley 314 
#ifdef HAVE_SYS_WAIT_H
315 
    if (WIFEXITED(res)) res = WEXITSTATUS(res);
316 
    else res = 0;
52799 ripley 317 
#else
53147 ripley 318 
    /* assume that this is shifted if a multiple of 256 */
319 
    if ((res % 256) == 0) res = res/256;
52799 ripley 320 
#endif
321 
    return res;
29747 ripley 322 
}
323 
 
41344 ripley 324 
#if defined(__APPLE__)
29747 ripley 325 
# include <crt_externs.h>
326 
# define environ (*_NSGetEnviron())
327 
#else
328 
extern char ** environ;
329 
#endif
330 
 
43997 ripley 331 
#ifdef Win32
332 
/* _wenviron is declared in stdlib.h */
333 
# define WIN32_LEAN_AND_MEAN 1
47999 ripley 334 
# include <windows.h> /* _wgetenv etc */
43997 ripley 335 
#endif
336 
 
36990 ripley 337 
SEXP attribute_hidden do_getenv(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 338 
{
339 
    int i, j;
340 
    SEXP ans;
341 
 
342 
    checkArity(op, args);
343 
 
344 
    if (!isString(CAR(args)))
41686 ripley 345 
	error(_("wrong type for argument"));
29747 ripley 346 
 
40376 ripley 347 
    if (!isString(CADR(args)) || LENGTH(CADR(args)) != 1)
41686 ripley 348 
	error(_("wrong type for argument"));
40376 ripley 349 
 
29747 ripley 350 
    i = LENGTH(CAR(args));
351 
    if (i == 0) {
47460 ripley 352 
#ifdef Win32
43997 ripley 353 
	int n = 0, N;
47999 ripley 354 
	wchar_t **w;
355 
	for (i = 0, w = _wenviron; *w != NULL; i++, w++)
356 
	    n = max(n, wcslen(*w));
51398 ripley 357 
	N = 3*n+1;
51444 ripley 358 
	char buf[N];
43997 ripley 359 
	PROTECT(ans = allocVector(STRSXP, i));
47999 ripley 360 
	for (i = 0, w = _wenviron; *w != NULL; i++, w++) {
361 
	    wcstoutf8(buf, *w, N); buf[N-1] = '\0';
44986 ripley 362 
	    SET_STRING_ELT(ans, i, mkCharCE(buf, CE_UTF8));
43997 ripley 363 
	}
364 
#else
40392 ripley 365 
	char **e;
29747 ripley 366 
	for (i = 0, e = environ; *e != NULL; i++, e++);
367 
	PROTECT(ans = allocVector(STRSXP, i));
368 
	for (i = 0, e = environ; *e != NULL; i++, e++)
369 
	    SET_STRING_ELT(ans, i, mkChar(*e));
43997 ripley 370 
#endif
29747 ripley 371 
    } else {
372 
	PROTECT(ans = allocVector(STRSXP, i));
373 
	for (j = 0; j < i; j++) {
47460 ripley 374 
#ifdef Win32
43997 ripley 375 
	    const wchar_t *wnm = wtransChar(STRING_ELT(CAR(args), j));
47999 ripley 376 
	    wchar_t *w = _wgetenv(wnm);
377 
	    if (w == NULL)
43997 ripley 378 
		SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
379 
	    else {
47999 ripley 380 
		int n = wcslen(w), N = 3*n+1; /* UCS-2 maps to <=3 UTF-8 */
59752 ripley 381 
		R_CheckStack2(N);
51398 ripley 382 
		char buf[N];
47999 ripley 383 
		wcstoutf8(buf, w, N); buf[N-1] = '\0'; /* safety */
384 
		SET_STRING_ELT(ans, j, mkCharCE(buf, CE_UTF8));
43997 ripley 385 
	    }
386 
#else
387 
	    char *s = getenv(translateChar(STRING_ELT(CAR(args), j)));
29747 ripley 388 
	    if (s == NULL)
40376 ripley 389 
		SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
40692 ripley 390 
	    else {
43039 luke 391 
		SEXP tmp;
44986 ripley 392 
		if(known_to_be_latin1) tmp = mkCharCE(s, CE_LATIN1);
393 
		else if(known_to_be_utf8) tmp = mkCharCE(s, CE_UTF8);
43039 luke 394 
		else tmp = mkChar(s);
40692 ripley 395 
		SET_STRING_ELT(ans, j, tmp);
396 
	    }
43997 ripley 397 
#endif
29747 ripley 398 
	}
399 
    }
400 
    UNPROTECT(1);
401 
    return (ans);
402 
}
403 
 
47460 ripley 404 
#ifdef Win32
43997 ripley 405 
static int Rwputenv(const wchar_t *nm, const wchar_t *val)
406 
{
47999 ripley 407 
    wchar_t *buf;
408 
    buf = (wchar_t *) malloc((wcslen(nm) + wcslen(val) + 2) * sizeof(wchar_t));
409 
    if(!buf) return 1;
48007 ripley 410 
    /* previously wsprintfW, which had a limit of 1024 chars */
411 
    wcscpy(buf, nm); wcscat(buf, L"="); wcscat(buf, val);
47999 ripley 412 
    if(_wputenv(buf)) return 1;
413 
    /* no free here: storage remains in use */
414 
    return 0;
43997 ripley 415 
}
416 
#elif !defined(HAVE_SETENV) && defined(HAVE_PUTENV)
41783 ripley 417 
static int Rputenv(const char *nm, const char *val)
29747 ripley 418 
{
419 
    char *buf;
40376 ripley 420 
    buf = (char *) malloc((strlen(nm) + strlen(val) + 2) * sizeof(char));
29747 ripley 421 
    if(!buf) return 1;
40376 ripley 422 
    sprintf(buf, "%s=%s", nm, val);
40392 ripley 423 
    if(putenv(buf)) return 1;
29747 ripley 424 
    /* no free here: storage remains in use */
425 
    return 0;
426 
}
427 
#endif
428 
 
429 
 
40473 ripley 430 
SEXP attribute_hidden do_setenv(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 431 
{
40376 ripley 432 
#if defined(HAVE_PUTENV) || defined(HAVE_SETENV)
29747 ripley 433 
    int i, n;
40376 ripley 434 
    SEXP ans, nm, vars;
435 
 
436 
    checkArity(op, args);
437 
 
438 
    if (!isString(nm = CAR(args)))
41686 ripley 439 
	error(_("wrong type for argument"));
40376 ripley 440 
    if (!isString(vars = CADR(args)))
41686 ripley 441 
	error(_("wrong type for argument"));
40376 ripley 442 
    if(LENGTH(nm) != LENGTH(vars))
41686 ripley 443 
	error(_("wrong length for argument"));
40376 ripley 444 
 
445 
    n = LENGTH(vars);
446 
    PROTECT(ans = allocVector(LGLSXP, n));
447 
#ifdef HAVE_SETENV
448 
    for (i = 0; i < n; i++)
40692 ripley 449 
	LOGICAL(ans)[i] = setenv(translateChar(STRING_ELT(nm, i)),
450 
				 translateChar(STRING_ELT(vars, i)),
40376 ripley 451 
				 1) == 0;
47460 ripley 452 
#elif defined(Win32)
43997 ripley 453 
    for (i = 0; i < n; i++)
454 
	LOGICAL(ans)[i] = Rwputenv(wtransChar(STRING_ELT(nm, i)),
455 
				   wtransChar(STRING_ELT(vars, i))) == 0;
40376 ripley 456 
#else
457 
    for (i = 0; i < n; i++)
40692 ripley 458 
	LOGICAL(ans)[i] = Rputenv(translateChar(STRING_ELT(nm, i)),
459 
				  translateChar(STRING_ELT(vars, i))) == 0;
40376 ripley 460 
#endif
461 
    UNPROTECT(1);
462 
    return ans;
463 
#else
41571 ripley 464 
    error(_("'Sys.setenv' is not available on this system"));
40376 ripley 465 
    return R_NilValue; /* -Wall */
466 
#endif
467 
}
468 
 
469 
SEXP attribute_hidden do_unsetenv(SEXP call, SEXP op, SEXP args, SEXP env)
470 
{
471 
    int i, n;
29747 ripley 472 
    SEXP ans, vars;
473 
 
474 
    checkArity(op, args);
475 
 
32415 ripley 476 
    if (!isString(vars = CAR(args)))
45446 ripley 477 
	error(_("wrong type for argument"));
29747 ripley 478 
    n = LENGTH(vars);
41571 ripley 479 
 
480 
#if defined(HAVE_UNSETENV) || defined(HAVE_PUTENV_UNSET) || defined(HAVE_PUTENV_UNSET2)
40391 ripley 481 
#ifdef HAVE_UNSETENV
40692 ripley 482 
    for (i = 0; i < n; i++) unsetenv(translateChar(STRING_ELT(vars, i)));
40391 ripley 483 
#elif defined(HAVE_PUTENV_UNSET)
42427 ripley 484 
    for (i = 0; i < n; i++) {
485 
	char buf[1000];
486 
	snprintf(buf, 1000, "%s",  translateChar(STRING_ELT(vars, i)));
487 
	putenv(buf);
488 
    }
40391 ripley 489 
#elif defined(HAVE_PUTENV_UNSET2)
47460 ripley 490 
# ifdef Win32
41571 ripley 491 
    for (i = 0; i < n; i++) {
43997 ripley 492 
	const wchar_t *w = wtransChar(STRING_ELT(vars, i));
51398 ripley 493 
	wchar_t buf[2*wcslen(w)];
47999 ripley 494 
	wcscpy(buf, w);
495 
	wcscat(buf, L"=");
496 
	_wputenv(buf);
43997 ripley 497 
    }
498 
# else
499 
    for (i = 0; i < n; i++) {
40376 ripley 500 
	char buf[1000];
41571 ripley 501 
	snprintf(buf, 1000, "%s=", translateChar(STRING_ELT(vars, i)));
502 
	putenv(buf);
29747 ripley 503 
    }
43997 ripley 504 
# endif
40376 ripley 505 
#endif
41571 ripley 506 
 
507 
#elif defined(HAVE_PUTENV) || defined(HAVE_SETENV)
508 
    warning(_("this system cannot unset environment variables: setting to \"\""));
509 
    n = LENGTH(vars);
510 
    for (i = 0; i < n; i++) {
511 
#ifdef HAVE_SETENV
42780 urbaneks 512 
	setenv(translateChar(STRING_ELT(vars, i)), "", 1);
41571 ripley 513 
#else
514 
	Rputenv(translateChar(STRING_ELT(vars, i)), "");
515 
#endif
516 
    }
517 
 
518 
#else
519 
    warning(_("'Sys.unsetenv' is not available on this system"));
520 
#endif
521 
 
522 
    PROTECT(ans = allocVector(LGLSXP, n));
40403 ripley 523 
    for (i = 0; i < n; i++)
45446 ripley 524 
	LOGICAL(ans)[i] = !getenv(translateChar(STRING_ELT(vars, i)));
41571 ripley 525 
    UNPROTECT(1);
29747 ripley 526 
    return ans;
527 
}
32415 ripley 528 
 
48904 ripley 529 
#include <iconv.h>
32415 ripley 530 
 
32642 ripley 531 
#ifdef HAVE_ICONVLIST
32482 ripley 532 
static unsigned int cnt;
533 
 
40376 ripley 534 
static int
42623 ripley 535 
count_one (unsigned int namescount, const char * const *names, void *data)
32482 ripley 536 
{
537 
    cnt += namescount;
538 
    return 0;
539 
}
540 
 
40376 ripley 541 
static int
42623 ripley 542 
write_one (unsigned int namescount, const char * const *names, void *data)
32482 ripley 543 
{
544 
  unsigned int i;
545 
  SEXP ans = (SEXP) data;
40376 ripley 546 
 
32482 ripley 547 
  for (i = 0; i < namescount; i++)
548 
      SET_STRING_ELT(ans, cnt++, mkChar(names[i]));
549 
  return 0;
550 
}
32486 ripley 551 
#endif
32482 ripley 552 
 
32551 ripley 553 
#include "RBufferUtils.h"
554 
 
49095 ripley 555 
/* iconv(x, from, to, sub, mark) */
36990 ripley 556 
SEXP attribute_hidden do_iconv(SEXP call, SEXP op, SEXP args, SEXP env)
32415 ripley 557 
{
43034 ripley 558 
    SEXP ans, x = CAR(args), si;
36081 ripley 559 
    void * obj;
42623 ripley 560 
    const char *inbuf;
32551 ripley 561 
    char *outbuf;
41783 ripley 562 
    const char *sub;
32415 ripley 563 
    size_t inb, outb, res;
32551 ripley 564 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
55264 ripley 565 
    Rboolean isRawlist = FALSE;
40376 ripley 566 
 
32415 ripley 567 
    checkArity(op, args);
32482 ripley 568 
    if(isNull(x)) {  /* list locales */
32642 ripley 569 
#ifdef HAVE_ICONVLIST
32482 ripley 570 
	cnt = 0;
571 
	iconvlist(count_one, NULL);
572 
	PROTECT(ans = allocVector(STRSXP, cnt));
573 
	cnt = 0;
574 
	iconvlist(write_one, (void *)ans);
575 
#else
42623 ripley 576 
	PROTECT(ans = R_NilValue);
32482 ripley 577 
#endif
578 
    } else {
55260 ripley 579 
	int mark, toRaw;
41783 ripley 580 
	const char *from, *to;
40672 ripley 581 
	Rboolean isLatin1 = FALSE, isUTF8 = FALSE;
582 
 
55260 ripley 583 
	args = CDR(args);
584 
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
41686 ripley 585 
	    error(_("invalid '%s' argument"), "from");
55260 ripley 586 
	from = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
587 
	args = CDR(args);
588 
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
41686 ripley 589 
	    error(_("invalid '%s' argument"), "to");
55260 ripley 590 
	to = CHAR(STRING_ELT(CAR(args), 0));
591 
	args = CDR(args);
592 
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
41686 ripley 593 
	    error(_("invalid '%s' argument"), "sub");
55260 ripley 594 
	if(STRING_ELT(CAR(args), 0) == NA_STRING) sub = NULL;
595 
	else sub = translateChar(STRING_ELT(CAR(args), 0));
596 
	args = CDR(args);
597 
	mark = asLogical(CAR(args));
49095 ripley 598 
	if(mark == NA_LOGICAL)
599 
	    error(_("invalid '%s' argument"), "mark");
55260 ripley 600 
	args = CDR(args);
601 
	toRaw = asLogical(CAR(args));
602 
	if(toRaw == NA_LOGICAL)
603 
	    error(_("invalid '%s' argument"), "toRaw");
44770 ripley 604 
	/* some iconv's allow "UTF8", but libiconv does not */
45514 ripley 605 
	if(streql(from, "UTF8") || streql(from, "utf8") ) from = "UTF-8";
606 
	if(streql(to, "UTF8") || streql(from, "utf8") ) to = "UTF-8";
40672 ripley 607 
	/* Should we do something about marked CHARSXPs in 'from = ""'? */
608 
	if(streql(to, "UTF-8")) isUTF8 = TRUE;
44655 ripley 609 
	if(streql(to, "latin1") || streql(to, "ISO_8859-1")
610 
	    || streql(to, "CP1252")) isLatin1 = TRUE;
40672 ripley 611 
	if(streql(to, "") && known_to_be_latin1) isLatin1 = TRUE;
612 
	if(streql(to, "") && known_to_be_utf8) isUTF8 = TRUE;
613 
	obj = Riconv_open(to, from);
32482 ripley 614 
	if(obj == (iconv_t)(-1))
45703 ripley 615 
#ifdef Win32
54753 ripley 616 
	    error(_("unsupported conversion from '%s' to '%s' in codepage %d"),
45703 ripley 617 
		  from, to, localeCP);
618 
#else
46133 ripley 619 
	    error(_("unsupported conversion from '%s' to '%s'"), from, to);
45703 ripley 620 
#endif
55264 ripley 621 
	isRawlist = (TYPEOF(x) == VECSXP);
622 
	if(isRawlist) {
623 
	    if(toRaw)
624 
		PROTECT(ans = duplicate(x));
625 
	    else {
626 
		PROTECT(ans = allocVector(STRSXP, LENGTH(x)));
627 
		DUPLICATE_ATTRIB(ans, x);
628 
	    }
629 
	} else {
630 
	    if(TYPEOF(x) != STRSXP)
631 
		error(_("'x' must be a character vector"));
632 
	    if(toRaw) {
633 
		PROTECT(ans = allocVector(VECSXP, LENGTH(x)));
634 
		DUPLICATE_ATTRIB(ans, x);
635 
	    } else
636 
		PROTECT(ans = duplicate(x));
637 
	}
41899 ripley 638 
	R_AllocStringBuffer(0, &cbuff);  /* 0 -> default */
59052 ripley 639 
	for(R_xlen_t i = 0; i < XLENGTH(x); i++) {
55264 ripley 640 
	    if (isRawlist) {
641 
		si = VECTOR_ELT(x, i);
642 
		if (TYPEOF(si) == NILSXP) {
643 
		    if (!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
644 
		    continue;
645 
		} else if (TYPEOF(si) != RAWSXP)
646 
		    error(_("'x' must be a list of NULL or raw vectors"));
647 
	    } else {
648 
		si = STRING_ELT(x, i);
649 
		if (si == NA_STRING) {
650 
		    if(!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
651 
		    continue;
652 
		}
55260 ripley 653 
	    }
32551 ripley 654 
	top_of_loop:
55264 ripley 655 
	    inbuf = isRawlist ? (const char *) RAW(si) : CHAR(si);
55260 ripley 656 
	    inb = LENGTH(si);
32551 ripley 657 
	    outbuf = cbuff.data; outb = cbuff.bufsize - 1;
32482 ripley 658 
	    /* First initialize output */
36081 ripley 659 
	    Riconv (obj, NULL, NULL, &outbuf, &outb);
45446 ripley 660 
	next_char:
32551 ripley 661 
	    /* Then convert input  */
42623 ripley 662 
	    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
32482 ripley 663 
	    *outbuf = '\0';
40376 ripley 664 
	    /* other possible error conditions are incomplete
32601 ripley 665 
	       and invalid multibyte chars */
32551 ripley 666 
	    if(res == -1 && errno == E2BIG) {
667 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
668 
		goto top_of_loop;
51812 ripley 669 
	    } else if(res == -1 && sub &&
670 
		      (errno == EILSEQ || errno == EINVAL)) {
32601 ripley 671 
		/* it seems this gets thrown for non-convertible input too */
672 
		if(strcmp(sub, "byte") == 0) {
673 
		    if(outb < 5) {
674 
			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
675 
			goto top_of_loop;
676 
		    }
32642 ripley 677 
		    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
32601 ripley 678 
		    outbuf += 4; outb -= 4;
679 
		} else {
59096 ripley 680 
		    size_t j;
32601 ripley 681 
		    if(outb < strlen(sub)) {
682 
			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
683 
			goto top_of_loop;
684 
		    }
45446 ripley 685 
		    memcpy(outbuf, sub, j = strlen(sub));
42804 maechler 686 
		    outbuf += j;
687 
		    outb -= j;
32601 ripley 688 
		}
689 
		inbuf++; inb--;
690 
		goto next_char;
691 
	    }
40376 ripley 692 
 
55260 ripley 693 
	    if(toRaw) {
694 
		if(res != -1 && inb == 0) {
59096 ripley 695 
		    size_t nout = cbuff.bufsize - 1 - outb;
55260 ripley 696 
		    SEXP el = allocVector(RAWSXP, nout);
697 
		    memcpy(RAW(el), cbuff.data, nout);
698 
		    SET_VECTOR_ELT(ans, i, el);
699 
		} /* otherwise is already NULL */
700 
	    } else {
701 
		if(res != -1 && inb == 0) {
702 
		    cetype_t ienc = CE_NATIVE;
703 
 
59096 ripley 704 
		    size_t nout = cbuff.bufsize - 1 - outb;
55260 ripley 705 
		    if(mark) {
706 
			if(isLatin1) ienc = CE_LATIN1;
707 
			else if(isUTF8) ienc = CE_UTF8;
708 
		    }
59097 ripley 709 
		    SET_STRING_ELT(ans, i,
710 
				   mkCharLenCE(cbuff.data, (int) nout, ienc));
55260 ripley 711 
		} else SET_STRING_ELT(ans, i, NA_STRING);
40672 ripley 712 
	    }
32482 ripley 713 
	}
36081 ripley 714 
	Riconv_close(obj);
32551 ripley 715 
	R_FreeStringBuffer(&cbuff);
32415 ripley 716 
    }
717 
    UNPROTECT(1);
718 
    return ans;
719 
}
32492 ripley 720 
 
44986 ripley 721 
cetype_t getCharCE(SEXP x)
43932 ripley 722 
{
723 
    if(TYPEOF(x) != CHARSXP)
51206 falcon 724 
	error(_("'%s' must be called on a CHARSXP"), "getCharCE");
43932 ripley 725 
    if(IS_UTF8(x)) return CE_UTF8;
726 
    else if(IS_LATIN1(x)) return CE_LATIN1;
54747 ripley 727 
    else if(IS_BYTES(x)) return CE_BYTES;
43932 ripley 728 
    else return CE_NATIVE;
729 
}
730 
 
731 
 
41781 ripley 732 
void * Riconv_open (const char* tocode, const char* fromcode)
32492 ripley 733 
{
44490 urbaneks 734 
#if defined Win32 || __APPLE__
44495 ripley 735 
# ifdef Win32
52753 ripley 736 
    const char *cp = "ASCII";
46512 ripley 737 
#  ifndef SUPPORT_UTF8_WIN32 /* Always, at present */
738 
    char to[20] = "";
739 
    if (localeCP > 0) {snprintf(to, 20, "CP%d", localeCP); cp = to;}
44495 ripley 740 
#  endif
741 
# else /* __APPLE__ */
52753 ripley 742 
    const char *cp = "UTF-8";
44490 urbaneks 743 
    if (latin1locale) cp = "ISO-8859-1";
44495 ripley 744 
    else if (!utf8locale) cp = locale2charset(NULL);
745 
# endif
44490 urbaneks 746 
    if (!*tocode && !*fromcode) return iconv_open(cp, cp);
46512 ripley 747 
    if(!*tocode)  return iconv_open(cp, fromcode);
748 
    else if(!*fromcode) return iconv_open(tocode, cp);
36081 ripley 749 
    else return iconv_open(tocode, fromcode);
32720 ripley 750 
#else
42623 ripley 751 
    return iconv_open(tocode, fromcode);
32720 ripley 752 
#endif
32492 ripley 753 
}
754 
 
54764 ripley 755 
/* Should be defined in config.h, but prior to 2.13.0 was only checked
756 
   if the NLS was enabled  */
42627 ripley 757 
#ifndef ICONV_CONST
758 
# define ICONV_CONST
759 
#endif
760 
 
41807 rgentlem 761 
size_t Riconv (void *cd, const char **inbuf, size_t *inbytesleft,
32493 ripley 762 
	       char **outbuf, size_t *outbytesleft)
32492 ripley 763 
{
44161 ripley 764 
    /* here libiconv has const char **, glibc has char ** for inbuf */
45446 ripley 765 
    return iconv((iconv_t) cd, (ICONV_CONST char **) inbuf, inbytesleft,
43034 ripley 766 
		 outbuf, outbytesleft);
32492 ripley 767 
}
768 
 
32493 ripley 769 
int Riconv_close (void *cd)
32492 ripley 770 
{
771 
    return iconv_close((iconv_t) cd);
772 
}
40672 ripley 773 
 
46133 ripley 774 
static void *latin1_obj = NULL, *utf8_obj=NULL, *ucsmb_obj=NULL,
775 
    *ucsutf8_obj=NULL;
40712 ripley 776 
 
63181 ripley 777 
/* This may return a R_alloc-ed result, so the caller has to manage the
778 
   R_alloc stack */
41784 ripley 779 
const char *translateChar(SEXP x)
40672 ripley 780 
{
781 
    void * obj;
41883 ripley 782 
    const char *inbuf, *ans = CHAR(x);
63223 ripley 783 
    char *outbuf;
40672 ripley 784 
    size_t inb, outb, res;
44986 ripley 785 
    cetype_t ienc = getCharCE(x);
40672 ripley 786 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
787 
 
43932 ripley 788 
    if(TYPEOF(x) != CHARSXP)
789 
	error(_("'%s' must be called on a CHARSXP"), "translateChar");
43717 ripley 790 
    if(x == NA_STRING || !(ENC_KNOWN(x))) return ans;
54753 ripley 791 
    if(IS_BYTES(x))
792 
	error(_("translating strings with \"bytes\" encoding is not allowed"));
40672 ripley 793 
    if(utf8locale && IS_UTF8(x)) return ans;
794 
    if(latin1locale && IS_LATIN1(x)) return ans;
58404 urbaneks 795 
    if(IS_ASCII(x)) return ans;
40672 ripley 796 
 
40712 ripley 797 
    if(IS_LATIN1(x)) {
798 
	if(!latin1_obj) {
799 
	    obj = Riconv_open("", "latin1");
800 
	    /* should never happen */
45703 ripley 801 
	    if(obj == (void *)(-1))
802 
#ifdef Win32
54753 ripley 803 
		error(_("unsupported conversion from '%s' in codepage %d"),
45703 ripley 804 
		      "latin1", localeCP);
805 
#else
46133 ripley 806 
	        error(_("unsupported conversion from '%s' to '%s'"),
807 
		      "latin1", "");
45703 ripley 808 
#endif
40712 ripley 809 
	    latin1_obj = obj;
810 
	}
811 
	obj = latin1_obj;
812 
    } else {
813 
	if(!utf8_obj) {
814 
	    obj = Riconv_open("", "UTF-8");
815 
	    /* should never happen */
45703 ripley 816 
	    if(obj == (void *)(-1))
817 
#ifdef Win32
54753 ripley 818 
		error(_("unsupported conversion from '%s' in codepage %d"),
45703 ripley 819 
		      "latin1", localeCP);
820 
#else
46133 ripley 821 
	        error(_("unsupported conversion from '%s' to '%s'"),
822 
		      "latin1", "");
45703 ripley 823 
#endif
40712 ripley 824 
	    utf8_obj = obj;
825 
	}
45446 ripley 826 
	obj = utf8_obj;
40712 ripley 827 
    }
44054 ripley 828 
 
40672 ripley 829 
    R_AllocStringBuffer(0, &cbuff);
830 
top_of_loop:
45412 ripley 831 
    inbuf = ans; inb = strlen(inbuf);
40672 ripley 832 
    outbuf = cbuff.data; outb = cbuff.bufsize - 1;
833 
    /* First initialize output */
834 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
835 
next_char:
836 
    /* Then convert input  */
41884 ripley 837 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
40672 ripley 838 
    if(res == -1 && errno == E2BIG) {
839 
	R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
840 
	goto top_of_loop;
51812 ripley 841 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
44034 ripley 842 
	if(outb < 13) {
40672 ripley 843 
	    R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
844 
	    goto top_of_loop;
845 
	}
44034 ripley 846 
	if (ienc == CE_UTF8) {
847 
	    /* if starting in UTF-8, use \uxxxx */
848 
	    /* This must be the first byte */
59096 ripley 849 
	    size_t clen;
44034 ripley 850 
	    wchar_t wc;
851 
	    clen = utf8toucs(&wc, inbuf);
44100 ripley 852 
	    if(clen > 0 && inb >= clen) {
853 
		inbuf += clen; inb -= clen;
44034 ripley 854 
# ifndef Win32
44100 ripley 855 
		if((unsigned int) wc < 65536) {
44034 ripley 856 
# endif
44100 ripley 857 
		    snprintf(outbuf, 9, "<U+%04X>", (unsigned int) wc);
858 
		    outbuf += 8; outb -= 8;
44034 ripley 859 
# ifndef Win32
44100 ripley 860 
		} else {
861 
		    snprintf(outbuf, 13, "<U+%08X>", (unsigned int) wc);
45446 ripley 862 
		    outbuf += 12; outb -= 12;
44100 ripley 863 
		}
864 
# endif
44034 ripley 865 
	    } else {
44100 ripley 866 
		snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
867 
		outbuf += 4; outb -= 4;
868 
		inbuf++; inb--;
44034 ripley 869 
	    }
49591 ripley 870 
	} else {
44034 ripley 871 
	    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
872 
	    outbuf += 4; outb -= 4;
873 
	    inbuf++; inb--;
874 
	}
40672 ripley 875 
	goto next_char;
876 
    }
877 
    *outbuf = '\0';
878 
    res = strlen(cbuff.data) + 1;
63223 ripley 879 
    char *p = R_alloc(res, 1);
40672 ripley 880 
    memcpy(p, cbuff.data, res);
881 
    R_FreeStringBuffer(&cbuff);
882 
    return p;
883 
}
43932 ripley 884 
 
63223 ripley 885 
SEXP installTrChar(SEXP x)
886 
{
887 
    void * obj;
888 
    const char *inbuf, *ans = CHAR(x);
889 
    char *outbuf;
890 
    size_t inb, outb, res;
891 
    cetype_t ienc = getCharCE(x);
892 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
893 
 
894 
    if(TYPEOF(x) != CHARSXP)
895 
	error(_("'%s' must be called on a CHARSXP"), "translateChar");
896 
    if(x == NA_STRING || !(ENC_KNOWN(x))) return install(ans);
897 
    if(IS_BYTES(x))
898 
	error(_("translating strings with \"bytes\" encoding is not allowed"));
899 
    if(utf8locale && IS_UTF8(x)) return install(ans);
900 
    if(latin1locale && IS_LATIN1(x)) return install(ans);
901 
    if(IS_ASCII(x)) return install(ans);
902 
 
903 
    if(IS_LATIN1(x)) {
904 
	if(!latin1_obj) {
905 
	    obj = Riconv_open("", "latin1");
906 
	    /* should never happen */
907 
	    if(obj == (void *)(-1))
908 
#ifdef Win32
909 
		error(_("unsupported conversion from '%s' in codepage %d"),
910 
		      "latin1", localeCP);
911 
#else
912 
	        error(_("unsupported conversion from '%s' to '%s'"),
913 
		      "latin1", "");
914 
#endif
915 
	    latin1_obj = obj;
916 
	}
917 
	obj = latin1_obj;
918 
    } else {
919 
	if(!utf8_obj) {
920 
	    obj = Riconv_open("", "UTF-8");
921 
	    /* should never happen */
922 
	    if(obj == (void *)(-1))
923 
#ifdef Win32
924 
		error(_("unsupported conversion from '%s' in codepage %d"),
925 
		      "latin1", localeCP);
926 
#else
927 
	        error(_("unsupported conversion from '%s' to '%s'"),
928 
		      "latin1", "");
929 
#endif
930 
	    utf8_obj = obj;
931 
	}
932 
	obj = utf8_obj;
933 
    }
934 
 
935 
    R_AllocStringBuffer(0, &cbuff);
936 
top_of_loop:
937 
    inbuf = ans; inb = strlen(inbuf);
938 
    outbuf = cbuff.data; outb = cbuff.bufsize - 1;
939 
    /* First initialize output */
940 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
941 
next_char:
942 
    /* Then convert input  */
943 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
944 
    if(res == -1 && errno == E2BIG) {
945 
	R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
946 
	goto top_of_loop;
947 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
948 
	if(outb < 13) {
949 
	    R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
950 
	    goto top_of_loop;
951 
	}
952 
	if (ienc == CE_UTF8) {
953 
	    /* if starting in UTF-8, use \uxxxx */
954 
	    /* This must be the first byte */
955 
	    size_t clen;
956 
	    wchar_t wc;
957 
	    clen = utf8toucs(&wc, inbuf);
958 
	    if(clen > 0 && inb >= clen) {
959 
		inbuf += clen; inb -= clen;
960 
# ifndef Win32
961 
		if((unsigned int) wc < 65536) {
962 
# endif
963 
		    snprintf(outbuf, 9, "<U+%04X>", (unsigned int) wc);
964 
		    outbuf += 8; outb -= 8;
965 
# ifndef Win32
966 
		} else {
967 
		    snprintf(outbuf, 13, "<U+%08X>", (unsigned int) wc);
968 
		    outbuf += 12; outb -= 12;
969 
		}
970 
# endif
971 
	    } else {
972 
		snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
973 
		outbuf += 4; outb -= 4;
974 
		inbuf++; inb--;
975 
	    }
976 
	} else {
977 
	    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
978 
	    outbuf += 4; outb -= 4;
979 
	    inbuf++; inb--;
980 
	}
981 
	goto next_char;
982 
    }
983 
    *outbuf = '\0';
984 
    SEXP Sans = install(cbuff.data);
985 
    R_FreeStringBuffer(&cbuff);
986 
    return Sans;
987 
}
988 
 
63181 ripley 989 
/* This may return a R_alloc-ed result, so the caller has to manage the
990 
   R_alloc stack */
54747 ripley 991 
const char *translateChar0(SEXP x)
992 
{
993 
    if(TYPEOF(x) != CHARSXP)
994 
	error(_("'%s' must be called on a CHARSXP"), "translateChar0");
995 
    if(IS_BYTES(x)) return CHAR(x);
996 
    return translateChar(x);
997 
}
998 
 
63181 ripley 999 
/* This may return a R_alloc-ed result, so the caller has to manage the
1000 
   R_alloc stack */
44054 ripley 1001 
const char *translateCharUTF8(SEXP x)
1002 
{
1003 
    void *obj;
1004 
    const char *inbuf, *ans = CHAR(x);
1005 
    char *outbuf, *p;
1006 
    size_t inb, outb, res;
1007 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
1008 
 
1009 
    if(TYPEOF(x) != CHARSXP)
1010 
	error(_("'%s' must be called on a CHARSXP"), "translateCharUTF8");
1011 
    if(x == NA_STRING) return ans;
54747 ripley 1012 
    if(IS_UTF8(x)) return ans;
58404 urbaneks 1013 
    if(IS_ASCII(x)) return ans;
54747 ripley 1014 
    if(IS_BYTES(x))
54753 ripley 1015 
	error(_("translating strings with \"bytes\" encoding is not allowed"));
44054 ripley 1016 
 
1017 
    obj = Riconv_open("UTF-8", IS_LATIN1(x) ? "latin1" : "");
45703 ripley 1018 
    if(obj == (void *)(-1))
1019 
#ifdef Win32
54753 ripley 1020 
	error(_("unsupported conversion from '%s' in codepage %d"),
54747 ripley 1021 
	      "latin1", localeCP);
45703 ripley 1022 
#else
54747 ripley 1023 
       error(_("unsupported conversion from '%s' to '%s'"), "latin1", "UTF-8");
45703 ripley 1024 
#endif
44054 ripley 1025 
    R_AllocStringBuffer(0, &cbuff);
1026 
top_of_loop:
1027 
    inbuf = ans; inb = strlen(inbuf);
1028 
    outbuf = cbuff.data; outb = cbuff.bufsize - 1;
1029 
    /* First initialize output */
1030 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
1031 
next_char:
1032 
    /* Then convert input  */
1033 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
1034 
    if(res == -1 && errno == E2BIG) {
1035 
	R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1036 
	goto top_of_loop;
51812 ripley 1037 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
44054 ripley 1038 
	if(outb < 5) {
1039 
	    R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1040 
	    goto top_of_loop;
1041 
	}
1042 
	snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
1043 
	outbuf += 4; outb -= 4;
1044 
	inbuf++; inb--;
1045 
	goto next_char;
1046 
    }
1047 
    *outbuf = '\0';
1048 
    Riconv_close(obj);
1049 
    res = strlen(cbuff.data) + 1;
1050 
    p = R_alloc(res, 1);
1051 
    memcpy(p, cbuff.data, res);
1052 
    R_FreeStringBuffer(&cbuff);
1053 
    return p;
1054 
}
1055 
 
49631 ripley 1056 
 
43997 ripley 1057 
#ifdef Win32
49631 ripley 1058 
static const char TO_WCHAR[] = "UCS-2LE";
1059 
#else
1060 
# ifdef WORDS_BIGENDIAN
1061 
static const char TO_WCHAR[] = "UCS-4BE";
1062 
# else
1063 
static const char TO_WCHAR[] = "UCS-4LE";
1064 
# endif
1065 
#endif
1066 
 
43997 ripley 1067 
static void *latin1_wobj = NULL, *utf8_wobj=NULL;
1068 
 
49631 ripley 1069 
/* Translate from current encoding to wchar_t = UCS-2/4
50302 ripley 1070 
   NB: that wchar_t is UCS-4 is an assumption, but not easy to avoid.
1071 
*/
49631 ripley 1072 
 
63181 ripley 1073 
/* This may return a R_alloc-ed result, so the caller has to manage the
1074 
   R_alloc stack */
50302 ripley 1075 
attribute_hidden /* but not hidden on Windows, where it was used in tcltk.c */
43997 ripley 1076 
const wchar_t *wtransChar(SEXP x)
1077 
{
1078 
    void * obj;
1079 
    const char *inbuf, *ans = CHAR(x);
1080 
    char *outbuf;
1081 
    wchar_t *p;
1082 
    size_t inb, outb, res, top;
1083 
    Rboolean knownEnc = FALSE;
1084 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
1085 
 
1086 
    if(TYPEOF(x) != CHARSXP)
1087 
	error(_("'%s' must be called on a CHARSXP"), "wtransChar");
1088 
 
54747 ripley 1089 
    if(IS_BYTES(x))
54753 ripley 1090 
	error(_("translating strings with \"bytes\" encoding is not allowed"));
54747 ripley 1091 
 
43997 ripley 1092 
    if(IS_LATIN1(x)) {
1093 
	if(!latin1_wobj) {
49631 ripley 1094 
	    obj = Riconv_open(TO_WCHAR, "latin1");
45703 ripley 1095 
	    if(obj == (void *)(-1))
46133 ripley 1096 
		error(_("unsupported conversion from '%s' to '%s'"),
49631 ripley 1097 
		      "latin1", TO_WCHAR);
43997 ripley 1098 
	    latin1_wobj = obj;
1099 
	} else
1100 
	    obj = latin1_wobj;
1101 
	knownEnc = TRUE;
1102 
    } else if(IS_UTF8(x)) {
44161 ripley 1103 
	if(!utf8_wobj) {
49631 ripley 1104 
	    obj = Riconv_open(TO_WCHAR, "UTF-8");
45703 ripley 1105 
	    if(obj == (void *)(-1))
46133 ripley 1106 
		error(_("unsupported conversion from '%s' to '%s'"),
49631 ripley 1107 
		      "latin1", TO_WCHAR);
43997 ripley 1108 
	    utf8_wobj = obj;
1109 
	} else
1110 
	    obj = utf8_wobj;
1111 
	knownEnc = TRUE;
1112 
    } else {
49631 ripley 1113 
	obj = Riconv_open(TO_WCHAR, "");
45703 ripley 1114 
	if(obj == (void *)(-1))
49631 ripley 1115 
#ifdef Win32
54753 ripley 1116 
	    error(_("unsupported conversion to '%s' from codepage %d"),
49631 ripley 1117 
		  TO_WCHAR, localeCP);
1118 
#else
1119 
	    error(_("unsupported conversion from '%s' to '%s'"), "", TO_WCHAR);
1120 
#endif
43997 ripley 1121 
    }
1122 
 
1123 
    R_AllocStringBuffer(0, &cbuff);
1124 
top_of_loop:
1125 
    inbuf = ans; inb = strlen(inbuf);
1126 
    outbuf = cbuff.data; top = outb = cbuff.bufsize - 1;
1127 
    /* First initialize output */
1128 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
49635 ripley 1129 
next_char:
1130 
    /* Then convert input  */
43997 ripley 1131 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
1132 
    if(res == -1 && errno == E2BIG) {
1133 
	R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1134 
	goto top_of_loop;
51812 ripley 1135 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
49635 ripley 1136 
	if(outb < 5) {
1137 
	    R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1138 
	    goto top_of_loop;
1139 
	}
1140 
	snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
1141 
	outbuf += 4; outb -= 4;
1142 
	inbuf++; inb--;
1143 
	goto next_char;
1144 
	/* if(!knownEnc) Riconv_close(obj);
1145 
	   error(_("invalid input in wtransChar")); */
43997 ripley 1146 
    }
1147 
    if(!knownEnc) Riconv_close(obj);
1148 
    res = (top - outb);
49631 ripley 1149 
    /* terminator is 2 or 4 null bytes */
1150 
    p = (wchar_t *) R_alloc(res+4, 1);
1151 
    memset(p, 0, res+4);
43997 ripley 1152 
    memcpy(p, cbuff.data, res);
1153 
    R_FreeStringBuffer(&cbuff);
1154 
    return p;
1155 
}
1156 
 
49631 ripley 1157 
 
59101 ripley 1158 
extern void *Rf_AdobeSymbol2utf8(char* work, const char *c0, size_t nwork); /* from util.c */
44325 ripley 1159 
 
63181 ripley 1160 
/* This may return a R_alloc-ed result, so the caller has to manage the
1161 
   R_alloc stack */
44986 ripley 1162 
const char *reEnc(const char *x, cetype_t ce_in, cetype_t ce_out, int subst)
43932 ripley 1163 
{
1164 
    void * obj;
1165 
    const char *inbuf;
1166 
    char *outbuf, *p;
43997 ripley 1167 
    size_t inb, outb, res, top;
43932 ripley 1168 
    char *tocode = NULL, *fromcode = NULL;
44329 ripley 1169 
#ifdef Win32
1170 
    char buf[20];
1171 
#endif
43932 ripley 1172 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
1173 
 
44325 ripley 1174 
    /* We can only encode from Symbol to UTF-8 */
45446 ripley 1175 
    if(ce_in == ce_out || ce_out == CE_SYMBOL ||
43932 ripley 1176 
       ce_in == CE_ANY || ce_out == CE_ANY) return x;
44326 ripley 1177 
    if(ce_in == CE_SYMBOL) {
44330 ripley 1178 
	if(ce_out == CE_UTF8) {
59096 ripley 1179 
	    size_t nc = 3*strlen(x)+1; /* all in BMP */
44330 ripley 1180 
	    p = R_alloc(nc, 1);
45446 ripley 1181 
	    Rf_AdobeSymbol2utf8(p, x, nc);
44330 ripley 1182 
	    return p;
1183 
	} else return x;
44326 ripley 1184 
    }
43932 ripley 1185 
    if(utf8locale && ce_in == CE_NATIVE && ce_out == CE_UTF8) return x;
1186 
    if(utf8locale && ce_out == CE_NATIVE && ce_in == CE_UTF8) return x;
1187 
    if(latin1locale && ce_in == CE_NATIVE && ce_out == CE_LATIN1) return x;
1188 
    if(latin1locale && ce_out == CE_NATIVE && ce_in == CE_LATIN1) return x;
1189 
 
44094 ripley 1190 
    if(strIsASCII(x)) return x;
45446 ripley 1191 
 
43932 ripley 1192 
    switch(ce_in) {
44329 ripley 1193 
#ifdef Win32
45446 ripley 1194 
    case CE_NATIVE:
44329 ripley 1195 
	{
44655 ripley 1196 
	    /* Looks like CP1252 is treated as Latin-1 by iconv */
62580 ripley 1197 
	    snprintf(buf, 20, "CP%d", localeCP);
45446 ripley 1198 
	    fromcode = buf;
44329 ripley 1199 
	    break;
1200 
	}
44655 ripley 1201 
    case CE_LATIN1: fromcode = "CP1252"; break;
44329 ripley 1202 
#else
43932 ripley 1203 
    case CE_NATIVE: fromcode = ""; break;
44655 ripley 1204 
    case CE_LATIN1: fromcode = "latin1"; break;
44329 ripley 1205 
#endif
43932 ripley 1206 
    case CE_UTF8:   fromcode = "UTF-8"; break;
1207 
    default: return x;
1208 
    }
1209 
 
1210 
    switch(ce_out) {
46506 ripley 1211 
 #ifdef Win32
1212 
    case CE_NATIVE:
1213 
	{
1214 
	    /* avoid possible misidentification of CP1250 as LATIN-2 */
62580 ripley 1215 
	    snprintf(buf, 20, "CP%d", localeCP);
46506 ripley 1216 
	    tocode = buf;
1217 
	    break;
1218 
	}
1219 
#else
43932 ripley 1220 
    case CE_NATIVE: tocode = ""; break;
46506 ripley 1221 
#endif
43932 ripley 1222 
    case CE_LATIN1: tocode = "latin1"; break;
1223 
    case CE_UTF8:   tocode = "UTF-8"; break;
1224 
    default: return x;
1225 
    }
45446 ripley 1226 
 
43932 ripley 1227 
    obj = Riconv_open(tocode, fromcode);
1228 
    if(obj == (void *)(-1)) return x;
1229 
    R_AllocStringBuffer(0, &cbuff);
1230 
top_of_loop:
1231 
    inbuf = x; inb = strlen(inbuf);
43997 ripley 1232 
    outbuf = cbuff.data; top = outb = cbuff.bufsize - 1;
43932 ripley 1233 
    /* First initialize output */
1234 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
1235 
next_char:
1236 
    /* Then convert input  */
1237 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
1238 
    if(res == -1 && errno == E2BIG) {
1239 
	R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1240 
	goto top_of_loop;
51812 ripley 1241 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
43932 ripley 1242 
	switch(subst) {
1243 
	case 1: /* substitute hex */
1244 
	    if(outb < 5) {
1245 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1246 
		goto top_of_loop;
1247 
	    }
1248 
	    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
1249 
	    outbuf += 4; outb -= 4;
1250 
	    inbuf++; inb--;
45446 ripley 1251 
	    goto next_char;
43932 ripley 1252 
	    break;
1253 
	case 2: /* substitute . */
1254 
	    if(outb < 1) {
1255 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1256 
		goto top_of_loop;
1257 
	    }
43969 ripley 1258 
	    *outbuf++ = '.'; inbuf++; outb--; inb--;
45446 ripley 1259 
	    goto next_char;
43932 ripley 1260 
	    break;
46843 ripley 1261 
	case 3: /* substitute ? */
1262 
	    if(outb < 1) {
1263 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1264 
		goto top_of_loop;
1265 
	    }
1266 
	    *outbuf++ = '?'; inbuf++; outb--; inb--;
1267 
	    goto next_char;
1268 
	    break;
43932 ripley 1269 
	default: /* skip byte */
1270 
	    inbuf++; inb--;
45446 ripley 1271 
	    goto next_char;
43932 ripley 1272 
	}
1273 
    }
1274 
    Riconv_close(obj);
1275 
    *outbuf = '\0';
43997 ripley 1276 
    res = (top-outb)+1; /* strlen(cbuff.data) + 1; */
43932 ripley 1277 
    p = R_alloc(res, 1);
1278 
    memcpy(p, cbuff.data, res);
1279 
    R_FreeStringBuffer(&cbuff);
1280 
    return p;
1281 
}
43953 ripley 1282 
 
63218 ripley 1283 
#ifdef Win32
1284 
/* A version avoiding R_alloc for use in the Rgui editor */
1285 
void reEnc2(const char *x, char *y, int ny,
1286 
	    cetype_t ce_in, cetype_t ce_out, int subst)
1287 
{
1288 
    void * obj;
1289 
    const char *inbuf;
63219 ripley 1290 
    char *outbuf;
63218 ripley 1291 
    size_t inb, outb, res, top;
1292 
    char *tocode = NULL, *fromcode = NULL;
1293 
    char buf[20];
1294 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
1295 
 
63219 ripley 1296 
    strncpy(y, x, ny);
63218 ripley 1297 
 
63219 ripley 1298 
    if(ce_in == ce_out || ce_in == CE_ANY || ce_out == CE_ANY) return;
1299 
    if(utf8locale && ce_in == CE_NATIVE && ce_out == CE_UTF8) return;
1300 
    if(utf8locale && ce_out == CE_NATIVE && ce_in == CE_UTF8) return;
1301 
    if(latin1locale && ce_in == CE_NATIVE && ce_out == CE_LATIN1) return;
1302 
    if(latin1locale && ce_out == CE_NATIVE && ce_in == CE_LATIN1) return;
63218 ripley 1303 
 
63219 ripley 1304 
    if(strIsASCII(x)) return;
1305 
 
63218 ripley 1306 
    switch(ce_in) {
1307 
    case CE_NATIVE:
1308 
	{
1309 
	    /* Looks like CP1252 is treated as Latin-1 by iconv */
1310 
	    snprintf(buf, 20, "CP%d", localeCP);
1311 
	    fromcode = buf;
1312 
	    break;
1313 
	}
1314 
    case CE_LATIN1: fromcode = "CP1252"; break;
1315 
    case CE_UTF8:   fromcode = "UTF-8"; break;
63219 ripley 1316 
    default: return;
63218 ripley 1317 
    }
1318 
 
1319 
    switch(ce_out) {
1320 
    case CE_NATIVE:
1321 
	{
1322 
	    /* avoid possible misidentification of CP1250 as LATIN-2 */
1323 
	    snprintf(buf, 20, "CP%d", localeCP);
1324 
	    tocode = buf;
1325 
	    break;
1326 
	}
1327 
    case CE_LATIN1: tocode = "latin1"; break;
1328 
    case CE_UTF8:   tocode = "UTF-8"; break;
63219 ripley 1329 
    default: return;
63218 ripley 1330 
    }
1331 
 
1332 
    obj = Riconv_open(tocode, fromcode);
63219 ripley 1333 
    if(obj == (void *)(-1)) return;
63218 ripley 1334 
    R_AllocStringBuffer(0, &cbuff);
1335 
top_of_loop:
1336 
    inbuf = x; inb = strlen(inbuf);
1337 
    outbuf = cbuff.data; top = outb = cbuff.bufsize - 1;
1338 
    /* First initialize output */
1339 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
1340 
next_char:
1341 
    /* Then convert input  */
1342 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
1343 
    if(res == -1 && errno == E2BIG) {
1344 
	R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1345 
	goto top_of_loop;
1346 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
1347 
	switch(subst) {
1348 
	case 1: /* substitute hex */
1349 
	    if(outb < 5) {
1350 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1351 
		goto top_of_loop;
1352 
	    }
1353 
	    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
1354 
	    outbuf += 4; outb -= 4;
1355 
	    inbuf++; inb--;
1356 
	    goto next_char;
1357 
	    break;
1358 
	case 2: /* substitute . */
1359 
	    if(outb < 1) {
1360 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1361 
		goto top_of_loop;
1362 
	    }
1363 
	    *outbuf++ = '.'; inbuf++; outb--; inb--;
1364 
	    goto next_char;
1365 
	    break;
1366 
	case 3: /* substitute ? */
1367 
	    if(outb < 1) {
1368 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
1369 
		goto top_of_loop;
1370 
	    }
1371 
	    *outbuf++ = '?'; inbuf++; outb--; inb--;
1372 
	    goto next_char;
1373 
	    break;
1374 
	default: /* skip byte */
1375 
	    inbuf++; inb--;
1376 
	    goto next_char;
1377 
	}
1378 
    }
1379 
    Riconv_close(obj);
1380 
    *outbuf = '\0';
1381 
    res = (top-outb)+1; /* strlen(cbuff.data) + 1; */
1382 
    if (res > ny) error("converted string too long for buffer");
63219 ripley 1383 
    memcpy(y, cbuff.data, res);
63218 ripley 1384 
    R_FreeStringBuffer(&cbuff);
1385 
}
1386 
#endif
1387 
 
44161 ripley 1388 
void attribute_hidden
1389 
invalidate_cached_recodings(void)
1390 
{
1391 
    latin1_obj = NULL;
1392 
    utf8_obj = NULL;
1393 
    ucsmb_obj = NULL;
1394 
#ifdef Win32
45446 ripley 1395 
    latin1_wobj = NULL;
44161 ripley 1396 
    utf8_wobj=NULL;
45446 ripley 1397 
#endif
44161 ripley 1398 
}
1399 
 
1400 
 
43953 ripley 1401 
#ifdef WORDS_BIGENDIAN
1402 
static const char UNICODE[] = "UCS-4BE";
32492 ripley 1403 
#else
43953 ripley 1404 
static const char UNICODE[] = "UCS-4LE";
1405 
#endif
1406 
 
44034 ripley 1407 
/* used in gram.c and devX11.c */
44014 ripley 1408 
size_t ucstomb(char *s, const unsigned int wc)
43953 ripley 1409 
{
44178 ripley 1410 
    char     buf[MB_CUR_MAX+1];
43953 ripley 1411 
    void    *cd = NULL ;
1412 
    unsigned int  wcs[2];
1413 
    const char *inbuf = (const char *) wcs;
1414 
    size_t   inbytesleft = sizeof(unsigned int); /* better be 4 */
1415 
    char    *outbuf = buf;
1416 
    size_t   outbytesleft = sizeof(buf);
1417 
    size_t   status;
45446 ripley 1418 
 
43953 ripley 1419 
    if(wc == 0) {*s = '\0'; return 1;}
45446 ripley 1420 
 
43953 ripley 1421 
    memset(buf, 0, sizeof(buf));
1422 
    memset(wcs, 0, sizeof(wcs));
1423 
    wcs[0] = wc;
1424 
 
1425 
    if(ucsmb_obj == NULL) {
1426 
	if((void *)(-1) == (cd = Riconv_open("", UNICODE))) {
1427 
#ifndef  Win32
1428 
	    char tocode[128];
1429 
	    /* locale set fuzzy case */
1430 
	    strncpy(tocode, locale2charset(NULL), sizeof(tocode));
1431 
	    if((void *)(-1) == (cd = Riconv_open(tocode, UNICODE)))
45446 ripley 1432 
		return (size_t)(-1);
43953 ripley 1433 
#else
1434 
	    return (size_t)(-1);
1435 
#endif
1436 
	}
1437 
	ucsmb_obj = cd;
1438 
    }
45446 ripley 1439 
 
43953 ripley 1440 
    status = Riconv(ucsmb_obj, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1441 
 
1442 
    if (status == (size_t) -1) {
45446 ripley 1443 
	switch(errno){
1444 
	case EINVAL:
1445 
	    return (size_t) -2;
1446 
	case EILSEQ:
1447 
	    return (size_t) -1;
1448 
	case E2BIG:
1449 
	    break;
1450 
	default:
1451 
	    errno = EILSEQ;
1452 
	    return (size_t) -1;
1453 
	}
43953 ripley 1454 
    }
44178 ripley 1455 
    buf[MB_CUR_MAX] = '\0'; /* safety measure */
44170 ripley 1456 
    strcpy(s, buf);
43953 ripley 1457 
    return strlen(buf);
1458 
}
1459 
 
44034 ripley 1460 
/* used in plot.c for non-UTF-8 MBCS */
43953 ripley 1461 
size_t attribute_hidden
1462 
mbtoucs(unsigned int *wc, const char *s, size_t n)
1463 
{
1464 
    unsigned int  wcs[2];
1465 
    char     buf[16];
1466 
    void    *cd;
1467 
    const char *inbuf = s;
1468 
    size_t   inbytesleft = strlen(s);
1469 
    char    *outbuf = (char *) wcs;
1470 
    size_t   outbytesleft = sizeof(buf);
1471 
    size_t   status;
45446 ripley 1472 
 
43953 ripley 1473 
    if(s[0] == 0) {*wc = 0; return 1;}
45446 ripley 1474 
 
43978 ripley 1475 
    if((void *)(-1) == (cd = Riconv_open(UNICODE, ""))) return (size_t)(-1);
43953 ripley 1476 
    status = Riconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1477 
 
43980 ripley 1478 
    if (status == (size_t) -1) {
45446 ripley 1479 
	switch(errno){
1480 
	case EINVAL:
1481 
	    return (size_t) -2;
1482 
	case EILSEQ:
1483 
	    return (size_t) -1;
1484 
	case E2BIG:
1485 
	    break;
1486 
	default:
1487 
	    errno = EILSEQ;
1488 
	    return (size_t) -1;
1489 
	}
43980 ripley 1490 
    }
46133 ripley 1491 
    Riconv_close(cd);
43953 ripley 1492 
    *wc = wcs[0];
1493 
    return (size_t) 1;
1494 
}
1495 
 
44329 ripley 1496 
/* made available for use in graphics devices */
1497 
size_t ucstoutf8(char *s, const unsigned int wc)
43953 ripley 1498 
{
1499 
    char     buf[16];
1500 
    void    *cd = NULL ;
1501 
    unsigned int  wcs[2];
1502 
    const char *inbuf = (const char *) wcs;
1503 
    size_t   inbytesleft = sizeof(unsigned int); /* better be 4 */
1504 
    char    *outbuf = buf;
1505 
    size_t   outbytesleft = sizeof(buf);
1506 
    size_t   status;
45446 ripley 1507 
 
43953 ripley 1508 
    if(wc == 0) {*s = '\0'; return 1;}
45446 ripley 1509 
 
43953 ripley 1510 
    memset(buf, 0, sizeof(buf));
1511 
    wcs[0] = wc; wcs[1] = 0;
1512 
 
46133 ripley 1513 
    if(ucsutf8_obj == NULL) {
1514 
	if((void *)(-1) == (cd = Riconv_open("UTF-8", UNICODE))) {
1515 
	    error(_("unsupported conversion from '%s' to '%s'"),
1516 
		  UNICODE, "UTF-8");
1517 
	    return (size_t)(-1);
1518 
	}
1519 
	ucsutf8_obj = cd;
1520 
    }
1521 
 
1522 
    status = Riconv(ucsutf8_obj, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
43953 ripley 1523 
 
1524 
    if (status == (size_t) -1) {
45446 ripley 1525 
	switch(errno){
1526 
	case EINVAL:
1527 
	    return (size_t) -2;
1528 
	case EILSEQ:
1529 
	    return (size_t) -1;
1530 
	case E2BIG:
1531 
	    break;
1532 
	default:
1533 
	    errno = EILSEQ;
1534 
	    return (size_t) -1;
1535 
	}
43953 ripley 1536 
    }
44325 ripley 1537 
    *outbuf = '\0';
1538 
    strcpy(s, buf);
43953 ripley 1539 
    return strlen(buf);
1540 
}
1541 
 
36601 ripley 1542 
/* moved from src/unix/sys-unix.c and src/gnuwin32/extra.c */
1543 
 
1544 
#ifdef HAVE_STAT
1545 
# ifdef HAVE_ACCESS
1546 
#  ifdef HAVE_UNISTD_H
1547 
#   include <unistd.h>
1548 
#  endif
1549 
# endif
1550 
 
41344 ripley 1551 
#ifdef Win32
1552 
# define WIN32_LEAN_AND_MEAN 1
1553 
# include <windows.h> /* For GetShortPathName */
1554 
#endif
1555 
 
36622 ripley 1556 
#if !defined(S_IFDIR) && defined(__S_IFDIR)
1557 
# define S_IFDIR __S_IFDIR
1558 
#endif
1559 
 
36601 ripley 1560 
static int isDir(char *path)
1561 
{
54797 ripley 1562 
#ifdef Win32
1563 
    struct _stati64 sb;
1564 
#else
36601 ripley 1565 
    struct stat sb;
54797 ripley 1566 
#endif
36601 ripley 1567 
    int isdir = 0;
1568 
    if(!path) return 0;
54797 ripley 1569 
#ifdef Win32
1570 
    if(_stati64(path, &sb) == 0) {
1571 
#else
36601 ripley 1572 
    if(stat(path, &sb) == 0) {
54797 ripley 1573 
#endif
36601 ripley 1574 
	isdir = (sb.st_mode & S_IFDIR) > 0; /* is a directory */
1575 
#ifdef HAVE_ACCESS
1576 
	/* We want to know if the directory is writable by this user,
1577 
	   which mode does not tell us */
1578 
	isdir &= (access(path, W_OK) == 0);
1579 
#endif
1580 
    }
1581 
    return isdir;
1582 
}
1583 
#else
1584 
static int isDir(char *path)
1585 
{
1586 
    return 1;
1587 
}
1588 
#endif /* HAVE_STAT */
1589 
 
1590 
#if !HAVE_DECL_MKDTEMP
1591 
extern char * mkdtemp (char *template);
1592 
#endif
1593 
 
52128 ripley 1594 
#ifdef Win32
1595 
# include <ctype.h>
1596 
#endif
1597 
 
36990 ripley 1598 
void attribute_hidden InitTempDir()
36601 ripley 1599 
{
1600 
    char *tmp, *tm, tmp1[PATH_MAX+11], *p;
1601 
#ifdef Win32
44720 ripley 1602 
    char tmp2[PATH_MAX];
36601 ripley 1603 
    int hasspace = 0;
1604 
#endif
1605 
 
39181 ripley 1606 
    if(R_TempDir) return; /* someone else set it */
36616 ripley 1607 
    tmp = NULL; /* getenv("R_SESSION_TMPDIR");   no longer set in R.sh */
36601 ripley 1608 
    if (!tmp) {
1609 
	tm = getenv("TMPDIR");
1610 
	if (!isDir(tm)) {
1611 
	    tm = getenv("TMP");
40376 ripley 1612 
	    if (!isDir(tm)) {
36601 ripley 1613 
		tm = getenv("TEMP");
40376 ripley 1614 
		if (!isDir(tm))
36601 ripley 1615 
#ifdef Win32
1616 
		    tm = getenv("R_USER"); /* this one will succeed */
1617 
#else
1618 
		    tm = "/tmp";
1619 
#endif
1620 
	    }
1621 
	}
1622 
#ifdef Win32
1623 
	/* make sure no spaces in path */
1624 
	for (p = tm; *p; p++)
1625 
	    if (isspace(*p)) { hasspace = 1; break; }
1626 
	if (hasspace) {
1627 
	    GetShortPathName(tm, tmp2, MAX_PATH);
1628 
	    tm = tmp2;
1629 
	}
62580 ripley 1630 
	snprintf(tmp1, PATH_MAX+11, "%s\\RtmpXXXXXX", tm);
37091 ripley 1631 
#else
62580 ripley 1632 
	snprintf(tmp1, PATH_MAX+11, "%s/RtmpXXXXXX", tm);
36601 ripley 1633 
#endif
1634 
	tmp = mkdtemp(tmp1);
60844 ripley 1635 
	if(!tmp) R_Suicide(_("cannot create 'R_TempDir'"));
40392 ripley 1636 
#ifndef Win32
1637 
# ifdef HAVE_SETENV
1638 
	if(setenv("R_SESSION_TMPDIR", tmp, 1))
1639 
	    errorcall(R_NilValue, _("unable to set R_SESSION_TMPDIR"));
1640 
# elif defined(HAVE_PUTENV)
36601 ripley 1641 
	{
62580 ripley 1642 
	    size_t len = strlen(tmp) + 20;
1643 
	    char * buf = (char *) malloc((len) * sizeof(char));
36601 ripley 1644 
	    if(buf) {
62580 ripley 1645 
		snprintf(buf, len, "R_SESSION_TMPDIR=%s", tmp);
45446 ripley 1646 
		if(putenv(buf))
40392 ripley 1647 
		    errorcall(R_NilValue, _("unable to set R_SESSION_TMPDIR"));
36601 ripley 1648 
		/* no free here: storage remains in use */
45446 ripley 1649 
	    } else
40392 ripley 1650 
		errorcall(R_NilValue, _("unable to set R_SESSION_TMPDIR"));
36601 ripley 1651 
	}
40392 ripley 1652 
# endif
36601 ripley 1653 
#endif
1654 
    }
1655 
 
59096 ripley 1656 
    size_t len = strlen(tmp) + 1;
36601 ripley 1657 
    p = (char *) malloc(len);
40376 ripley 1658 
    if(!p)
60844 ripley 1659 
	R_Suicide(_("cannot allocate 'R_TempDir'"));
36601 ripley 1660 
    else {
1661 
	R_TempDir = p;
1662 
	strcpy(R_TempDir, tmp);
39181 ripley 1663 
	Sys_TempDir = R_TempDir;
36601 ripley 1664 
    }
1665 
}
1666 
 
1667 
char * R_tmpnam(const char * prefix, const char * tempdir)
1668 
{
54876 murdoch 1669 
    return R_tmpnam2(prefix, tempdir, "");
1670 
}
1671 
 
57745 ripley 1672 
/* NB for use with multicore: parent and all children share the same
1673 
   session directory and run in parallel.
1674 
   So as from 2.14.1, we make sure getpic() is part of the process.
1675 
*/
1676 
char * R_tmpnam2(const char *prefix, const char *tempdir, const char *fileext)
54876 murdoch 1677 
{
1678 
    char tm[PATH_MAX], *res;
57745 ripley 1679 
    unsigned int n, done = 0, pid = getpid();
37091 ripley 1680 
#ifdef Win32
1681 
    char filesep[] = "\\";
1682 
#else
1683 
    char filesep[] = "/";
1684 
#endif
36601 ripley 1685 
 
1686 
    if(!prefix) prefix = "";	/* NULL */
54876 murdoch 1687 
    if(!fileext) fileext = "";  /*  "   */
1688 
 
1689 
#if RAND_MAX > 16777215
1690 
#define RAND_WIDTH 8
1691 
#else
1692 
#define RAND_WIDTH 12
1693 
#endif
1694 
 
1695 
    if(strlen(tempdir) + 1 + strlen(prefix) + RAND_WIDTH + strlen(fileext) >= PATH_MAX)
1696 
    	error(_("temporary name too long"));
1697 
 
36601 ripley 1698 
    for (n = 0; n < 100; n++) {
1699 
	/* try a random number at the end.  Need at least 6 hex digits */
1700 
#if RAND_MAX > 16777215
57745 ripley 1701 
	snprintf(tm, PATH_MAX, "%s%s%s%x%x%s", tempdir, filesep, prefix, pid, rand(), fileext);
36601 ripley 1702 
#else
57745 ripley 1703 
	snprintf(tm, PATH_MAX, "%s%s%s%x%x%x%s", tempdir, filesep, prefix, pid, rand(), rand(), fileext);
36601 ripley 1704 
#endif
45446 ripley 1705 
	if(!R_FileExists(tm)) {
40376 ripley 1706 
	    done = 1;
1707 
	    break;
36601 ripley 1708 
	}
1709 
    }
1710 
    if(!done)
1711 
	error(_("cannot find unused tempfile name"));
1712 
    res = (char *) malloc((strlen(tm)+1) * sizeof(char));
50871 ripley 1713 
    if(!res)
54876 murdoch 1714 
	error(_("allocation failed in R_tmpnam2"));
36601 ripley 1715 
    strcpy(res, tm);
1716 
    return res;
1717 
}
39743 duncan 1718 
 
39948 ripley 1719 
SEXP attribute_hidden do_proctime(SEXP call, SEXP op, SEXP args, SEXP env)
1720 
{
44103 ripley 1721 
    SEXP ans, nm;
51258 ripley 1722 
 
1723 
    checkArity(op, args);
44103 ripley 1724 
    PROTECT(ans = allocVector(REALSXP, 5));
1725 
    PROTECT(nm = allocVector(STRSXP, 5));
39948 ripley 1726 
    R_getProcTime(REAL(ans));
40050 ripley 1727 
    SET_STRING_ELT(nm, 0, mkChar("user.self"));
1728 
    SET_STRING_ELT(nm, 1, mkChar("sys.self"));
40051 ripley 1729 
    SET_STRING_ELT(nm, 2, mkChar("elapsed"));
40050 ripley 1730 
    SET_STRING_ELT(nm, 3, mkChar("user.child"));
1731 
    SET_STRING_ELT(nm, 4, mkChar("sys.child"));
1732 
    setAttrib(ans, R_NamesSymbol, nm);
39948 ripley 1733 
    setAttrib(ans, R_ClassSymbol, mkString("proc_time"));
44103 ripley 1734 
    UNPROTECT(2);
39948 ripley 1735 
    return ans;
1736 
}
45074 ripley 1737 
 
1738 
void attribute_hidden resetTimeLimits()
1739 
{
1740 
    double data[5];
1741 
    R_getProcTime(data);
1742 
 
1743 
    elapsedLimit = (elapsedLimitValue > 0) ? data[2] + elapsedLimitValue : -1.0;
45446 ripley 1744 
    if (elapsedLimit2 > 0.0 &&
45074 ripley 1745 
	(elapsedLimit <= 0.0 || elapsedLimit2 < elapsedLimit))
1746 
	elapsedLimit = elapsedLimit2;
1747 
 
1748 
#ifdef Win32
1749 
    cpuLimit = (cpuLimitValue > 0) ? data[0] + data[1] + cpuLimitValue : -1.0;
1750 
#else
1751 
    cpuLimit = (cpuLimitValue > 0) ? data[0] + data[1] + data[3] + data[4] + cpuLimitValue : -1.0;
1752 
#endif
1753 
    if (cpuLimit2 > 0.0 && (cpuLimit <= 0.0 || cpuLimit2 < cpuLimit))
1754 
	cpuLimit = cpuLimit2;
1755 
}
1756 
 
1757 
SEXP attribute_hidden
1758 
do_setTimeLimit(SEXP call, SEXP op, SEXP args, SEXP rho)
1759 
{
1760 
    double cpu, elapsed, old_cpu = cpuLimitValue,
1761 
	old_elapsed = elapsedLimitValue;
1762 
    int transient;
1763 
 
1764 
    checkArity(op, args);
1765 
    cpu = asReal(CAR(args));
1766 
    elapsed = asReal(CADR(args));
1767 
    transient = asLogical(CADDR(args));
1768 
 
1769 
    if (R_FINITE(cpu) && cpu > 0) cpuLimitValue = cpu; else cpuLimitValue = -1;
1770 
 
1771 
    if (R_FINITE(elapsed) && elapsed > 0) elapsedLimitValue = elapsed;
1772 
    else elapsedLimitValue = -1;
1773 
 
1774 
    resetTimeLimits();
1775 
 
1776 
    if (transient == TRUE) {
1777 
	cpuLimitValue = old_cpu;
1778 
	elapsedLimitValue = old_elapsed;
1779 
    }
1780 
 
1781 
    return R_NilValue;
1782 
}
1783 
 
1784 
SEXP attribute_hidden
1785 
do_setSessionTimeLimit(SEXP call, SEXP op, SEXP args, SEXP rho)
1786 
{
1787 
    double cpu, elapsed, data[5];
1788 
 
1789 
    checkArity(op, args);
1790 
    cpu = asReal(CAR(args));
1791 
    elapsed = asReal(CADR(args));
1792 
    R_getProcTime(data);
1793 
 
45446 ripley 1794 
    if (R_FINITE(cpu) && cpu > 0)
45074 ripley 1795 
#ifdef Win32
1796 
	cpuLimit2 = cpu + data[0] + data[1];
1797 
#else
45446 ripley 1798 
	cpuLimit2 = cpu + data[0] + data[1] + data[3] + data[4];
45074 ripley 1799 
#endif
1800 
    else cpuLimit2 = -1;
1801 
 
1802 
    if (R_FINITE(elapsed) && elapsed > 0) elapsedLimit2 = elapsed + data[2];
1803 
    else elapsedLimit2 = -1;
1804 
 
1805 
    return R_NilValue;
1806 
}
49381 ripley 1807 
 
49383 ripley 1808 
/* moved from character.c in 2.10.0: configure requires this */
49381 ripley 1809 
 
1810 
#ifdef HAVE_GLOB_H
1811 
# include <glob.h>
1812 
#endif
1813 
#ifdef Win32
1814 
# include <dos_wglob.h>
1815 
# define globfree dos_wglobfree
1816 
# define glob_t wglob_t
1817 
#else
1818 
# ifndef GLOB_QUOTE
1819 
#  define GLOB_QUOTE 0
1820 
# endif
1821 
#endif
1822 
SEXP attribute_hidden do_glob(SEXP call, SEXP op, SEXP args, SEXP env)
1823 
{
1824 
    SEXP x, ans;
59052 ripley 1825 
    R_xlen_t i, n;
59832 pd 1826 
    int res, dirmark, initialized=FALSE;
49381 ripley 1827 
    glob_t globbuf;
49392 ripley 1828 
#ifdef Win32
49385 ripley 1829 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
49392 ripley 1830 
#endif
49381 ripley 1831 
 
1832 
    checkArity(op, args);
1833 
    if (!isString(x = CAR(args)))
1834 
	error(_("invalid '%s' argument"), "paths");
59052 ripley 1835 
    if (!XLENGTH(x)) return allocVector(STRSXP, 0);
49381 ripley 1836 
    dirmark = asLogical(CADR(args));
1837 
    if (dirmark == NA_LOGICAL)
1838 
	error(_("invalid '%s' argument"), "dirmark");
1839 
#ifndef GLOB_MARK
1840 
    if (dirmark)
1841 
	error(_("'dirmark = TRUE' is not supported on this platform"));
1842 
#endif
1843 
 
59052 ripley 1844 
    for (i = 0; i < XLENGTH(x); i++) {
49381 ripley 1845 
	SEXP el = STRING_ELT(x, i);
1846 
	if (el == NA_STRING) continue;
1847 
#ifdef Win32
1848 
	res = dos_wglob(filenameToWchar(el, FALSE),
1849 
			(dirmark ? GLOB_MARK : 0) |
59832 pd 1850 
			GLOB_QUOTE | (initialized ? GLOB_APPEND : 0),
49381 ripley 1851 
			NULL, &globbuf);
1852 
	if (res == GLOB_NOSPACE)
1853 
	    error(_("internal out-of-memory condition"));
1854 
#else
1855 
	res = glob(translateChar(el),
1856 
# ifdef GLOB_MARK
1857 
		   (dirmark ? GLOB_MARK : 0) |
1858 
# endif
59832 pd 1859 
		   GLOB_QUOTE | (initialized ? GLOB_APPEND : 0),
49381 ripley 1860 
		   NULL, &globbuf);
1861 
# ifdef GLOB_ABORTED
1862 
	if (res == GLOB_ABORTED)
1863 
	    warning(_("read error on '%s'"), translateChar(el));
1864 
# endif
1865 
# ifdef GLOB_NOSPACE
1866 
	if (res == GLOB_NOSPACE)
1867 
	    error(_("internal out-of-memory condition"));
1868 
# endif
1869 
#endif
59832 pd 1870 
	initialized = TRUE;
49381 ripley 1871 
    }
59832 pd 1872 
    n = initialized ? globbuf.gl_pathc : 0;
49381 ripley 1873 
    PROTECT(ans = allocVector(STRSXP, n));
1874 
    for (i = 0; i < n; i++)
1875 
#ifdef Win32
1876 
    {
1877 
	wchar_t *w = globbuf.gl_pathv[i];
1878 
	char *buf;
1879 
	int nb = wcstoutf8(NULL, w, 0);
1880 
	buf = R_AllocStringBuffer(nb+1, &cbuff);
1881 
	wcstoutf8(buf, w, nb+1); buf[nb] = '\0'; /* safety check */
1882 
	SET_STRING_ELT(ans, i, mkCharCE(buf, CE_UTF8));
1883 
    }
1884 
#else
1885 
	SET_STRING_ELT(ans, i, mkChar(globbuf.gl_pathv[i]));
1886 
#endif
1887 
    UNPROTECT(1);
1888 
#ifdef Win32
1889 
    R_FreeStringBufferL(&cbuff);
1890 
#endif
59832 pd 1891 
    if (initialized) globfree(&globbuf);
49381 ripley 1892 
    return ans;
1893 
}