The R Project SVN R

Rev

Rev 87938 | 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
87783 ripley 3 
 *  Copyright (C) 1997-2025   The R Core Team
42307 ripley 4 
 *  Copyright (C) 1995-1996   Robert Gentleman and Ross Ihaka
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
68947 ripley 18 
 *  https://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 */
83503 ripley 26 
#ifdef HAVE_SYS_TYPES_H
27 
# include <sys/types.h> // for size_t
28 
#endif
29 
 
57538 ripley 30 
#define R_USE_SIGNALS 1
29747 ripley 31 
#include <Defn.h>
60667 ripley 32 
#include <Internal.h>
32670 ripley 33 
#include <R_ext/Riconv.h>
39866 duncan 34 
#include <Rinterface.h>
42398 ripley 35 
#include <errno.h>
72707 murdoch 36 
#include <rlocale.h>
29747 ripley 37 
 
38 
/*
39 
  See ../unix/system.txt for a description of some of these functions.
40 
  Formally part of ../unix/sys-common.c.
41 
 */
42 
 
43 
/*
44 
 * FILESYSTEM INTERACTION
45 
 */
46 
 
47 
/*
48 
 * This call provides a simple interface to the "stat" system call.
49 
 */
50 
 
41349 ripley 51 
#ifdef HAVE_SYS_TYPES_H
52 
# include <sys/types.h>
53 
#endif
54 
#ifdef HAVE_SYS_STAT_H
55 
# include <sys/stat.h>
56 
#endif
29747 ripley 57 
 
87901 ripley 58 
attribute_hidden int R_isWriteableDir(char *path);
72621 maechler 59 
 
51388 ripley 60 
#ifdef HAVE_AQUA
89784 luke 61 
extern int (*ptr_CocoaSystem)(const char*);
31157 iacus 62 
#endif
63 
 
54797 ripley 64 
#ifdef Win32
87891 ripley 65 
bool R_FileExists(const char *path)
29747 ripley 66 
{
54797 ripley 67 
    struct _stati64 sb;
68 
    return _stati64(R_ExpandFileName(path), &sb) == 0;
69 
}
70 
 
87901 ripley 71 
attribute_hidden double R_FileMtime(const char *path)
54797 ripley 72 
{
73 
    struct _stati64 sb;
74 
    if (_stati64(R_ExpandFileName(path), &sb) != 0)
75 
	error(_("cannot determine file modification time of '%s'"), path);
76 
    return sb.st_mtime;
77 
}
78 
#else
87891 ripley 79 
// used in tools
80 
bool R_FileExists(const char *path)
54797 ripley 81 
{
29747 ripley 82 
    struct stat sb;
83 
    return stat(R_ExpandFileName(path), &sb) == 0;
84 
}
85 
 
87901 ripley 86 
attribute_hidden double R_FileMtime(const char *path)
29747 ripley 87 
{
88 
    struct stat sb;
89 
    if (stat(R_ExpandFileName(path), &sb) != 0)
33297 ripley 90 
	error(_("cannot determine file modification time of '%s'"), path);
59101 ripley 91 
    return (double) sb.st_mtime;
29747 ripley 92 
}
54797 ripley 93 
#endif
29747 ripley 94 
 
95 
    /*
96 
     *  Unix file names which begin with "." are invisible.
97 
     */
98 
 
87901 ripley 99 
attribute_hidden bool R_HiddenFile(const char *name)
29747 ripley 100 
{
101 
    if (name && name[0] != '.') return 0;
102 
    else return 1;
103 
}
104 
 
44165 ripley 105 
/* The MSVC runtime has a global to determine whether an unspecified
106 
   file open is in text or binary mode.  We force explicit text mode
107 
   here to avoid depending on that global, which may have been changed
108 
   by user code (most likely in embedded applications of R).
44052 murdoch 109 
*/
29747 ripley 110 
 
44052 murdoch 111 
#ifdef Win32
112 
 
113 
static char * fixmode(const char *mode)
114 
{
72650 murdoch 115 
    /* Rconnection can have a mode of 4 chars plus a ccs= setting plus a null; we might
116 
     * add one char if neither b nor t is specified. */
117 
    static char fixedmode[20];
118 
    fixedmode[19] = '\0';
119 
    strncpy(fixedmode, mode, 19);
44052 murdoch 120 
    if (!strpbrk(fixedmode, "bt")) {
45446 ripley 121 
	strcat(fixedmode, "t");
44052 murdoch 122 
    }
123 
    return fixedmode;
124 
}
125 
 
126 
static wchar_t * wcfixmode(const wchar_t *mode)
127 
{
72650 murdoch 128 
    static wchar_t wcfixedmode[20];
129 
    wcfixedmode[19] = L'\0';
130 
    wcsncpy(wcfixedmode, mode, 19);
44052 murdoch 131 
    if (!wcspbrk(wcfixedmode, L"bt")) {
45446 ripley 132 
	wcscat(wcfixedmode, L"t");
44052 murdoch 133 
    }
134 
    return wcfixedmode;
135 
}
136 
 
137 
#else
138 
#define fixmode(mode) (mode)
139 
#define wcfixmode(mode) (mode)
140 
#endif
141 
 
29747 ripley 142 
FILE *R_fopen(const char *filename, const char *mode)
143 
{
44052 murdoch 144 
    return(filename ? fopen(filename, fixmode(mode)) : NULL );
29747 ripley 145 
}
146 
 
40700 ripley 147 
/* The point of this function is to allow file names in foreign
148 
   character sets.  On Unix-alikes in a UTF-8 locale all that is
149 
   needed is to convert file names to UTF-8, since they will be stored
150 
   in UTF-8.  For other locales, it seems that there is no way to specify
151 
   a file name in UTF-8.
152 
 
153 
   On NT-based versions of Windows, file names are stored in 'Unicode'
154 
   (UCS-2), and _wfopen is provided to access them by UCS-2 names.
79699 ripley 155 
   <FIXME> since Windows 2000 they could be UTF-16LE
40700 ripley 156 
*/
157 
 
44008 ripley 158 
#if defined(Win32)
159 
 
70047 ripley 160 
#define BSIZE 100000
44008 ripley 161 
wchar_t *filenameToWchar(const SEXP fn, const Rboolean expand)
40700 ripley 162 
{
54524 ripley 163 
    static wchar_t filename[BSIZE+1];
40700 ripley 164 
    void *obj;
44008 ripley 165 
    const char *from = "", *inbuf;
166 
    char *outbuf;
40700 ripley 167 
    size_t inb, outb, res;
44008 ripley 168 
 
44761 ripley 169 
    if(!strlen(CHAR(fn))) {
170 
	wcscpy(filename, L"");
171 
	return filename;
172 
    }
73786 kalibera 173 
    if(IS_LATIN1(fn))
174 
#ifdef HAVE_ICONV_CP1252
175 
	from = "CP1252";
176 
#else
177 
	from = "latin1";
178 
#endif
44054 ripley 179 
    if(IS_UTF8(fn)) from = "UTF-8";
54753 ripley 180 
    if(IS_BYTES(fn)) error(_("encoding of a filename cannot be 'bytes'"));
82528 kalibera 181 
    obj = Riconv_open("UTF-16LE", from);
44008 ripley 182 
    if(obj == (void *)(-1))
70047 ripley 183 
	error(_("unsupported conversion from '%s' in codepage %d"),
45680 ripley 184 
	      from, localeCP);
40700 ripley 185 
 
186 
    if(expand) inbuf = R_ExpandFileName(CHAR(fn)); else inbuf = CHAR(fn);
187 
 
54524 ripley 188 
    inb = strlen(inbuf)+1; outb = 2*BSIZE;
40700 ripley 189 
    outbuf = (char *) filename;
190 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
191 
    Riconv_close(obj);
54524 ripley 192 
    if(inb > 0) error(_("file name conversion problem -- name too long?"));
44762 ripley 193 
    if(res == -1) error(_("file name conversion problem"));
40700 ripley 194 
 
44008 ripley 195 
    return filename;
196 
}
197 
 
44016 ripley 198 
FILE *R_wfopen(const wchar_t *filename, const wchar_t *mode)
199 
{
44695 ripley 200 
    return filename ? _wfopen(filename, wcfixmode(mode)) : NULL;
44016 ripley 201 
}
202 
 
203 
 
44008 ripley 204 
FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)
205 
{
206 
    wchar_t wmode[10];
207 
 
44695 ripley 208 
    if(fn == NA_STRING) return NULL;
44052 murdoch 209 
    mbstowcs(wmode, fixmode(mode), 10);
44008 ripley 210 
    return _wfopen(filenameToWchar(fn, expand), wmode);
40700 ripley 211 
}
212 
#else
213 
FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)
214 
{
63181 ripley 215 
    const void *vmax = vmaxget();
76974 ripley 216 
    const char *filename = translateCharFP(fn), *res;
44695 ripley 217 
    if(fn == NA_STRING || !filename) return NULL;
63181 ripley 218 
    if(expand) res = R_ExpandFileName(filename);
219 
    else res = filename;
220 
    vmaxset(vmax);
221 
    return fopen(res, mode);
40700 ripley 222 
}
223 
#endif
224 
 
29747 ripley 225 
/*
226 
 *  SYSTEM INFORMATION
227 
 */
228 
 
45446 ripley 229 
	  /* The location of the R system files */
29747 ripley 230 
 
44201 ripley 231 
char *R_HomeDir(void)
29747 ripley 232 
{
233 
    return getenv("R_HOME");
234 
}
235 
 
51245 ripley 236 
/* This is a primitive (with no arguments) */
83446 ripley 237 
attribute_hidden SEXP do_interactive(SEXP call, SEXP op, SEXP args, SEXP rho)
29747 ripley 238 
{
51245 ripley 239 
    checkArity(op, args);
41894 ripley 240 
    return ScalarLogical( (R_Interactive) ? 1 : 0 );
29747 ripley 241 
}
242 
 
83446 ripley 243 
attribute_hidden SEXP do_tempdir(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 244 
{
41894 ripley 245 
    checkArity(op, args);
87863 ripley 246 
    bool check = asBool2(CAR(args), call);
79342 kalibera 247 
    if(check && !R_isWriteableDir(R_TempDir)) {
72621 maechler 248 
	R_TempDir = NULL;
249 
	R_reInitTempDir(/* die_on_fail = */ FALSE);
250 
    }
41894 ripley 251 
    return mkString(R_TempDir);
29747 ripley 252 
}
253 
 
254 
 
83446 ripley 255 
attribute_hidden SEXP do_tempfile(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 256 
{
54876 murdoch 257 
    SEXP  ans, pattern, fileext, tempdir;
258 
    const char *tn, *td, *te;
41783 ripley 259 
    char *tm;
54876 murdoch 260 
    int i, n1, n2, n3, slen;
29747 ripley 261 
 
262 
    checkArity(op, args);
54876 murdoch 263 
    pattern = CAR(args); n1 = length(pattern); args = CDR(args);
264 
    tempdir = CAR(args); n2 = length(tempdir); args = CDR(args);
265 
    fileext = CAR(args); n3 = length(fileext);
29747 ripley 266 
    if (!isString(pattern))
45446 ripley 267 
	error(_("invalid filename pattern"));
29747 ripley 268 
    if (!isString(tempdir))
45446 ripley 269 
	error(_("invalid '%s' value"), "tempdir");
54876 murdoch 270 
    if (!isString(fileext))
271 
	error(_("invalid file extension"));
29747 ripley 272 
    if (n1 < 1)
41686 ripley 273 
	error(_("no 'pattern'"));
29747 ripley 274 
    if (n2 < 1)
41686 ripley 275 
	error(_("no 'tempdir'"));
54876 murdoch 276 
    if (n3 < 1)
70047 ripley 277 
	error(_("no 'fileext'"));
29747 ripley 278 
    slen = (n1 > n2) ? n1 : n2;
54876 murdoch 279 
    slen = (n3 > slen) ? n3 : slen;
29747 ripley 280 
    PROTECT(ans = allocVector(STRSXP, slen));
281 
    for(i = 0; i < slen; i++) {
76974 ripley 282 
	tn = translateCharFP( STRING_ELT( pattern , i%n1 ) );
283 
	td = translateCharFP( STRING_ELT( tempdir , i%n2 ) );
284 
	te = translateCharFP( STRING_ELT( fileext , i%n3 ) );
29747 ripley 285 
	/* try to get a new file name */
54876 murdoch 286 
	tm = R_tmpnam2(tn, td, te);
29747 ripley 287 
	SET_STRING_ELT(ans, i, mkChar(tm));
288 
	if(tm) free(tm);
289 
    }
290 
    UNPROTECT(1);
291 
    return (ans);
292 
}
293 
 
41781 ripley 294 
FILE *R_popen(const char *command, const char *type)
29747 ripley 295 
{
296 
    FILE *fp;
69881 luke 297 
#ifdef OLD__APPLE__
29747 ripley 298 
    /* Luke recommends this to fix PR#1140 */
69881 luke 299 
    /* As of 2016-01-06 on El Capitan this may no longer be needed -- LT */
29747 ripley 300 
    sigset_t ss;
39757 urbaneks 301 
    sigemptyset(&ss);
29747 ripley 302 
    sigaddset(&ss, SIGPROF);
303 
    sigprocmask(SIG_BLOCK, &ss,  NULL);
304 
    fp = popen(command, type);
305 
    sigprocmask(SIG_UNBLOCK, &ss, NULL);
306 
#else
307 
    fp = popen(command, type);
308 
#endif
309 
    return fp;
310 
}
311 
 
53147 ripley 312 
#ifdef HAVE_SYS_WAIT_H
313 
# include <sys/wait.h>
314 
#endif
315 
 
41781 ripley 316 
int R_system(const char *command)
29747 ripley 317 
{
52799 ripley 318 
    int res;
61027 ripley 319 
#ifdef __APPLE__
69881 luke 320 
# ifdef OLD__APPLE__
29747 ripley 321 
    /* Luke recommends this to fix PR#1140 */
69881 luke 322 
    /* As of 2016-01-06 on El Capitan this may no longer be needed -- LT */
29747 ripley 323 
    sigset_t ss;
39754 urbaneks 324 
    sigemptyset(&ss);
29747 ripley 325 
    sigaddset(&ss, SIGPROF);
326 
    sigprocmask(SIG_BLOCK, &ss,  NULL);
70047 ripley 327 
# endif
31157 iacus 328 
#ifdef HAVE_AQUA
61483 ripley 329 
    if(ptr_CocoaSystem) res = ptr_CocoaSystem(command); else
40376 ripley 330 
#endif
52799 ripley 331 
    res = system(command);
69881 luke 332 
# ifdef OLD__APPLE__
29747 ripley 333 
    sigprocmask(SIG_UNBLOCK, &ss, NULL);
69881 luke 334 
# endif
61472 ripley 335 
#else // not APPLE
52799 ripley 336 
    res = system(command);
29747 ripley 337 
#endif
53147 ripley 338 
#ifdef HAVE_SYS_WAIT_H
339 
    if (WIFEXITED(res)) res = WEXITSTATUS(res);
52799 ripley 340 
#else
53147 ripley 341 
    /* assume that this is shifted if a multiple of 256 */
342 
    if ((res % 256) == 0) res = res/256;
52799 ripley 343 
#endif
65710 urbaneks 344 
    if (res == -1) {
345 
	/* this means that system() failed badly - it didn't
346 
	   even get to try to run the shell */
347 
	warning(_("system call failed: %s"), strerror(errno));
348 
	/* R system() is documented to return 127 on failure, and a lot of
349 
	   code relies on that - it will misinterpret -1 as success */
350 
	res = 127;
351 
    }
52799 ripley 352 
    return res;
29747 ripley 353 
}
354 
 
41344 ripley 355 
#if defined(__APPLE__)
29747 ripley 356 
# include <crt_externs.h>
357 
# define environ (*_NSGetEnviron())
81360 kalibera 358 
#elif defined(Win32)
43997 ripley 359 
/* _wenviron is declared in stdlib.h */
360 
# define WIN32_LEAN_AND_MEAN 1
47999 ripley 361 
# include <windows.h> /* _wgetenv etc */
81360 kalibera 362 
#else
363 
extern char ** environ;
43997 ripley 364 
#endif
365 
 
84763 maechler 366 
// .Internal(Sys.getenv(x, unset))
83446 ripley 367 
attribute_hidden SEXP do_getenv(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 368 
{
369 
    int i, j;
370 
    SEXP ans;
371 
 
372 
    checkArity(op, args);
373 
 
374 
    if (!isString(CAR(args)))
41686 ripley 375 
	error(_("wrong type for argument"));
29747 ripley 376 
 
40376 ripley 377 
    if (!isString(CADR(args)) || LENGTH(CADR(args)) != 1)
41686 ripley 378 
	error(_("wrong type for argument"));
40376 ripley 379 
 
29747 ripley 380 
    i = LENGTH(CAR(args));
84763 maechler 381 
    if (i == 0) { // full list of environment variables
47460 ripley 382 
#ifdef Win32
43997 ripley 383 
	int n = 0, N;
47999 ripley 384 
	wchar_t **w;
385 
	for (i = 0, w = _wenviron; *w != NULL; i++, w++)
386 
	    n = max(n, wcslen(*w));
72714 murdoch 387 
	N = 4*n+1;
51444 ripley 388 
	char buf[N];
43997 ripley 389 
	PROTECT(ans = allocVector(STRSXP, i));
47999 ripley 390 
	for (i = 0, w = _wenviron; *w != NULL; i++, w++) {
72714 murdoch 391 
	    wcstoutf8(buf, *w, sizeof(buf));
44986 ripley 392 
	    SET_STRING_ELT(ans, i, mkCharCE(buf, CE_UTF8));
43997 ripley 393 
	}
394 
#else
40392 ripley 395 
	char **e;
29747 ripley 396 
	for (i = 0, e = environ; *e != NULL; i++, e++);
397 
	PROTECT(ans = allocVector(STRSXP, i));
398 
	for (i = 0, e = environ; *e != NULL; i++, e++)
399 
	    SET_STRING_ELT(ans, i, mkChar(*e));
43997 ripley 400 
#endif
29747 ripley 401 
    } else {
402 
	PROTECT(ans = allocVector(STRSXP, i));
403 
	for (j = 0; j < i; j++) {
47460 ripley 404 
#ifdef Win32
43997 ripley 405 
	    const wchar_t *wnm = wtransChar(STRING_ELT(CAR(args), j));
47999 ripley 406 
	    wchar_t *w = _wgetenv(wnm);
407 
	    if (w == NULL)
43997 ripley 408 
		SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
409 
	    else {
72714 murdoch 410 
		int n = wcslen(w), N = 4*n+1; /* UTF-16 maps to <= 4 UTF-8 */
59752 ripley 411 
		R_CheckStack2(N);
51398 ripley 412 
		char buf[N];
72714 murdoch 413 
		wcstoutf8(buf, w, sizeof(buf));
47999 ripley 414 
		SET_STRING_ELT(ans, j, mkCharCE(buf, CE_UTF8));
43997 ripley 415 
	    }
416 
#else
417 
	    char *s = getenv(translateChar(STRING_ELT(CAR(args), j)));
29747 ripley 418 
	    if (s == NULL)
40376 ripley 419 
		SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
40692 ripley 420 
	    else {
43039 luke 421 
		SEXP tmp;
44986 ripley 422 
		if(known_to_be_latin1) tmp = mkCharCE(s, CE_LATIN1);
423 
		else if(known_to_be_utf8) tmp = mkCharCE(s, CE_UTF8);
43039 luke 424 
		else tmp = mkChar(s);
40692 ripley 425 
		SET_STRING_ELT(ans, j, tmp);
426 
	    }
43997 ripley 427 
#endif
29747 ripley 428 
	}
429 
    }
430 
    UNPROTECT(1);
431 
    return (ans);
432 
}
433 
 
47460 ripley 434 
#ifdef Win32
43997 ripley 435 
static int Rwputenv(const wchar_t *nm, const wchar_t *val)
436 
{
47999 ripley 437 
    wchar_t *buf;
438 
    buf = (wchar_t *) malloc((wcslen(nm) + wcslen(val) + 2) * sizeof(wchar_t));
439 
    if(!buf) return 1;
48007 ripley 440 
    /* previously wsprintfW, which had a limit of 1024 chars */
441 
    wcscpy(buf, nm); wcscat(buf, L"="); wcscat(buf, val);
47999 ripley 442 
    if(_wputenv(buf)) return 1;
443 
    /* no free here: storage remains in use */
444 
    return 0;
43997 ripley 445 
}
446 
#elif !defined(HAVE_SETENV) && defined(HAVE_PUTENV)
41783 ripley 447 
static int Rputenv(const char *nm, const char *val)
29747 ripley 448 
{
449 
    char *buf;
83456 ripley 450 
    size_t sz = (strlen(nm) + strlen(val) + 2) * sizeof(char);
451 
    buf = (char *) malloc(sz);
29747 ripley 452 
    if(!buf) return 1;
83456 ripley 453 
    snprintf(buf, sz, "%s=%s", nm, val);
40392 ripley 454 
    if(putenv(buf)) return 1;
29747 ripley 455 
    /* no free here: storage remains in use */
456 
    return 0;
457 
}
458 
#endif
459 
 
460 
 
84763 maechler 461 
// .Internal(Sys.setenv(nm, val)) : (nm_1=val_1, nm_2=val_2, ..., nm_<n>=val_<n>)
83446 ripley 462 
attribute_hidden SEXP do_setenv(SEXP call, SEXP op, SEXP args, SEXP env)
29747 ripley 463 
{
40376 ripley 464 
#if defined(HAVE_PUTENV) || defined(HAVE_SETENV)
465 
 
466 
    checkArity(op, args);
467 
 
84763 maechler 468 
    SEXP nm = CAR(args);
469 
    if (!isString(nm))
41686 ripley 470 
	error(_("wrong type for argument"));
84763 maechler 471 
    SEXP val = CADR(args);
472 
    if (!isString(val))
41686 ripley 473 
	error(_("wrong type for argument"));
84763 maechler 474 
    if(LENGTH(nm) != LENGTH(val))
475 
	error(_("'%s' and '%s' are of different lengths"), "names", "val");
40376 ripley 476 
 
84763 maechler 477 
    int i, n = LENGTH(val);
478 
    SEXP ans = PROTECT(allocVector(LGLSXP, n));
40376 ripley 479 
#ifdef HAVE_SETENV
480 
    for (i = 0; i < n; i++)
40692 ripley 481 
	LOGICAL(ans)[i] = setenv(translateChar(STRING_ELT(nm, i)),
84763 maechler 482 
				 translateChar(STRING_ELT(val, i)),
40376 ripley 483 
				 1) == 0;
47460 ripley 484 
#elif defined(Win32)
43997 ripley 485 
    for (i = 0; i < n; i++)
486 
	LOGICAL(ans)[i] = Rwputenv(wtransChar(STRING_ELT(nm, i)),
84763 maechler 487 
				   wtransChar(STRING_ELT(val, i))) == 0;
40376 ripley 488 
#else
489 
    for (i = 0; i < n; i++)
40692 ripley 490 
	LOGICAL(ans)[i] = Rputenv(translateChar(STRING_ELT(nm, i)),
84763 maechler 491 
				  translateChar(STRING_ELT(val, i))) == 0;
40376 ripley 492 
#endif
493 
    UNPROTECT(1);
494 
    return ans;
495 
#else
41571 ripley 496 
    error(_("'Sys.setenv' is not available on this system"));
40376 ripley 497 
    return R_NilValue; /* -Wall */
498 
#endif
499 
}
500 
 
84763 maechler 501 
// .Internal(Sys.unsetenv(nm))
83446 ripley 502 
attribute_hidden SEXP do_unsetenv(SEXP call, SEXP op, SEXP args, SEXP env)
40376 ripley 503 
{
29747 ripley 504 
    checkArity(op, args);
505 
 
84763 maechler 506 
    SEXP nm = CAR(args);
507 
    if (!isString(nm))
45446 ripley 508 
	error(_("wrong type for argument"));
84763 maechler 509 
    int i, n = LENGTH(nm);
41571 ripley 510 
 
511 
#if defined(HAVE_UNSETENV) || defined(HAVE_PUTENV_UNSET) || defined(HAVE_PUTENV_UNSET2)
40391 ripley 512 
#ifdef HAVE_UNSETENV
84763 maechler 513 
    for (i = 0; i < n; i++) unsetenv(translateChar(STRING_ELT(nm, i)));
40391 ripley 514 
#elif defined(HAVE_PUTENV_UNSET)
42427 ripley 515 
    for (i = 0; i < n; i++) {
516 
	char buf[1000];
84763 maechler 517 
	snprintf(buf, 1000, "%s",  translateChar(STRING_ELT(nm, i)));
42427 ripley 518 
	putenv(buf);
519 
    }
40391 ripley 520 
#elif defined(HAVE_PUTENV_UNSET2)
47460 ripley 521 
# ifdef Win32
41571 ripley 522 
    for (i = 0; i < n; i++) {
84763 maechler 523 
	const wchar_t *w = wtransChar(STRING_ELT(nm, i));
51398 ripley 524 
	wchar_t buf[2*wcslen(w)];
47999 ripley 525 
	wcscpy(buf, w);
526 
	wcscat(buf, L"=");
527 
	_wputenv(buf);
43997 ripley 528 
    }
529 
# else
530 
    for (i = 0; i < n; i++) {
40376 ripley 531 
	char buf[1000];
84763 maechler 532 
	snprintf(buf, 1000, "%s=", translateChar(STRING_ELT(nm, i)));
41571 ripley 533 
	putenv(buf);
29747 ripley 534 
    }
43997 ripley 535 
# endif
40376 ripley 536 
#endif
41571 ripley 537 
 
538 
#elif defined(HAVE_PUTENV) || defined(HAVE_SETENV)
539 
    warning(_("this system cannot unset environment variables: setting to \"\""));
84763 maechler 540 
    n = LENGTH(nm);
41571 ripley 541 
    for (i = 0; i < n; i++) {
542 
#ifdef HAVE_SETENV
84763 maechler 543 
	setenv(translateChar(STRING_ELT(nm, i)), "", 1);
41571 ripley 544 
#else
84763 maechler 545 
	Rputenv(translateChar(STRING_ELT(nm, i)), "");
41571 ripley 546 
#endif
547 
    }
548 
 
549 
#else
550 
    warning(_("'Sys.unsetenv' is not available on this system"));
551 
#endif
552 
 
84763 maechler 553 
    SEXP ans = PROTECT(allocVector(LGLSXP, n));
40403 ripley 554 
    for (i = 0; i < n; i++)
84763 maechler 555 
	LOGICAL(ans)[i] = !getenv(translateChar(STRING_ELT(nm, i)));
41571 ripley 556 
    UNPROTECT(1);
29747 ripley 557 
    return ans;
558 
}
32415 ripley 559 
 
48904 ripley 560 
#include <iconv.h>
32415 ripley 561 
 
32642 ripley 562 
#ifdef HAVE_ICONVLIST
32482 ripley 563 
static unsigned int cnt;
564 
 
40376 ripley 565 
static int
42623 ripley 566 
count_one (unsigned int namescount, const char * const *names, void *data)
32482 ripley 567 
{
568 
    cnt += namescount;
569 
    return 0;
570 
}
571 
 
40376 ripley 572 
static int
42623 ripley 573 
write_one (unsigned int namescount, const char * const *names, void *data)
32482 ripley 574 
{
575 
  unsigned int i;
576 
  SEXP ans = (SEXP) data;
40376 ripley 577 
 
32482 ripley 578 
  for (i = 0; i < namescount; i++)
579 
      SET_STRING_ELT(ans, cnt++, mkChar(names[i]));
580 
  return 0;
581 
}
32486 ripley 582 
#endif
32482 ripley 583 
 
85570 ripley 584 
// Copied from platform.c (only used condiitonally there)
585 
// case-insensitive string comparison
586 
int static R_strieql(const char *a, const char *b)
587 
{
588 
    while (*a && *b && toupper(*a) == toupper(*b)) { a++; b++; }
589 
    return (*a == 0 && *b == 0);
590 
}
591 
 
592 
 
32551 ripley 593 
#include "RBufferUtils.h"
594 
 
49095 ripley 595 
/* iconv(x, from, to, sub, mark) */
83446 ripley 596 
attribute_hidden SEXP do_iconv(SEXP call, SEXP op, SEXP args, SEXP env)
32415 ripley 597 
{
43034 ripley 598 
    SEXP ans, x = CAR(args), si;
82791 kalibera 599 
    void * arg_obj = (iconv_t)-1;
600 
    void * latin1_obj = (iconv_t)-1;
601 
    void * utf8_obj = (iconv_t)-1;
42623 ripley 602 
    const char *inbuf;
32551 ripley 603 
    char *outbuf;
84660 ripley 604 
    const char *sub; // null for no substitution.
32415 ripley 605 
    size_t inb, outb, res;
87228 kalibera 606 
    size_t inp_unit_size = 0; /* uninitialized */
32551 ripley 607 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
87891 ripley 608 
    bool isRawlist = false;
40376 ripley 609 
 
32415 ripley 610 
    checkArity(op, args);
32482 ripley 611 
    if(isNull(x)) {  /* list locales */
32642 ripley 612 
#ifdef HAVE_ICONVLIST
32482 ripley 613 
	cnt = 0;
614 
	iconvlist(count_one, NULL);
615 
	PROTECT(ans = allocVector(STRSXP, cnt));
616 
	cnt = 0;
617 
	iconvlist(write_one, (void *)ans);
618 
#else
42623 ripley 619 
	PROTECT(ans = R_NilValue);
32482 ripley 620 
#endif
621 
    } else {
55260 ripley 622 
	int mark, toRaw;
41783 ripley 623 
	const char *from, *to;
87891 ripley 624 
	bool isLatin1 = false, isUTF8 = false;
40672 ripley 625 
 
55260 ripley 626 
	args = CDR(args);
627 
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
41686 ripley 628 
	    error(_("invalid '%s' argument"), "from");
55260 ripley 629 
	from = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
630 
	args = CDR(args);
631 
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
41686 ripley 632 
	    error(_("invalid '%s' argument"), "to");
55260 ripley 633 
	to = CHAR(STRING_ELT(CAR(args), 0));
634 
	args = CDR(args);
635 
	if(!isString(CAR(args)) || length(CAR(args)) != 1)
41686 ripley 636 
	    error(_("invalid '%s' argument"), "sub");
55260 ripley 637 
	if(STRING_ELT(CAR(args), 0) == NA_STRING) sub = NULL;
638 
	else sub = translateChar(STRING_ELT(CAR(args), 0));
639 
	args = CDR(args);
640 
	mark = asLogical(CAR(args));
49095 ripley 641 
	if(mark == NA_LOGICAL)
70047 ripley 642 
	    error(_("invalid '%s' argument"), "mark");
55260 ripley 643 
	args = CDR(args);
644 
	toRaw = asLogical(CAR(args));
645 
	if(toRaw == NA_LOGICAL)
70047 ripley 646 
	    error(_("invalid '%s' argument"), "toRaw");
85570 ripley 647 
	/* some iconv's allow "UTF8", but GNU libiconv does not */
648 
	if(R_strieql(from, "UTF8")) from = "UTF-8";
649 
	if(R_strieql(to, "UTF8")) to = "UTF-8";
40672 ripley 650 
	if(streql(to, "UTF-8")) isUTF8 = TRUE;
85570 ripley 651 
	if(R_strieql(to, "latin1") || R_strieql(to, "ISO_8859-1")
652 
	    || R_strieql(to, "CP1252")) isLatin1 = TRUE;
40672 ripley 653 
	if(streql(to, "") && known_to_be_latin1) isLatin1 = TRUE;
654 
	if(streql(to, "") && known_to_be_utf8) isUTF8 = TRUE;
85570 ripley 655 
#ifdef OS_MUSL
656 
	if(R_strieql(from, "latin-2") || R_strieql(from, "latin2") )
657 
	    from = "iso88592";
658 
	if(R_strieql(to, "latin-2") || R_strieql(to, "latin2") )
659 
	    to = "iso88592";
87713 smeyer 660 
	/* the following is redundant (musl does know about the latin9 alias) */
85570 ripley 661 
	if(R_strieql(from, "latin-9") || R_strieql(from, "latin9") )
662 
	    from = "iso885915";
663 
	if(R_strieql(to, "latin-9") || R_strieql(to, "latin9") )
664 
	    to = "iso885915";
665 
#endif
55264 ripley 666 
	isRawlist = (TYPEOF(x) == VECSXP);
667 
	if(isRawlist) {
668 
	    if(toRaw)
669 
		PROTECT(ans = duplicate(x));
670 
	    else {
671 
		PROTECT(ans = allocVector(STRSXP, LENGTH(x)));
69108 luke 672 
		SHALLOW_DUPLICATE_ATTRIB(ans, x);
55264 ripley 673 
	    }
70047 ripley 674 
	} else {
82791 kalibera 675 
	    if(TYPEOF(x) != STRSXP)
55264 ripley 676 
		error(_("'x' must be a character vector"));
677 
	    if(toRaw) {
678 
		PROTECT(ans = allocVector(VECSXP, LENGTH(x)));
69108 luke 679 
		SHALLOW_DUPLICATE_ATTRIB(ans, x);
70047 ripley 680 
	    } else
55264 ripley 681 
		PROTECT(ans = duplicate(x));
682 
	}
41899 ripley 683 
	R_AllocStringBuffer(0, &cbuff);  /* 0 -> default */
59052 ripley 684 
	for(R_xlen_t i = 0; i < XLENGTH(x); i++) {
55264 ripley 685 
	    if (isRawlist) {
686 
		si = VECTOR_ELT(x, i);
687 
		if (TYPEOF(si) == NILSXP) {
688 
		    if (!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
689 
		    continue;
82791 kalibera 690 
		} else if (TYPEOF(si) != RAWSXP)
69444 ripley 691 
		    error(_("'x' must be a character vector or a list of NULL or raw vectors"));
55264 ripley 692 
	    } else {
693 
		si = STRING_ELT(x, i);
694 
		if (si == NA_STRING) {
695 
		    if(!toRaw) SET_STRING_ELT(ans, i, NA_STRING);
696 
		    continue;
697 
		}
55260 ripley 698 
	    }
82791 kalibera 699 
	    void * obj = (iconv_t)-1;
87891 ripley 700 
	    bool fromUTF8 = false;
82791 kalibera 701 
 
702 
	    /* With 'from = ""', encoding flags are used in preference
703 
	       of native encoding.
704 
 
705 
	       FIXME: Should we go further and ignore "from" with any non-bytes,
706 
	              non-raw input? */
707 
	    if (!isRawlist && IS_UTF8(si) && streql(from, "")) {
708 
		if (utf8_obj == (iconv_t)-1) {
709 
		    utf8_obj = Riconv_open(to, "UTF-8");
710 
		    if(utf8_obj == (iconv_t)(-1))
711 
		#ifdef Win32
712 
			error(_("unsupported conversion from '%s' to '%s' in codepage %d"),
713 
			      "UTF-8", to, localeCP);
714 
		#else
84660 ripley 715 
		    {
716 
			// musl does not support ASCII//TRANSLIT but has
717 
			// similar ASCII subsituting with *
718 
			// In case there are others, we set sub here.
719 
			if(streql(to, "ASCII//TRANSLIT")) {
720 
			    to = "ASCII";
721 
			    utf8_obj = Riconv_open(to, "UTF-8");
722 
			    if(!sub) sub = "c99";
723 
			}
724 
			if(utf8_obj == (iconv_t)(-1))
725 
			    error(_("unsupported conversion from '%s' to '%s'"),
726 
				  "UTF-8", to);
727 
		    }
82791 kalibera 728 
		#endif
729 
		}
730 
		obj = utf8_obj;
731 
		fromUTF8 = TRUE;
732 
	    } else if (!isRawlist && IS_LATIN1(si) && streql(from, "")) {
733 
		if (latin1_obj == (iconv_t)-1) {
734 
		    latin1_obj = Riconv_open(to, "latin1");
735 
		    if(latin1_obj == (iconv_t)(-1))
736 
		#ifdef Win32
737 
			error(_("unsupported conversion from '%s' to '%s' in codepage %d"),
738 
			      "latin1", to, localeCP);
739 
		#else
84660 ripley 740 
		    {
741 
			if(streql(to, "ASCII//TRANSLIT")) {
742 
			    to = "ASCII";
743 
			    latin1_obj = Riconv_open(to, "latin1");
744 
			    if(!sub) sub = "?";
745 
			}
746 
			if(latin1_obj == (iconv_t)(-1))
747 
			    error(_("unsupported conversion from '%s' to '%s'"),
748 
				  "latin1", to);
749 
		    }
82791 kalibera 750 
		#endif
751 
		}
752 
		obj = latin1_obj;
753 
	    } else {
754 
		if (arg_obj == (iconv_t)-1) {
755 
		    arg_obj = Riconv_open(to, from);
756 
		    if(arg_obj == (iconv_t)(-1))
757 
		#ifdef Win32
758 
			error(_("unsupported conversion from '%s' to '%s' in codepage %d"),
759 
			      from, to, localeCP);
760 
		#else
84660 ripley 761 
		    {
762 
			if(streql(to, "ASCII//TRANSLIT")) {
763 
			    to = "ASCII";
764 
			    arg_obj = Riconv_open(to, from);
765 
			    if(!sub) sub = "?";
766 
			}
767 
			if(arg_obj == (iconv_t)(-1))
768 
			    error(_("unsupported conversion from '%s' to '%s'"),
769 
				  from, to);
770 
		    }
82791 kalibera 771 
		#endif
772 
		}
773 
		obj = arg_obj;
774 
		fromUTF8 = streql(from, "UTF-8")
775 
		           || (streql(from, "") && known_to_be_utf8);
776 
		           /* FIXME: utf8locale? as Riconv doesn't handle
777 
		                     known_to_be_utf8 */
778 
	    }
32551 ripley 779 
	top_of_loop:
70047 ripley 780 
	    inbuf = isRawlist ? (const char *) RAW(si) : CHAR(si);
55260 ripley 781 
	    inb = LENGTH(si);
32551 ripley 782 
	    outbuf = cbuff.data; outb = cbuff.bufsize - 1;
32482 ripley 783 
	    /* First initialize output */
36081 ripley 784 
	    Riconv (obj, NULL, NULL, &outbuf, &outb);
45446 ripley 785 
	next_char:
32551 ripley 786 
	    /* Then convert input  */
42623 ripley 787 
	    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
32482 ripley 788 
	    *outbuf = '\0';
77045 ripley 789 
	    /* other possible error conditions are
790 
	       incomplete and invalid multibyte chars */
32551 ripley 791 
	    if(res == -1 && errno == E2BIG) {
792 
		R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
793 
		goto top_of_loop;
70047 ripley 794 
	    } else if(res == -1 && sub &&
51812 ripley 795 
		      (errno == EILSEQ || errno == EINVAL)) {
32601 ripley 796 
		/* it seems this gets thrown for non-convertible input too */
87219 kalibera 797 
		/* EINVAL returned for invalid input on macOS with system
798 
		   libiconv */
87222 kalibera 799 
		/*
800 
		  Should re-set with a stateful encoding, but some iconv
801 
		  implementations forget byte-order learned from BOM.
802 
 
85476 kalibera 803 
		res = Riconv(obj, NULL, NULL, &outbuf, &outb);
804 
		if (res == -1 && errno == E2BIG) {
805 
		    R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
806 
		    goto top_of_loop;
87222 kalibera 807 
		}
808 
		*/
77045 ripley 809 
		if(fromUTF8 && streql(sub, "Unicode")) {
810 
		    if(outb < 13) {
811 
			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
812 
			goto top_of_loop;
813 
		    }
814 
		    wchar_t wc;
78021 ripley 815 
		    ssize_t clen = utf8toucs(&wc, inbuf);
77045 ripley 816 
		    if(clen > 0 && inb >= clen) {
77916 ripley 817 
			R_wchar_t ucs;
77045 ripley 818 
			if (IS_HIGH_SURROGATE(wc))
819 
			    ucs = utf8toucs32(wc, inbuf);
820 
			else
77916 ripley 821 
			    ucs = (R_wchar_t) wc;
77045 ripley 822 
			inbuf += clen; inb -= clen;
823 
			if(ucs < 65536) {
85567 ripley 824 
			    // gcc 7 objected to this with unsigned int
77045 ripley 825 
			    snprintf(outbuf, 9, "<U+%04X>", (unsigned short) ucs);
826 
			    outbuf += 8; outb -= 8;
827 
			} else {
77916 ripley 828 
			    /* R_wchar_t is unsigned int on Windows,
77045 ripley 829 
			       otherwise wchar_t (usually int).
830 
			       In any case Unicode points <= 0x10FFFF
85567 ripley 831 
			       so one could argue against zero-padding here.
77045 ripley 832 
			    */
85609 ripley 833 
			    snprintf(outbuf, 13, "<U+%04X>", (unsigned int) ucs);
834 
			    size_t l = strlen(outbuf);
835 
			    outbuf += l; outb -= l;
77045 ripley 836 
			}
837 
		    }
838 
		    goto next_char;
81786 ripley 839 
		} else if(fromUTF8 && streql(sub, "c99")) {
840 
		    if(outb < 11) {
841 
			R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
842 
			goto top_of_loop;
843 
		    }
844 
		    wchar_t wc;
845 
		    ssize_t clen = utf8toucs(&wc, inbuf);
846 
		    if(clen > 0 && inb >= clen) {
847 
			R_wchar_t ucs;
848 
			if (IS_HIGH_SURROGATE(wc))
849 
			    ucs = utf8toucs32(wc, inbuf);
850 
			else
851 
			    ucs = (R_wchar_t) wc;
852 
			inbuf += clen; inb -= clen;
853 
			if(ucs < 65536) {
84668 ripley 854 
			    // gcc 7 objected to this with unsigned int
81786 ripley 855 
			    snprintf(outbuf, 7, "\\u%04x", (unsigned short) ucs);
856 
			    outbuf += 6; outb -= 6;
857 
			} else {
858 
			    /* R_wchar_t is unsigned int on Windows,
859 
			       otherwise wchar_t (usually int).
860 
			       In any case Unicode points <= 0x10FFFF
861 
			    */
81797 ripley 862 
			    snprintf(outbuf, 11, "\\U%08x", (unsigned int) ucs);
81786 ripley 863 
			    outbuf += 10; outb -= 10;
864 
			}
865 
		    }
866 
		    goto next_char;
32601 ripley 867 
		} else {
87228 kalibera 868 
		    if (!inp_unit_size) {
87241 kalibera 869 
			if (!strncasecmp(from, "UTF-16", 6) ||
870 
			    !strncasecmp(from, "UCS-2", 5))
87228 kalibera 871 
			    inp_unit_size = 2;
87241 kalibera 872 
			else if (!strncasecmp(from, "UTF-32", 6) ||
873 
			           !strncasecmp(from, "UCS-4", 5))
87228 kalibera 874 
			    inp_unit_size = 4;
875 
			else
87241 kalibera 876 
			    /* encodings supported directly by CHARSXP,
877 
			       including the native encoding, all use
878 
			       unit size 1 */
87228 kalibera 879 
			    inp_unit_size = 1;
880 
		    }
87229 kalibera 881 
		    for(int i = 0; i < inp_unit_size && inb > 0; i++) {
87228 kalibera 882 
			if(strcmp(sub, "byte") == 0) {
883 
			    if(outb < 5) {
884 
				R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
885 
				goto top_of_loop;
886 
			    }
887 
			    snprintf(outbuf, 5, "<%02x>",
888 
			             (unsigned char)*inbuf);
889 
			    outbuf += 4; outb -= 4;
890 
			} else {
891 
			    size_t sub_len = strlen(sub);
892 
			    if(outb < sub_len) {
893 
				R_AllocStringBuffer(2*cbuff.bufsize, &cbuff);
894 
				goto top_of_loop;
895 
			    }
896 
			    if (sub_len)
897 
				memcpy(outbuf, sub, sub_len);
898 
			    outbuf += sub_len; outb -= sub_len;
899 
			}
900 
			inbuf++; inb--;
32601 ripley 901 
		    }
902 
		}
903 
		goto next_char;
904 
	    }
40376 ripley 905 
 
55260 ripley 906 
	    if(toRaw) {
907 
		if(res != -1 && inb == 0) {
59096 ripley 908 
		    size_t nout = cbuff.bufsize - 1 - outb;
55260 ripley 909 
		    SEXP el = allocVector(RAWSXP, nout);
87180 kalibera 910 
		    if (nout)
911 
			memcpy(RAW(el), cbuff.data, nout);
55260 ripley 912 
		    SET_VECTOR_ELT(ans, i, el);
913 
		} /* otherwise is already NULL */
914 
	    } else {
915 
		if(res != -1 && inb == 0) {
916 
		    cetype_t ienc = CE_NATIVE;
70047 ripley 917 
 
59096 ripley 918 
		    size_t nout = cbuff.bufsize - 1 - outb;
55260 ripley 919 
		    if(mark) {
920 
			if(isLatin1) ienc = CE_LATIN1;
921 
			else if(isUTF8) ienc = CE_UTF8;
922 
		    }
82791 kalibera 923 
		    /* FIXME: use "bytes" unless CE_NATIVE matches to? */
70047 ripley 924 
		    SET_STRING_ELT(ans, i,
59097 ripley 925 
				   mkCharLenCE(cbuff.data, (int) nout, ienc));
55260 ripley 926 
		} else SET_STRING_ELT(ans, i, NA_STRING);
40672 ripley 927 
	    }
32482 ripley 928 
	}
82791 kalibera 929 
	if (latin1_obj != (iconv_t)-1) Riconv_close(latin1_obj);
930 
	if (utf8_obj != (iconv_t)-1) Riconv_close(utf8_obj);
931 
	if (arg_obj != (iconv_t)-1) Riconv_close(arg_obj);
32551 ripley 932 
	R_FreeStringBuffer(&cbuff);
32415 ripley 933 
    }
934 
    UNPROTECT(1);
935 
    return ans;
936 
}
32492 ripley 937 
 
82476 kalibera 938 
#define CHECK_CHARSXP(x) do { \
939 
    SEXP __x__ = (x);            \
940 
    if(TYPEOF(__x__) != CHARSXP) \
941 
	error(_("'%s' must be called on a CHARSXP, but got '%s'"), \
85146 luke 942 
	      __func__, R_typeToChar(__x__));			   \
82476 kalibera 943 
} while(0);
944 
 
44986 ripley 945 
cetype_t getCharCE(SEXP x)
43932 ripley 946 
{
82476 kalibera 947 
    CHECK_CHARSXP(x);
43932 ripley 948 
    if(IS_UTF8(x)) return CE_UTF8;
949 
    else if(IS_LATIN1(x)) return CE_LATIN1;
54747 ripley 950 
    else if(IS_BYTES(x)) return CE_BYTES;
43932 ripley 951 
    else return CE_NATIVE;
952 
}
953 
 
87938 ripley 954 
// In Rinternals.h
86789 kalibera 955 
Rboolean charIsASCII(SEXP x)
956 
{
957 
    CHECK_CHARSXP(x);
958 
    return IS_ASCII(x) ? TRUE : FALSE;
959 
}
960 
 
87938 ripley 961 
// In Rinternals.h
86789 kalibera 962 
Rboolean charIsUTF8(SEXP x)
963 
{
964 
    CHECK_CHARSXP(x);
965 
    if (IS_ASCII(x) || IS_UTF8(x)) return TRUE;
966 
    if (IS_LATIN1(x) || IS_BYTES(x) || !utf8locale || x == NA_STRING)
967 
	return FALSE;
968 
    return TRUE;
969 
}
970 
 
87938 ripley 971 
// In Rinternals.h
86789 kalibera 972 
Rboolean charIsLatin1(SEXP x)
973 
{
974 
    CHECK_CHARSXP(x);
975 
    if (IS_ASCII(x) || IS_LATIN1(x)) return TRUE;
976 
    if (!latin1locale || IS_UTF8(x) || IS_BYTES(x) || x == NA_STRING)
977 
	return FALSE;
978 
    return TRUE;
979 
}
980 
 
85483 kalibera 981 
#ifdef __APPLE__
87209 kalibera 982 
/* Work-around for system libiconv in macOS 14.1. When an invalid input byte
983 
   is encountered while converting, subsequent valid bytes may be reported as
984 
   invalid and libiconv may crash R due to an assertion failure e.g. once
985 
   then converting an empty input. The problem does not seem to
986 
   happen when the converter is re-set after error. The problem has been
987 
   observed in libiconv-86 (which came with macOS 14.1) but no longer
988 
   in libiconv-92 (macOS 14.2).
43932 ripley 989 
 
85483 kalibera 990 
   While often one should reset the converter in such situation in order to
991 
   support stateful encodings properly, the problem has been seen even when
87209 kalibera 992 
   converting from UTF-8 to UTF-8 (UTF-8 is stateless).
85483 kalibera 993 
 
994 
   This work-around automatically re-sets the converter in Riconv in case
87209 kalibera 995 
   of error for stateless encodings. It is enabled only based on a runtime
996 
   check for the issue (also to avoid to running into problems with BOM
997 
   handling, see R_MACOS_LIBICONV_HANDLE_BOM).
85655 kalibera 998 
 
87209 kalibera 999 
   Can be disabled via env. variable _R_ICONV_RESET_AFTER_ERROR_. */
1000 
# define R_MACOS_LIBICONV_RESET_AFTER_ERROR
1001 
 
85655 kalibera 1002 
/* A hack to detect and undo transliteration (experimental, likely to change
1003 
   or be removed).  While POSIX says that iconv should transliterate or
1004 
   substitute valid input characters not representable in the output
1005 
   encoding, this typically is not the case.  Instead, non-representable
1006 
   characters usually cause an error (EILSEQ or even EINVAL) and R ended up
1007 
   depending on that.
1008 
 
1009 
   macOS 14.1 has a libiconv implementation which transliterates many
1010 
   characters.
1011 
 
87209 kalibera 1012 
   This feature, currently only available for stateless conversions, detects
1013 
   transliteration by converting the result back to the original encoding,
1014 
   compares with the original and then re-runs the conversion only to the
1015 
   to-be-transliterated character. This wouldn't work in cases when the
1016 
   conversion isn't unique, but such cases are unlikely (note implementations
1017 
   of iconv, including libiconv in macOS 14.1, do not support decomposed
1018 
   forms).
85655 kalibera 1019 
 
87209 kalibera 1020 
   Enabled at runtime via env. variable _R_ICONV_UNDO_TRANSLITERATION_. */
87205 kalibera 1021 
# define R_MACOS_LIBICONV_UNDO_TRANSLITERATION
85655 kalibera 1022 
 
87209 kalibera 1023 
/* Work-around for libiconv in macOS 14.1.  This version of
87205 kalibera 1024 
   libiconv accepts BOM for UTF-16, but on error (including EINVAL when it
1025 
   is not given enough input, which is a normal situation in processing a
87209 kalibera 1026 
   stream) it forgets the byte-order it has learned from the BOM. This
1027 
   problem was observed in libiconv-86 (which came with macOS 14.1) and
1028 
   still exists in libiconv-107 (in macOS 15.0).
1029 
 
1030 
   Also, in some cases iconv forgets the BOM on reset, i.e.
1031 
   iconv(cd, NULL, NULL, NULL, NULL) and then starts producing unexpected
1032 
   results. The default is usually big-endian ordering even on little-endian
87205 kalibera 1033 
   machines, so this particularly causes trouble when reading inputs
1034 
   produced on Windows.  The work-around falls back to UTF-16LE/BE or
87209 kalibera 1035 
   UTF32-LE/BE based on the BOM, if present. This problem has been seen
1036 
   already in libiconv-64 (macOS 13.5) and is present also in some other
1037 
   iconv implementations, where the byte-order learned from the BOM is
1038 
   incorrectly treated as being part of the encoding state (but UTF-16
1039 
   and UTF-32 is stateless and the byte-order learned from the BOM
1040 
   should be write-once property of the conversion descriptor). */
87205 kalibera 1041 
# define R_MACOS_LIBICONV_HANDLE_BOM
87209 kalibera 1042 
#endif
87205 kalibera 1043 
 
87209 kalibera 1044 
#ifndef R_MACOS_LIBICONV_WORKAROUND
1045 
# if defined(R_MACOS_LIBICONV_RESET_AFTER_ERROR) \
1046 
     || defined(R_MACOS_LIBICONV_UNDO_TRANSLITERATION) \
1047 
     || defined(R_MACOS_LIBICONV_HANDLE_BOM)
1048 
#  define R_MACOS_LIBICONV_WORKAROUND
1049 
# endif
85483 kalibera 1050 
#endif
1051 
 
1052 
#ifdef R_MACOS_LIBICONV_WORKAROUND
1053 
typedef struct {
1054 
    iconv_t cd;
87891 ripley 1055 
    bool reset_after_error;
85655 kalibera 1056 
    iconv_t cd_back;
87891 ripley 1057 
    bool undo_transliteration;
85655 kalibera 1058 
    size_t buflen;
1059 
    char *buf;
87891 ripley 1060 
    bool handle_bom;
87205 kalibera 1061 
    size_t bomlen;
1062 
    char *tocode;
1063 
    char start[4];
1064 
    size_t startlen;
85483 kalibera 1065 
} Riconv_cd;
1066 
 
87891 ripley 1067 
static bool is_stateful(const char *code)
85483 kalibera 1068 
{
1069 
    /* list from libiconv 1.17, but names are system-specific */
1070 
    static char *stateful[] = {
1071 
        "utf7", "UTF-7", "UNICODE-1-1-UTF-7", "csUnicode11UTF7", "cp1255",
1072 
        "CP1255", "WINDOWS-1255", "MS-HEBR", "cp1258", "CP1258",
1073 
        "WINDOWS-1258", "tcvn", "TCVN", "TCVN-5712", "TCVN5712-1",
1074 
        "TCVN5712-1:1993", "iso2022_jp", "ISO-2022-JP", "csISO2022JP",
1075 
        "iso2022_jp1", "ISO-2022-JP-1", "iso2022_jp2", "ISO-2022-JP-2",
1076 
        "csISO2022JP2", "iso2022_jpms", "ISO-2022-JP-MS", "CP50221",
1077 
        "iso2022_cn", "ISO-2022-CN", "csISO2022CN", "iso2022_cn_ext",
1078 
        "ISO-2022-CN-EXT", "hz", "HZ", "HZ-GB-2312", "big5hkscs1999",
1079 
        "BIG5-HKSCS:1999", "big5hkscs2001", "BIG5-HKSCS:2001",
1080 
        "big5hkscs2004", "BIG5-HKSCS:2004", "big5hkscs2008", "BIG5-HKSCS",
1081 
        "BIG5HKSCS", "BIG5-HKSCS:2008", "iso2022_kr", "ISO-2022-KR",
1082 
        "csISO2022KR", "euc_jisx0213", "EUC-JISX0213", "EUC-JIS-2004",
1083 
        "shift_jisx0213", "SHIFT_JISX0213", "SHIFT_JIS-2004", "iso2022_jp3",
1084 
        "ISO-2022-JP-3", "ISO-2022-JP-2004", NULL
1085 
    };
1086 
 
1087 
    if (!strcasecmp(code, "UTF-8") || !strcasecmp(code, "ISO-8859-1") ||
1088 
        !strcasecmp(code, "latin1"))
87891 ripley 1089 
	return false;
85483 kalibera 1090 
 
1091 
    /* if performance of this becomes a problem, there could be a cache of
1092 
       recently used encodings or/and a perfect hashing function */
1093 
    for(int i = 0; stateful[i] ; i++)
1094 
	if (!strcasecmp(code, stateful[i]))
87891 ripley 1095 
	    return true;
1096 
    return false;
85483 kalibera 1097 
}
85655 kalibera 1098 
 
1099 
# ifdef R_MACOS_LIBICONV_UNDO_TRANSLITERATION
87891 ripley 1100 
static bool is_unicode(const char *code)
85655 kalibera 1101 
{
1102 
    /* list from libiconv 1.17, but names are system-specific */
1103 
    static char *unicode[] = {
1104 
        "UTF-8",
1105 
        "UCS-4", "UCS-4BE", "UCS-4LE",
1106 
        "UTF-16", "UTF-16BE", "UTF-16LE",
1107 
        "UTF-32", "UTF-32BE", "UTF-32LE",
1108 
        "UTF-7",
1109 
        "C99", "JAVA", NULL
1110 
    };
1111 
 
1112 
    for(int i = 0; unicode[i] ; i++)
1113 
	if (!strcasecmp(code, unicode[i]))
87891 ripley 1114 
	    return true;
1115 
    return false;
85655 kalibera 1116 
}
1117 
# endif
87205 kalibera 1118 
 
87209 kalibera 1119 
/* only for debugging, may be removed */
1120 
static int macos_libiconv_verbose(void) {
1121 
    static int verbose = -1;
1122 
 
1123 
    if (verbose == -1) {
1124 
	char *p = getenv("_R_ICONV_VERBOSE_");
1125 
	verbose = p && StringTrue(p);
1126 
    }
1127 
    return verbose;
1128 
}
1129 
 
87205 kalibera 1130 
static int iconv_close_internal(Riconv_cd *rcd)
1131 
{
1132 
    int res = 0;
1133 
 
1134 
    if (rcd->cd != (iconv_t)-1)
1135 
	res = iconv_close(rcd->cd);
1136 
 
1137 
# ifdef R_MACOS_LIBICONV_HANDLE_BOM
1138 
    if (rcd->handle_bom && rcd->tocode)
1139 
	free(rcd->tocode);
1140 
# endif
1141 
 
1142 
# ifdef R_MACOS_LIBICONV_UNDO_TRANSLITERATION
1143 
    if (rcd->undo_transliteration) {
1144 
	if (rcd->buf)
1145 
	    free(rcd->buf);
1146 
	if (rcd->cd_back != (iconv_t)-1) {
1147 
	    if (iconv_close(rcd->cd_back))
1148 
		res = -1;
1149 
	}
1150 
    }
1151 
# endif
1152 
 
1153 
    free(rcd);
1154 
    return res;
1155 
}
85483 kalibera 1156 
#endif
1157 
 
87209 kalibera 1158 
#ifdef R_MACOS_LIBICONV_HANDLE_BOM
87205 kalibera 1159 
 
87209 kalibera 1160 
/* Try converting input in UTF-16 iteratively (first 5 bytes, then the
1161 
   remaining byte) to UTF-8. The result should be "23".
1162 
   See fails_iteratively_with_bom().
1163 
 
1164 
   1 when iconv "successfully" returns wrong result
1165 
   -1 on (other) error
1166 
 
1167 
*/
1168 
static int fails_iteratively_when_incomplete(char *input)
1169 
{
1170 
    iconv_t cd = iconv_open("UTF-8", "UTF-16");
1171 
    if (cd == (iconv_t)-1)
1172 
	return -1;
1173 
 
1174 
    char output[6]; // UTF-8-BOM (possibly) + "23" + NUL
1175 
    char *inbuf = input;
1176 
    size_t inbytesleft = 5;
1177 
    char *outbuf = output;
1178 
    size_t outbytesleft = 6;
1179 
 
1180 
    size_t res = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1181 
    if (res != (size_t)-1 || errno != EINVAL) {
1182 
	iconv_close(cd);
1183 
	return -1;
1184 
    }
1185 
 
1186 
    inbytesleft = 6 - (5 - inbytesleft);
1187 
    res = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1188 
    iconv_close(cd);
1189 
    if (res == (size_t)-1)
1190 
	return -1;
1191 
    *outbuf = 0;
1192 
 
1193 
    /* remove UTF-8 BOM if present (unlikely) */
1194 
    int offset = 0;
1195 
    if ((outbuf - output >= 3) && !memcmp(output, "\xef\xbb\xbf", 3))
1196 
	offset = 3;
1197 
 
1198 
    if (!memcmp(output + offset, "23", 3))
1199 
	return 0; /* success, conversion works iteratively */
1200 
    else
1201 
	return 1; /* wrong result */
1202 
}
1203 
 
1204 
/* Try converting input in UTF-16 iteratively (first 4 bytes, then
1205 
   re-set, then remaining two bytes) to UTF-8. The result should be "23".
1206 
   See fails_iteratively_with_bom().
1207 
 
1208 
   1 when iconv "successfully" returns wrong result
1209 
   -1 on (other) error
1210 
 
1211 
*/
1212 
static int fails_iteratively_with_reset(char *input)
1213 
{
1214 
    iconv_t cd = iconv_open("UTF-8", "UTF-16");
1215 
    if (cd == (iconv_t)-1)
1216 
	return -1;
1217 
 
1218 
    char output[6]; // UTF-8-BOM (possibly) + "23" + NUL
1219 
    char *inbuf = input;
1220 
    size_t inbytesleft = 4;
1221 
    char *outbuf = output;
1222 
    size_t outbytesleft = 6;
1223 
 
1224 
    size_t res = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1225 
    if (res == (size_t)-1) {
1226 
	iconv_close(cd);
1227 
	return -1;
1228 
    }
1229 
    iconv(cd, NULL, NULL, NULL, NULL);
1230 
 
1231 
    inbytesleft = 6 - (4 - inbytesleft);
1232 
    res = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1233 
    iconv_close(cd);
1234 
    if (res == (size_t)-1)
1235 
	return -1;
1236 
    *outbuf = 0;
1237 
 
1238 
    /* remove UTF-8 BOM if present (unlikely) */
1239 
    int offset = 0;
1240 
    if ((outbuf - output >= 3) && !memcmp(output, "\xef\xbb\xbf", 3)) {
1241 
	if (macos_libiconv_verbose())
1242 
	    fprintf(stderr, "ICONV: UTF-8 with BOM produced.\n");
1243 
	offset = 3;
1244 
    }
1245 
 
1246 
    if (!memcmp(output + offset, "23", 3))
1247 
	return 0; /* success, conversion works iteratively */
1248 
    else
1249 
	return 1; /* wrong result */
1250 
}
1251 
 
1252 
/* Test whether iterative conversion from UTF-16 with a BOM to UTF-8 fails
1253 
   by producing an incorrect result. This has been observed in Apple libiconv
1254 
   on macOS. A runtime test is used as that version cannot be reliably
1255 
   detected.
1256 
 
1257 
   1 when iconv "successfully" returns wrong result
1258 
   -1 on (other) error
1259 
 
1260 
*/
1261 
static int fails_iteratively_with_bom(void)
1262 
{
1263 
    unsigned words[] = { 0xfeff /* BOM */, 0x32 /* 2 */, 0x33 /* 3 */};
1264 
    char big[6];
1265 
    char little[6];
1266 
 
1267 
    for(int i = 0; i < 6; i += 2) {
1268 
	unsigned w = words[i/2];
87225 ripley 1269 
	big[i] = little[i+1] = (char) (w >> 8);
87209 kalibera 1270 
	big[i+1] = little[i] = w & 0xff;
1271 
    }
1272 
 
1273 
    int ile = fails_iteratively_when_incomplete(little);
1274 
    int ibe = fails_iteratively_when_incomplete(big);
1275 
 
1276 
    int rle = fails_iteratively_with_reset(little);
1277 
    int rbe = fails_iteratively_with_reset(big);
1278 
 
1279 
    if (macos_libiconv_verbose()) {
1280 
	fprintf(stderr, "ICONV: Fails iteratively when incomplete (LE): %d.\n",
1281 
	        ile);
1282 
	fprintf(stderr, "ICONV: Fails iteratively when incomplete (BE): %d.\n",
1283 
	        ibe);
1284 
	fprintf(stderr, "ICONV: Fails iteratively with reset (LE): %d.\n",
1285 
	        rle);
1286 
	fprintf(stderr, "ICONV: Fails iteratively with reset (BE): %d.\n",
1287 
	        rbe);
1288 
    }
1289 
 
1290 
    if (ile == 1 || ibe == 1 || rle == 1 || rbe == 1)
1291 
	return 1;
1292 
    if (ile == -1 || ibe == -1 || rle == -1 || rbe == -1)
1293 
	return -1;
1294 
    return 0;
1295 
}
87212 kalibera 1296 
#endif
87209 kalibera 1297 
 
87212 kalibera 1298 
#ifdef R_MACOS_LIBICONV_RESET_AFTER_ERROR
1299 
 
87209 kalibera 1300 
/* Test whether iconv, after encountering an invalid byte in input, keeps
1301 
   incorrectly reporting as invalid also additional valid bytes. This has
1302 
   been observed in Apple libiconv on macOS. A runtime test is used as that
1303 
   version cannot be reliably detected.
1304 
 
1305 
   1 when iconv "successfully" returns wrong result
1306 
   -1 on (other) error
1307 
 
1308 
static int breaks_after_invalid_byte(void)
1309 
{
1310 
    char *input = "1" "\xFC" "3456789";
1311 
 
1312 
    iconv_t cd = iconv_open("UTF-8", "UTF-8");
1313 
    if (cd == (iconv_t)-1)
1314 
        return -1;
1315 
 
1316 
    char output[10];
1317 
    char *inbuf = input;
1318 
    size_t inbytesleft = 10;
1319 
    char *outbuf = output;
1320 
    size_t outbytesleft = 10;
1321 
 
1322 
    size_t res = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1323 
    if (res != (size_t)-1 || (errno != EILSEQ && errno != EINVAL)
1324 
        || outbytesleft != 9 || inbytesleft != 9) {
1325 
 
1326 
	iconv_close(cd);
1327 
	return -1;
1328 
    }
1329 
 
1330 
    /* advance over invalid byte */
1331 
    inbuf++;
1332 
    inbytesleft--;
1333 
 
1334 
    res = iconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
1335 
    iconv_close(cd);
1336 
    if (res == (size_t)-1 && (errno == EINVAL || errno == EILSEQ))
1337 
        return 1; /* input incorrectly reported as invalid */
1338 
    *outbuf = '\0';
1339 
    if (memcmp(output, "13456789", 9)) {
1340 
	if (macos_libiconv_verbose())
1341 
	    fprintf(stderr, "ICONV: Incorrect conversion with invalid byte.\n");
1342 
	return -1; /* wrong result for other reason */
1343 
    }
1344 
 
1345 
    return 0; /* success, handling invalid bytes works */
1346 
}
1347 
#endif
1348 
 
85483 kalibera 1349 
static void *iconv_open_internal(const char *tocode, const char *fromcode)
1350 
{
1351 
#ifndef R_MACOS_LIBICONV_WORKAROUND
1352 
    return iconv_open(tocode, fromcode);
1353 
#else
1354 
    iconv_t cd = iconv_open(tocode, fromcode);
1355 
    if (cd == (iconv_t)-1)
1356 
	return cd;
1357 
 
1358 
    Riconv_cd *rcd = malloc(sizeof(Riconv_cd));
1359 
    if (!rcd) {
1360 
	errno = ENOMEM;
1361 
	return (void *)(iconv_t)-1;
1362 
    }
1363 
    rcd->cd = cd;
85655 kalibera 1364 
 
87209 kalibera 1365 
    rcd->reset_after_error = FALSE;
87205 kalibera 1366 
    rcd->handle_bom = FALSE;
1367 
    rcd->undo_transliteration = FALSE; /* for cleanup */
1368 
 
87209 kalibera 1369 
# ifdef R_MACOS_LIBICONV_RESET_AFTER_ERROR
1370 
    static int iconv_use_reset_after_error = -1; /* -1: not known yet */
1371 
 
1372 
    if (iconv_use_reset_after_error)
1373 
	rcd->reset_after_error = !is_stateful(tocode)
1374 
	                         && !is_stateful(fromcode);
1375 
 
1376 
    if (rcd->reset_after_error && iconv_use_reset_after_error == -1) {
1377 
	/* a run-time check whether iconv needs reset after error */
1378 
	int bib = breaks_after_invalid_byte();
1379 
	if (macos_libiconv_verbose())
1380 
	    fprintf(stderr, "ICONV: Breaks after invalid bytes: %d.\n", bib);
1381 
 
1382 
	char *p = getenv("_R_ICONV_RESET_AFTER_ERROR_");
1383 
	if (bib == 1 && (!p || !StringFalse(p))) {
1384 
	    if (macos_libiconv_verbose())
1385 
		fprintf(stderr, "ICONV: Reset after error enabled.\n");
1386 
	    iconv_use_reset_after_error = 1;
1387 
	} else {
1388 
	    iconv_use_reset_after_error = 0;
1389 
	    rcd->reset_after_error = FALSE;
1390 
	}
1391 
   }
1392 
# endif
1393 
 
87205 kalibera 1394 
# ifdef R_MACOS_LIBICONV_HANDLE_BOM
87209 kalibera 1395 
    static int iconv_needs_bom_handling = -1; /* -1: not known yet */
1396 
 
1397 
    if (iconv_needs_bom_handling) {
1398 
	if (!strcasecmp(fromcode, "UTF-16")
1399 
	    || !strcasecmp(fromcode,"UNICODE")) {
1400 
 
1401 
	    rcd->handle_bom = TRUE;
1402 
	    rcd->bomlen = 2;
1403 
	} else if (!strcasecmp(fromcode, "UTF-32")) {
1404 
	    rcd->handle_bom = TRUE;
1405 
	    rcd->bomlen = 4;
1406 
	}
87205 kalibera 1407 
    }
87209 kalibera 1408 
 
1409 
    if (rcd->handle_bom && iconv_needs_bom_handling == -1) {
1410 
	/* a run-time check whether iconv needs bom handling */
1411 
	if (fails_iteratively_with_bom() == 1) {
1412 
	    if (macos_libiconv_verbose())
1413 
		fprintf(stderr, "ICONV: BOM handling enabled.\n");
1414 
	    iconv_needs_bom_handling = 1;
1415 
	} else {
1416 
	    iconv_needs_bom_handling = 0;
1417 
	    rcd->handle_bom = FALSE;
1418 
	}
1419 
    }
1420 
 
87205 kalibera 1421 
    if (rcd->handle_bom) {
1422 
	rcd->startlen = 0;
1423 
	size_t len = strlen(tocode)+1;
1424 
	rcd->tocode = malloc(len);
1425 
	if (!rcd->tocode) {
1426 
	    iconv_close_internal(rcd);
1427 
	    errno = ENOMEM;
1428 
	    return (void *)(iconv_t)-1;
1429 
	}
1430 
	memcpy(rcd->tocode, tocode, len);
1431 
    }
1432 
# endif
1433 
 
85655 kalibera 1434 
# ifdef R_MACOS_LIBICONV_UNDO_TRANSLITERATION
87209 kalibera 1435 
    rcd->undo_transliteration = !is_unicode(tocode)
1436 
                                && !is_stateful(tocode)
1437 
                                && !is_stateful(fromcode);
85655 kalibera 1438 
 
1439 
    char *p = getenv("_R_ICONV_UNDO_TRANSLITERATION_");
1440 
    if (!p || !StringTrue(p))
1441 
	rcd->undo_transliteration = FALSE;
1442 
 
1443 
    if (rcd->undo_transliteration) {
87205 kalibera 1444 
	rcd->buf = NULL; /* for cleanup */
85655 kalibera 1445 
	rcd->cd_back = iconv_open(fromcode, tocode);
1446 
	if (rcd->cd_back == (iconv_t)-1) {
87205 kalibera 1447 
	    iconv_close_internal(rcd);
85655 kalibera 1448 
	    return (iconv_t)-1;
1449 
	}
1450 
	rcd->buflen = 8192;
1451 
	rcd->buf = malloc(rcd->buflen);
1452 
	if (!rcd->buf) {
87205 kalibera 1453 
	    iconv_close_internal(rcd);
85655 kalibera 1454 
	    return (iconv_t)-1;
1455 
	}
1456 
    }
1457 
# endif
85483 kalibera 1458 
    return rcd;
1459 
#endif
1460 
}
1461 
 
41781 ripley 1462 
void * Riconv_open (const char* tocode, const char* fromcode)
32492 ripley 1463 
{
44490 urbaneks 1464 
#if defined Win32 || __APPLE__
72214 ripley 1465 
// These two support "utf8"
44495 ripley 1466 
# ifdef Win32
52753 ripley 1467 
    const char *cp = "ASCII";
46512 ripley 1468 
    char to[20] = "";
1469 
    if (localeCP > 0) {snprintf(to, 20, "CP%d", localeCP); cp = to;}
44495 ripley 1470 
# else /* __APPLE__ */
52753 ripley 1471 
    const char *cp = "UTF-8";
44490 urbaneks 1472 
    if (latin1locale) cp = "ISO-8859-1";
44495 ripley 1473 
    else if (!utf8locale) cp = locale2charset(NULL);
1474 
# endif
85483 kalibera 1475 
    if (!*tocode && !*fromcode) return iconv_open_internal(cp, cp);
1476 
    if(!*tocode)  return iconv_open_internal(cp, fromcode);
1477 
    else if(!*fromcode) return iconv_open_internal(tocode, cp);
1478 
    else return iconv_open_internal(tocode, fromcode);
32720 ripley 1479 
#else
72214 ripley 1480 
// "utf8" is not valid but people keep on using it
1481 
    const char *to = tocode, *from = fromcode;
1482 
    if(strcasecmp(tocode, "utf8") == 0) to = "UTF-8";
1483 
    if(strcasecmp(fromcode, "utf8") == 0) from = "UTF-8";
85483 kalibera 1484 
    return iconv_open_internal(to, from);
32720 ripley 1485 
#endif
32492 ripley 1486 
}
1487 
 
54764 ripley 1488 
/* Should be defined in config.h, but prior to 2.13.0 was only checked
1489 
   if the NLS was enabled  */
42627 ripley 1490 
#ifndef ICONV_CONST
1491 
# define ICONV_CONST
1492 
#endif
1493 
 
41807 rgentlem 1494 
size_t Riconv (void *cd, const char **inbuf, size_t *inbytesleft,
32493 ripley 1495 
	       char **outbuf, size_t *outbytesleft)
32492 ripley 1496 
{
85655 kalibera 1497 
#ifdef R_MACOS_LIBICONV_WORKAROUND
1498 
    Riconv_cd *rcd = (Riconv_cd *)cd;
1499 
 
87205 kalibera 1500 
# ifdef R_MACOS_LIBICONV_HANDLE_BOM
1501 
    const char *prev_inbuf = NULL;
1502 
    if (rcd->handle_bom && inbuf)
1503 
	prev_inbuf = *inbuf;
1504 
# endif
1505 
 
85655 kalibera 1506 
# ifdef R_MACOS_LIBICONV_UNDO_TRANSLITERATION
1507 
    const char *old_inbuf = NULL;
1508 
    size_t old_inbytesleft = 0;
1509 
    char *old_outbuf = NULL;
1510 
    size_t old_outbytesleft = 0;
1511 
 
1512 
    if (rcd->undo_transliteration) {
1513 
	old_inbuf = inbuf ? *inbuf : NULL;
1514 
	old_inbytesleft = inbytesleft ? *inbytesleft : 0;
1515 
	old_outbuf = outbuf ? *outbuf : NULL;
1516 
	old_outbytesleft = outbytesleft ? *outbytesleft : 0;
1517 
    }
1518 
# endif
1519 
#endif
1520 
 
44161 ripley 1521 
    /* here libiconv has const char **, glibc has char ** for inbuf */
85483 kalibera 1522 
    size_t res = iconv(
1523 
#ifdef R_MACOS_LIBICONV_WORKAROUND
85655 kalibera 1524 
                       rcd->cd,
85483 kalibera 1525 
#else
1526 
                       (iconv_t)cd,
1527 
#endif
1528 
                       (ICONV_CONST char **) inbuf, inbytesleft,
1529 
                       outbuf, outbytesleft);
1530 
 
1531 
#ifdef R_MACOS_LIBICONV_WORKAROUND
87209 kalibera 1532 
# ifdef R_MACOS_LIBICONV_RESET_AFTER_ERROR
85655 kalibera 1533 
    if (rcd->reset_after_error &&
1534 
	(res == (size_t)-1 && (errno == EILSEQ || errno == EINVAL))) {
1535 
 
1536 
	int saveerrno = errno;
1537 
	iconv(rcd->cd, NULL, NULL, NULL, NULL);
1538 
	errno = saveerrno;
87209 kalibera 1539 
    }
1540 
# endif
85655 kalibera 1541 
 
87205 kalibera 1542 
# ifdef R_MACOS_LIBICONV_HANDLE_BOM
1543 
    if (rcd->handle_bom && prev_inbuf && inbuf) {
1544 
	size_t tocopy = rcd->bomlen - rcd->startlen;
1545 
	ptrdiff_t avail = *inbuf - prev_inbuf;
1546 
 
1547 
	if (avail < tocopy)
1548 
	    tocopy = (size_t) avail;
1549 
	memcpy(rcd->start + rcd->startlen, prev_inbuf, tocopy);
1550 
	rcd->startlen += tocopy;
1551 
 
1552 
	if (rcd->startlen == rcd->bomlen) {
1553 
	    const char *new_fromcode = NULL;
1554 
 
1555 
	    if (rcd->bomlen == 2) {
1556 
		if (!memcmp(rcd->start, "\xff\xfe", 2))
1557 
		    new_fromcode = "UTF-16LE";
1558 
		else if (!memcmp(rcd->start, "\xfe\xff", 2))
1559 
		    new_fromcode = "UTF-16BE";
1560 
	    } else if (rcd->bomlen == 4) {
1561 
		if (!memcmp(rcd->start, "\xff\xfe\x00\x00", 4))
1562 
		    new_fromcode = "UTF-32LE";
1563 
		else if (!memcmp(rcd->start, "\x00\x00\xfe\xff", 4))
1564 
		    new_fromcode = "UTF-32BE";
1565 
	    }
1566 
	    if (new_fromcode) {
1567 
		iconv_close((iconv_t) rcd->cd);
1568 
		rcd->cd = iconv_open(rcd->tocode, new_fromcode);
1569 
	    }
1570 
 
1571 
	    free(rcd->tocode);
1572 
	    rcd->tocode = NULL; /* for cleanup */
1573 
	    rcd->handle_bom = FALSE;
1574 
	}
1575 
    }
1576 
# endif
1577 
 
85655 kalibera 1578 
# ifdef R_MACOS_LIBICONV_UNDO_TRANSLITERATION
1579 
    if (rcd->undo_transliteration &&
1580 
        inbuf && inbytesleft && outbuf && outbytesleft) {
1581 
 
1582 
	int saveerrno = errno;
1583 
	size_t needed = old_inbytesleft - *inbytesleft;
1584 
	if (rcd->buflen < needed) {
1585 
	    free(rcd->buf);
1586 
	    rcd->buf = malloc(needed);
1587 
	    if (!rcd->buf) {
1588 
		errno = ENOMEM;
1589 
		return -1;
1590 
	    }
1591 
	    rcd->buflen = needed;
1592 
	}
1593 
 
1594 
	const char *back_inbuf = old_outbuf;
1595 
	size_t back_inbytesleft = old_outbytesleft - *outbytesleft;
1596 
	char *back_outbuf = rcd->buf;
1597 
	size_t back_outbytesleft = needed;
1598 
 
1599 
	iconv(rcd->cd_back, NULL, NULL, NULL, NULL);
86279 ripley 1600 
	size_t back_res = iconv(rcd->cd_back,
85655 kalibera 1601 
	      (ICONV_CONST char **) &back_inbuf,
1602 
	      &back_inbytesleft,
1603 
	      (ICONV_CONST char **) &back_outbuf,
1604 
	      &back_outbytesleft);
1605 
 
1606 
	if (back_res == (size_t)-1) {
1607 
	    /* should not happen */
85483 kalibera 1608 
	    errno = saveerrno;
85655 kalibera 1609 
	    return res;
85483 kalibera 1610 
	}
85655 kalibera 1611 
 
1612 
	if (back_outbytesleft == 0 && back_inbytesleft == 0 &&
1613 
	    !memcmp(rcd->buf, old_inbuf, needed)) {
1614 
 
1615 
	    /* no transliteration happened */
1616 
	    errno = saveerrno;
1617 
	    return res;
1618 
	}
1619 
 
1620 
	size_t stored = needed - back_outbytesleft;
1621 
	size_t i;
1622 
	for(i = 0; i < stored; i++)
1623 
	    if (rcd->buf[i] != old_inbuf[i]) {
1624 
		/* byte at index i in old_inbuf was probably transliterated,
1625 
		   so convert again only i bytes and report error */
1626 
		*inbuf = old_inbuf;
1627 
		*outbuf = old_outbuf;
1628 
		*outbytesleft = old_outbytesleft;
1629 
		size_t reduced = i;
1630 
		res = iconv(rcd->cd,
1631 
		            (ICONV_CONST char **) inbuf,
1632 
		            &reduced,
1633 
		            (ICONV_CONST char **) outbuf,
1634 
		            outbytesleft);
1635 
 
1636 
		/* "reduced" should be 0 now */
1637 
		*inbytesleft = old_inbytesleft - (i - reduced);
1638 
		errno = EILSEQ;
1639 
		return -1;
1640 
	    }
1641 
	/* should not be reached */
1642 
	errno = saveerrno;
1643 
    }
1644 
# endif
85483 kalibera 1645 
#endif
1646 
    return res;
32492 ripley 1647 
}
1648 
 
32493 ripley 1649 
int Riconv_close (void *cd)
32492 ripley 1650 
{
85483 kalibera 1651 
#ifndef R_MACOS_LIBICONV_WORKAROUND
32492 ripley 1652 
    return iconv_close((iconv_t) cd);
85655 kalibera 1653 
 
85483 kalibera 1654 
#else
87205 kalibera 1655 
    return iconv_close_internal((Riconv_cd *)cd);
85483 kalibera 1656 
#endif
32492 ripley 1657 
}
40672 ripley 1658 
 
66479 luke 1659 
typedef enum {
82476 kalibera 1660 
    NT_NONE        = 0, /* no translation is needed */
66479 luke 1661 
    NT_FROM_UTF8   = 1, /* need to translate from UTF8 */
73783 kalibera 1662 
    NT_FROM_LATIN1 = 2, /* need to translate from latin1 */
82476 kalibera 1663 
    NT_FROM_NATIVE = 3, /* need to translate from native encoding */
82582 kalibera 1664 
    NT_FROM_ASCII  = 4, /* need to translate from ASCII */
66479 luke 1665 
} nttype_t;
1666 
 
1667 
/* Decides whether translation to native encoding is needed. */
82476 kalibera 1668 
static R_INLINE nttype_t needsTranslation(SEXP x)
1669 
{
66479 luke 1670 
    if (IS_ASCII(x)) return NT_NONE;
1671 
    if (IS_UTF8(x)) {
70047 ripley 1672 
	if (utf8locale || x == NA_STRING) return NT_NONE;
1673 
	return NT_FROM_UTF8;
66479 luke 1674 
    }
1675 
    if (IS_LATIN1(x)) {
70047 ripley 1676 
	if (x == NA_STRING || latin1locale) return NT_NONE;
1677 
	return NT_FROM_LATIN1;
66479 luke 1678 
    }
1679 
    if (IS_BYTES(x))
70047 ripley 1680 
	error(_("translating strings with \"bytes\" encoding is not allowed"));
66479 luke 1681 
    return NT_NONE;
1682 
}
1683 
 
46133 ripley 1684 
static void *latin1_obj = NULL, *utf8_obj=NULL, *ucsmb_obj=NULL,
1685 
    *ucsutf8_obj=NULL;
40712 ripley 1686 
 
76974 ripley 1687 
/* Translates string in "ans" to native encoding returning it in string
82476 kalibera 1688 
   buffer "cbuff". */
76994 ripley 1689 
static int translateToNative(const char *ans, R_StringBuffer *cbuff,
1690 
			     nttype_t ttype, int mustWork)
76974 ripley 1691 
{
66479 luke 1692 
    if (ttype == NT_NONE)
70047 ripley 1693 
	error(_("internal error: no translation needed"));
66479 luke 1694 
 
40672 ripley 1695 
    void * obj;
73786 kalibera 1696 
    const char *inbuf, *from;
63223 ripley 1697 
    char *outbuf;
40672 ripley 1698 
    size_t inb, outb, res;
87891 ripley 1699 
    bool failed = false;
40672 ripley 1700 
 
66479 luke 1701 
    if(ttype == NT_FROM_LATIN1) {
40712 ripley 1702 
	if(!latin1_obj) {
73786 kalibera 1703 
#ifdef HAVE_ICONV_CP1252
1704 
	    from = "CP1252";
1705 
#else
1706 
	    from = "latin1";
1707 
#endif
1708 
	    obj = Riconv_open("", from);
40712 ripley 1709 
	    /* should never happen */
45703 ripley 1710 
	    if(obj == (void *)(-1))
1711 
#ifdef Win32
54753 ripley 1712 
		error(_("unsupported conversion from '%s' in codepage %d"),
73786 kalibera 1713 
		      from, localeCP);
45703 ripley 1714 
#else
70047 ripley 1715 
		error(_("unsupported conversion from '%s' to '%s'"),
73786 kalibera 1716 
		      from, "");
45703 ripley 1717 
#endif
40712 ripley 1718 
	    latin1_obj = obj;
1719 
	}
1720 
	obj = latin1_obj;
82476 kalibera 1721 
    } else { /* ttype == NT_FROM_UTF8 */
40712 ripley 1722 
	if(!utf8_obj) {
1723 
	    obj = Riconv_open("", "UTF-8");
1724 
	    /* should never happen */
70047 ripley 1725 
	    if(obj == (void *)(-1))
45703 ripley 1726 
#ifdef Win32
54753 ripley 1727 
		error(_("unsupported conversion from '%s' in codepage %d"),
73132 kalibera 1728 
		      "UTF-8", localeCP);
45703 ripley 1729 
#else
70047 ripley 1730 
		error(_("unsupported conversion from '%s' to '%s'"),
73132 kalibera 1731 
		      "UTF-8", "");
45703 ripley 1732 
#endif
40712 ripley 1733 
	    utf8_obj = obj;
1734 
	}
45446 ripley 1735 
	obj = utf8_obj;
40712 ripley 1736 
    }
44054 ripley 1737 
 
66479 luke 1738 
    R_AllocStringBuffer(0, cbuff);
40672 ripley 1739 
top_of_loop:
45412 ripley 1740 
    inbuf = ans; inb = strlen(inbuf);
66479 luke 1741 
    outbuf = cbuff->data; outb = cbuff->bufsize - 1;
40672 ripley 1742 
    /* First initialize output */
1743 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
1744 
next_char:
1745 
    /* Then convert input  */
41884 ripley 1746 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
40672 ripley 1747 
    if(res == -1 && errno == E2BIG) {
66479 luke 1748 
	R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
40672 ripley 1749 
	goto top_of_loop;
51812 ripley 1750 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
85476 kalibera 1751 
	res = Riconv(obj, NULL, NULL, &outbuf, &outb);
1752 
	if((res == -1 && errno == E2BIG) || outb < 13) {
66479 luke 1753 
	    R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
40672 ripley 1754 
	    goto top_of_loop;
1755 
	}
87891 ripley 1756 
	failed = true;
66479 luke 1757 
	if (ttype == NT_FROM_UTF8) {
44034 ripley 1758 
	    /* if starting in UTF-8, use \uxxxx */
1759 
	    /* This must be the first byte */
1760 
	    wchar_t wc;
78021 ripley 1761 
	    ssize_t clen = utf8toucs(&wc, inbuf);
44100 ripley 1762 
	    if(clen > 0 && inb >= clen) {
77916 ripley 1763 
		R_wchar_t ucs;
72707 murdoch 1764 
	    	if (IS_HIGH_SURROGATE(wc))
1765 
	    	    ucs = utf8toucs32(wc, inbuf);
1766 
	    	else
77916 ripley 1767 
	    	    ucs = (R_wchar_t) wc;
44100 ripley 1768 
		inbuf += clen; inb -= clen;
72707 murdoch 1769 
		if(ucs < 65536) {
71586 ripley 1770 
		// gcc 7 objects to this with unsigned int
72707 murdoch 1771 
		    snprintf(outbuf, 9, "<U+%04X>", (unsigned short) ucs);
44100 ripley 1772 
		    outbuf += 8; outb -= 8;
1773 
		} else {
77916 ripley 1774 
		    // R_wchar_t is usually unsigned int, but wchar_t need not be
73787 ripley 1775 
		    snprintf(outbuf, 13, "<U+%08X>", (unsigned int) ucs);
45446 ripley 1776 
		    outbuf += 12; outb -= 12;
44100 ripley 1777 
		}
44034 ripley 1778 
	    } else {
44100 ripley 1779 
		snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
1780 
		outbuf += 4; outb -= 4;
1781 
		inbuf++; inb--;
44034 ripley 1782 
	    }
76974 ripley 1783 
	} else { // not from UTF-8
44034 ripley 1784 
	    snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
1785 
	    outbuf += 4; outb -= 4;
1786 
	    inbuf++; inb--;
1787 
	}
40672 ripley 1788 
	goto next_char;
1789 
    }
1790 
    *outbuf = '\0';
76981 ripley 1791 
    if (mustWork && failed) {
82494 kalibera 1792 
	/* copy to truncate and in case of error prevent memory leak */
1793 
	char err_buff[256];
1794 
	if (strlen(cbuff->data) > 255) {
1795 
	    strncpy(err_buff, cbuff->data, 252);
1796 
	    err_buff[252] = '\0';
1797 
	    mbcsTruncateToValid(err_buff);
1798 
	    strcat(err_buff, "...");
1799 
	} else
1800 
	    strcpy(err_buff, cbuff->data);
1801 
 
76994 ripley 1802 
	if (mustWork == 2) {
82476 kalibera 1803 
	    warning(_("unable to translate '%s' to native encoding"),
82494 kalibera 1804 
		    err_buff);
76994 ripley 1805 
	    return 1;
82309 kalibera 1806 
	} else {
1807 
	    R_FreeStringBuffer(cbuff);
1808 
	    error(_("unable to translate '%s' to native encoding"), err_buff);
1809 
	}
76981 ripley 1810 
    }
76994 ripley 1811 
    return 0;
66479 luke 1812 
}
1813 
 
82476 kalibera 1814 
static const char *copyAndFreeStringBuffer(R_StringBuffer *cbuff)
1815 
{
1816 
    size_t res = strlen(cbuff->data) + 1;
1817 
    char *p = R_alloc(res, 1);
1818 
    memcpy(p, cbuff->data, res);
1819 
    R_FreeStringBuffer(cbuff);
1820 
    return p;
1821 
}
66479 luke 1822 
 
1823 
/* This may return a R_alloc-ed result, so the caller has to manage the
1824 
   R_alloc stack */
1825 
const char *translateChar(SEXP x)
1826 
{
82476 kalibera 1827 
    CHECK_CHARSXP(x);
66479 luke 1828 
    nttype_t t = needsTranslation(x);
1829 
    const char *ans = CHAR(x);
1830 
    if (t == NT_NONE) return ans;
1831 
 
1832 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
76974 ripley 1833 
    translateToNative(ans, &cbuff, t, 0);
82476 kalibera 1834 
    return copyAndFreeStringBuffer(&cbuff);
40672 ripley 1835 
}
43932 ripley 1836 
 
82495 kalibera 1837 
/* Variant which does not return escaped string (which must work, throwing
1838 
   error when conversion fails). Used for file paths, including devices. */
76974 ripley 1839 
const char *translateCharFP(SEXP x)
1840 
{
82476 kalibera 1841 
    CHECK_CHARSXP(x);
76974 ripley 1842 
    nttype_t t = needsTranslation(x);
1843 
    const char *ans = CHAR(x);
1844 
    if (t == NT_NONE) return ans;
1845 
 
1846 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
1847 
    translateToNative(ans, &cbuff, t, 1);
82476 kalibera 1848 
    return copyAndFreeStringBuffer(&cbuff);
76974 ripley 1849 
}
1850 
 
82495 kalibera 1851 
/* Variant which returns NULL (with a warning) when conversion fails,
1852 
   used for file paths. */
76994 ripley 1853 
attribute_hidden
1854 
const char *translateCharFP2(SEXP x)
1855 
{
82476 kalibera 1856 
    CHECK_CHARSXP(x);
76994 ripley 1857 
    nttype_t t = needsTranslation(x);
1858 
    const char *ans = CHAR(x);
1859 
    if (t == NT_NONE) return ans;
1860 
 
1861 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
82476 kalibera 1862 
    if (translateToNative(ans, &cbuff, t, 2)) {
1863 
	R_FreeStringBuffer(&cbuff);
1864 
	return NULL;
1865 
    } else
1866 
	return copyAndFreeStringBuffer(&cbuff);
76994 ripley 1867 
}
1868 
 
63223 ripley 1869 
SEXP installTrChar(SEXP x)
1870 
{
82476 kalibera 1871 
    CHECK_CHARSXP(x);
66479 luke 1872 
    nttype_t t = needsTranslation(x);
74162 kalibera 1873 
    if (t == NT_NONE) return installNoTrChar(x);
63223 ripley 1874 
 
66479 luke 1875 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
76980 ripley 1876 
    // For back-compatibility this allows installing
76981 ripley 1877 
    // symbols with escapes, with a warning.
1878 
    translateToNative(CHAR(x), &cbuff, t, 2);
63223 ripley 1879 
 
1880 
    SEXP Sans = install(cbuff.data);
1881 
    R_FreeStringBuffer(&cbuff);
1882 
    return Sans;
1883 
}
1884 
 
76984 ripley 1885 
/* Translates as from R 3.6.0.
77234 ripley 1886 
   As from R 4.0.0 unused in newly installed code as installChar is
76984 ripley 1887 
   remapped to Rf_installTrChar.
1888 
 */
1889 
SEXP Rf_installChar(SEXP x)
74162 kalibera 1890 
{
76984 ripley 1891 
    return Rf_installTrChar(x);
74162 kalibera 1892 
}
1893 
 
63181 ripley 1894 
/* This may return a R_alloc-ed result, so the caller has to manage the
76974 ripley 1895 
   R_alloc stack.
1896 
 
1897 
   Use for writeLines/Bin/Char, the first only with useBytes = TRUE.
1898 
*/
86648 luke 1899 
attribute_hidden const char *translateChar0(SEXP x)
54747 ripley 1900 
{
82476 kalibera 1901 
    CHECK_CHARSXP(x);
54747 ripley 1902 
    if(IS_BYTES(x)) return CHAR(x);
1903 
    return translateChar(x);
1904 
}
1905 
 
82476 kalibera 1906 
/* Decides whether translation to UTF-8 is needed. */
1907 
static R_INLINE nttype_t needsTranslationUTF8(SEXP x)
44054 ripley 1908 
{
82476 kalibera 1909 
    if (IS_UTF8(x) || IS_ASCII(x) || x == NA_STRING) return NT_NONE;
1910 
    if (IS_BYTES(x))
1911 
	error(_("translating strings with \"bytes\" encoding is not allowed"));
1912 
    if (IS_LATIN1(x) || latin1locale) return NT_FROM_LATIN1;
1913 
    if (utf8locale) return NT_NONE;
1914 
    return NT_FROM_NATIVE;
1915 
}
1916 
 
1917 
/* Translates string in "ans" to UTF-8 returning it in string
1918 
   buffer "cbuff". */
1919 
static int translateToUTF8(const char *ans, R_StringBuffer *cbuff,
1920 
			     nttype_t ttype, int mustWork)
1921 
{
1922 
    if (ttype == NT_NONE)
1923 
	error(_("internal error: no translation needed"));
1924 
 
44054 ripley 1925 
    void *obj;
82476 kalibera 1926 
    const char *inbuf, *from = "";
1927 
    char *outbuf;
44054 ripley 1928 
    size_t inb, outb, res;
87891 ripley 1929 
    bool failed = false;
44054 ripley 1930 
 
82476 kalibera 1931 
    if (ttype == NT_FROM_LATIN1)
73786 kalibera 1932 
#ifdef HAVE_ICONV_CP1252
1933 
	from = "CP1252";
1934 
#else
1935 
	from = "latin1";
1936 
#endif
82476 kalibera 1937 
    /* else (ttype == NT_FROM_NATIVE) */
73786 kalibera 1938 
    obj = Riconv_open("UTF-8", from);
70047 ripley 1939 
    if(obj == (void *)(-1))
45703 ripley 1940 
#ifdef Win32
54753 ripley 1941 
	error(_("unsupported conversion from '%s' in codepage %d"),
73786 kalibera 1942 
	      from, localeCP);
45703 ripley 1943 
#else
73132 kalibera 1944 
	error(_("unsupported conversion from '%s' to '%s'"),
73786 kalibera 1945 
	      from, "UTF-8");
45703 ripley 1946 
#endif
82476 kalibera 1947 
    R_AllocStringBuffer(0, cbuff);
44054 ripley 1948 
top_of_loop:
1949 
    inbuf = ans; inb = strlen(inbuf);
82476 kalibera 1950 
    outbuf = cbuff->data; outb = cbuff->bufsize - 1;
44054 ripley 1951 
    /* First initialize output */
1952 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
1953 
next_char:
1954 
    /* Then convert input  */
1955 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
1956 
    if(res == -1 && errno == E2BIG) {
82476 kalibera 1957 
	R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
44054 ripley 1958 
	goto top_of_loop;
51812 ripley 1959 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
85476 kalibera 1960 
	res = Riconv(obj, NULL, NULL, &outbuf, &outb);
1961 
	if((res == -1 && errno == E2BIG) || outb < 5) {
82476 kalibera 1962 
	    R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
44054 ripley 1963 
	    goto top_of_loop;
1964 
	}
87891 ripley 1965 
	failed = true;
44054 ripley 1966 
	snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
1967 
	outbuf += 4; outb -= 4;
1968 
	inbuf++; inb--;
1969 
	goto next_char;
1970 
    }
1971 
    *outbuf = '\0';
1972 
    Riconv_close(obj);
82476 kalibera 1973 
    if (mustWork && failed) {
82477 kalibera 1974 
	const void *vmax = vmaxget();
1975 
	const char *native_buf = reEnc(cbuff->data, CE_UTF8, CE_NATIVE, 2);
82494 kalibera 1976 
 
82528 kalibera 1977 
	/* copy to truncate */
82494 kalibera 1978 
	char err_buff[256];
1979 
	if (strlen(native_buf) > 255) {
1980 
	    strncpy(err_buff, native_buf, 252);
1981 
	    err_buff[252] = '\0';
1982 
	    mbcsTruncateToValid(err_buff);
1983 
	    strcat(err_buff, "...");
1984 
	} else
1985 
	    strcpy(err_buff, native_buf);
1986 
 
82476 kalibera 1987 
	if (mustWork == 2) {
1988 
	    warning(_("unable to translate '%s' to UTF-8"),
82494 kalibera 1989 
		    err_buff);
82528 kalibera 1990 
	    vmaxset(vmax);
82476 kalibera 1991 
	    return 1;
1992 
	} else {
1993 
	    R_FreeStringBuffer(cbuff);
1994 
	    error(_("unable to translate '%s' to UTF-8"), err_buff);
1995 
	}
82477 kalibera 1996 
	vmaxset(vmax);
82476 kalibera 1997 
    }
1998 
    return 0;
44054 ripley 1999 
}
2000 
 
82476 kalibera 2001 
/* This may return a R_alloc-ed result, so the caller has to manage the
2002 
   R_alloc stack */
2003 
const char *translateCharUTF8(SEXP x)
2004 
{
2005 
    CHECK_CHARSXP(x);
2006 
    nttype_t t = needsTranslationUTF8(x);
2007 
    const char *ans = CHAR(x);
2008 
    if (t == NT_NONE) return ans;
2009 
 
2010 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2011 
    translateToUTF8(ans, &cbuff, t, 0);
2012 
    return copyAndFreeStringBuffer(&cbuff);
2013 
}
2014 
 
82495 kalibera 2015 
/* Variant which does not return escaped string (which must work, throwing
2016 
   error when conversion fails). */
76986 ripley 2017 
attribute_hidden
76974 ripley 2018 
const char *trCharUTF8(SEXP x)
2019 
{
82476 kalibera 2020 
    CHECK_CHARSXP(x);
2021 
    nttype_t t = needsTranslationUTF8(x);
2022 
    const char *ans = CHAR(x);
2023 
    if (t == NT_NONE) return ans;
2024 
 
76974 ripley 2025 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
82476 kalibera 2026 
    translateToUTF8(ans, &cbuff, t, 1);
2027 
    return copyAndFreeStringBuffer(&cbuff);
2028 
}
49631 ripley 2029 
 
82495 kalibera 2030 
/* Variant which returns NULL (with a warning) when conversion fails. */
2031 
attribute_hidden
2032 
const char *trCharUTF82(SEXP x)
2033 
{
2034 
    CHECK_CHARSXP(x);
2035 
    nttype_t t = needsTranslationUTF8(x);
2036 
    const char *ans = CHAR(x);
2037 
    if (t == NT_NONE) return ans;
2038 
 
2039 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2040 
    if (translateToUTF8(ans, &cbuff, t, 2)) {
2041 
	R_FreeStringBuffer(&cbuff);
2042 
	return NULL;
2043 
    }  else
2044 
	return copyAndFreeStringBuffer(&cbuff);
2045 
}
2046 
 
82476 kalibera 2047 
/* Decides type of translation needed to get wchar_t*. */
2048 
static R_INLINE nttype_t wneedsTranslation(SEXP x)
2049 
{
2050 
    if (IS_BYTES(x))
76974 ripley 2051 
	error(_("translating strings with \"bytes\" encoding is not allowed"));
82582 kalibera 2052 
    if (IS_ASCII(x)) return NT_FROM_ASCII;
82476 kalibera 2053 
    if (IS_UTF8(x)) return NT_FROM_UTF8;
2054 
    if (IS_LATIN1(x) || latin1locale) return NT_FROM_LATIN1;
2055 
    if (utf8locale) return NT_FROM_UTF8;
2056 
    return NT_FROM_NATIVE;
76974 ripley 2057 
}
2058 
 
82528 kalibera 2059 
static const wchar_t *wcopyAndFreeStringBuffer(R_StringBuffer *cbuff)
2060 
{
2061 
    size_t res = wcslen((wchar_t *) cbuff->data) + 1;
2062 
    wchar_t *p = (wchar_t *) R_alloc(res, sizeof(wchar_t));
2063 
    memcpy(p, cbuff->data, res * sizeof(wchar_t));
2064 
    R_FreeStringBuffer(cbuff);
2065 
    return p;
2066 
}
2067 
 
82582 kalibera 2068 
static const wchar_t *wfromASCII(const char *src, size_t len)
2069 
{
2070 
    size_t i;
2071 
    wchar_t *p = (wchar_t *) R_alloc(len + 1, sizeof(wchar_t));
2072 
    for (i = 0; i < len; i++)
2073 
	p[i] = (wchar_t) src[i];
2074 
    p[i] = L'\0';
2075 
    return p;
2076 
}
2077 
 
76974 ripley 2078 
#ifdef Win32
82528 kalibera 2079 
static const char TO_WCHAR[] = "UTF-16LE";
49631 ripley 2080 
#else
2081 
# ifdef WORDS_BIGENDIAN
2082 
static const char TO_WCHAR[] = "UCS-4BE";
2083 
# else
2084 
static const char TO_WCHAR[] = "UCS-4LE";
2085 
# endif
2086 
#endif
2087 
 
43997 ripley 2088 
static void *latin1_wobj = NULL, *utf8_wobj=NULL;
2089 
 
82528 kalibera 2090 
/* Translate from current encoding to wchar_t = UTF-16LE/UCS-4
50302 ripley 2091 
   NB: that wchar_t is UCS-4 is an assumption, but not easy to avoid.
2092 
*/
49631 ripley 2093 
 
63181 ripley 2094 
/* This may return a R_alloc-ed result, so the caller has to manage the
2095 
   R_alloc stack */
82528 kalibera 2096 
static int translateToWchar(const char *ans, R_StringBuffer *cbuff,
2097 
                            nttype_t ttype, int mustWork)
43997 ripley 2098 
{
2099 
    void * obj;
82476 kalibera 2100 
    const char *inbuf, *from;
43997 ripley 2101 
    char *outbuf;
82528 kalibera 2102 
    size_t inb, outb, res;
87891 ripley 2103 
    bool failed = false;
43997 ripley 2104 
 
82528 kalibera 2105 
    if(ttype == NT_FROM_LATIN1) {
43997 ripley 2106 
	if(!latin1_wobj) {
73786 kalibera 2107 
#ifdef HAVE_ICONV_CP1252
2108 
	    from = "CP1252";
2109 
#else
2110 
	    from = "latin1";
2111 
#endif
2112 
	    obj = Riconv_open(TO_WCHAR, from);
45703 ripley 2113 
	    if(obj == (void *)(-1))
46133 ripley 2114 
		error(_("unsupported conversion from '%s' to '%s'"),
73786 kalibera 2115 
		      from, TO_WCHAR);
43997 ripley 2116 
	    latin1_wobj = obj;
2117 
	} else
2118 
	    obj = latin1_wobj;
82528 kalibera 2119 
    } else if(ttype == NT_FROM_UTF8) {
44161 ripley 2120 
	if(!utf8_wobj) {
49631 ripley 2121 
	    obj = Riconv_open(TO_WCHAR, "UTF-8");
70047 ripley 2122 
	    if(obj == (void *)(-1))
46133 ripley 2123 
		error(_("unsupported conversion from '%s' to '%s'"),
73132 kalibera 2124 
		      "UTF-8", TO_WCHAR);
43997 ripley 2125 
	    utf8_wobj = obj;
2126 
	} else
2127 
	    obj = utf8_wobj;
82476 kalibera 2128 
    } else { /* t == NT_FROM_NATIVE */
49631 ripley 2129 
	obj = Riconv_open(TO_WCHAR, "");
45703 ripley 2130 
	if(obj == (void *)(-1))
49631 ripley 2131 
#ifdef Win32
54753 ripley 2132 
	    error(_("unsupported conversion to '%s' from codepage %d"),
49631 ripley 2133 
		  TO_WCHAR, localeCP);
2134 
#else
2135 
	    error(_("unsupported conversion from '%s' to '%s'"), "", TO_WCHAR);
2136 
#endif
43997 ripley 2137 
    }
2138 
 
81103 kalibera 2139 
    /* R_AllocStringBuffer returns correctly aligned for wchar_t */
82528 kalibera 2140 
    R_AllocStringBuffer(0, cbuff);
43997 ripley 2141 
top_of_loop:
2142 
    inbuf = ans; inb = strlen(inbuf);
82528 kalibera 2143 
    outbuf = cbuff->data; outb = cbuff->bufsize - 1;
43997 ripley 2144 
    /* First initialize output */
2145 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
49635 ripley 2146 
next_char:
2147 
    /* Then convert input  */
43997 ripley 2148 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
2149 
    if(res == -1 && errno == E2BIG) {
82528 kalibera 2150 
	R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
43997 ripley 2151 
	goto top_of_loop;
51812 ripley 2152 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
85476 kalibera 2153 
	res = Riconv(obj, NULL, NULL, &outbuf, &outb);
2154 
	if((res == -1 && errno == E2BIG) || outb < 5 * sizeof(wchar_t)) {
82528 kalibera 2155 
	    R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
49635 ripley 2156 
	    goto top_of_loop;
2157 
	}
87891 ripley 2158 
	failed = true;
81103 kalibera 2159 
	swprintf((wchar_t*)outbuf, 5, L"<%02x>", (unsigned char)*inbuf);
2160 
	outbuf += 4 * sizeof(wchar_t); outb -= 4 * sizeof(wchar_t);
49635 ripley 2161 
	inbuf++; inb--;
2162 
	goto next_char;
43997 ripley 2163 
    }
82528 kalibera 2164 
    *((wchar_t *) outbuf) = L'\0'; /* terminate wide string */
2165 
    if(ttype == NT_FROM_NATIVE) Riconv_close(obj);
2166 
    if (mustWork && failed) {
2167 
	const void *vmax = vmaxget();
83126 kalibera 2168 
	const char *native_buf = reEnc3(cbuff->data, TO_WCHAR, "", 2);
82528 kalibera 2169 
 
2170 
	/* copy to truncate (and mark as truncated) */
2171 
	char err_buff[256];
2172 
	if (strlen(native_buf) > 255) {
2173 
	    strncpy(err_buff, native_buf, 252);
2174 
	    err_buff[252] = '\0';
2175 
	    mbcsTruncateToValid(err_buff);
2176 
	    strcat(err_buff, "...");
2177 
	} else
2178 
	    strcpy(err_buff, native_buf);
2179 
 
2180 
	if (mustWork == 2) {
2181 
	    warning(_("unable to translate '%s' to a wide string"),
2182 
	              err_buff);
2183 
	    vmaxset(vmax);
2184 
	    return 1;
2185 
	} else {
2186 
	    R_FreeStringBuffer(cbuff);
2187 
	    error(_("unable to translate '%s' to a wide string"),
2188 
	          err_buff);
2189 
	}
2190 
	vmaxset(vmax);
2191 
    }
2192 
    return 0;
43997 ripley 2193 
}
2194 
 
82528 kalibera 2195 
/* This may return a R_alloc-ed result, so the caller has to manage the
2196 
   R_alloc stack */
2197 
const wchar_t *wtransChar(SEXP x)
2198 
{
2199 
    CHECK_CHARSXP(x);
2200 
    nttype_t t = wneedsTranslation(x);
82582 kalibera 2201 
    if (t == NT_FROM_ASCII)
2202 
	return wfromASCII(CHAR(x), LENGTH(x));
82528 kalibera 2203 
 
2204 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2205 
    translateToWchar(CHAR(x), &cbuff, t, 0);
2206 
    return wcopyAndFreeStringBuffer(&cbuff);
2207 
}
2208 
 
2209 
/* Variant which returns NULL (with a warning) when conversion fails. */
86647 luke 2210 
attribute_hidden /* would need to be in an installed header if not hidden */
82528 kalibera 2211 
const wchar_t *wtransChar2(SEXP x)
2212 
{
2213 
    CHECK_CHARSXP(x);
2214 
    nttype_t t = wneedsTranslation(x);
82582 kalibera 2215 
    if (t == NT_FROM_ASCII)
2216 
	return wfromASCII(CHAR(x), LENGTH(x));
82528 kalibera 2217 
 
2218 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2219 
    if (translateToWchar(CHAR(x), &cbuff, t, 2)) {
2220 
	R_FreeStringBuffer(&cbuff);
2221 
	return NULL;
2222 
    } else
2223 
	return wcopyAndFreeStringBuffer(&cbuff);
2224 
}
2225 
 
82477 kalibera 2226 
static int reEncodeIconv(const char *x, R_StringBuffer *cbuff,
2227 
                         const char *fromcode, const char *tocode, int subst)
43932 ripley 2228 
{
2229 
    void * obj;
2230 
    const char *inbuf;
82477 kalibera 2231 
    char *outbuf;
2232 
    size_t inb, outb, res;
87891 ripley 2233 
    bool fromWchar = !strcmp(fromcode, TO_WCHAR);
43932 ripley 2234 
 
2235 
    obj = Riconv_open(tocode, fromcode);
82477 kalibera 2236 
    if(obj == (void *)(-1)) return 1;
2237 
    R_AllocStringBuffer(0, cbuff);
43932 ripley 2238 
top_of_loop:
83126 kalibera 2239 
    inbuf = x;
2240 
    if (fromWchar)
2241 
	inb = wcslen((wchar_t *)inbuf) * sizeof(wchar_t);
2242 
    else
2243 
	inb = strlen(inbuf);
82477 kalibera 2244 
    outbuf = cbuff->data; outb = cbuff->bufsize - 3;
43932 ripley 2245 
    /* First initialize output */
2246 
    Riconv (obj, NULL, NULL, &outbuf, &outb);
2247 
next_char:
2248 
    /* Then convert input  */
2249 
    res = Riconv(obj, &inbuf , &inb, &outbuf, &outb);
2250 
    if(res == -1 && errno == E2BIG) {
82477 kalibera 2251 
	R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
43932 ripley 2252 
	goto top_of_loop;
51812 ripley 2253 
    } else if(res == -1 && (errno == EILSEQ || errno == EINVAL)) {
85476 kalibera 2254 
	res = Riconv(obj, NULL, NULL, &outbuf, &outb);
2255 
	if(res == -1 && errno == E2BIG) {
2256 
	    R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
2257 
	    goto top_of_loop;
2258 
	}
83126 kalibera 2259 
	size_t inb_per_char = fromWchar ? sizeof(wchar_t) : 1;
2260 
 
2261 
	/* ensure space in cbuff for substitution */
2262 
	size_t need = 0;
43932 ripley 2263 
	switch(subst) {
2264 
	case 1: /* substitute hex */
83126 kalibera 2265 
	    need = inb_per_char * 4 + 1;
43932 ripley 2266 
	    break;
2267 
	case 2: /* substitute . */
46843 ripley 2268 
	case 3: /* substitute ? */
83126 kalibera 2269 
	    need = inb_per_char;
46843 ripley 2270 
	    break;
43932 ripley 2271 
	default: /* skip byte */
83126 kalibera 2272 
	    inbuf += inb_per_char;
2273 
	    inb -= inb_per_char;
45446 ripley 2274 
	    goto next_char;
43932 ripley 2275 
	}
83126 kalibera 2276 
	if(outb < need) {
2277 
	    R_AllocStringBuffer(2*cbuff->bufsize, cbuff);
2278 
	    goto top_of_loop;
2279 
	}
2280 
 
2281 
	/* substitute individual bytes, it makes more sense for users as
2282 
	   typically errors would be due to conversion from a single-byte
2283 
	   encoding */
2284 
	for(int i = 0; i < inb_per_char; i++) {
2285 
	    if (!inb) break;
2286 
	    switch(subst) {
2287 
	    case 1: /* substitute hex */
2288 
		snprintf(outbuf, 5, "<%02x>", (unsigned char)*inbuf);
2289 
		outbuf += 4; outb -= 4;
2290 
		inbuf++; inb--;
2291 
		break;
2292 
	    case 2: /* substitute . */
2293 
		*outbuf++ = '.'; inbuf++; outb--; inb--;
2294 
		break;
2295 
	    case 3: /* substitute ? */
2296 
		*outbuf++ = '?'; inbuf++; outb--; inb--;
2297 
		break;
2298 
	    }
2299 
	}
2300 
	goto next_char;
43932 ripley 2301 
    }
2302 
    Riconv_close(obj);
2303 
    *outbuf = '\0';
82477 kalibera 2304 
    return 0;
43932 ripley 2305 
}
43953 ripley 2306 
 
82477 kalibera 2307 
#include <R_ext/GraphicsEngine.h>
2308 
 
2309 
/* returns 1 when no conversion is needed and in case of error, 0 otherwise */
2310 
static int reEncode(const char *x, R_StringBuffer *cbuff,
2311 
                    cetype_t ce_in, cetype_t ce_out, int subst)
63218 ripley 2312 
{
2313 
    char *tocode = NULL, *fromcode = NULL;
2314 
 
82477 kalibera 2315 
    /* We can only encode from Symbol to UTF-8 */
2316 
    if(ce_in == ce_out || ce_out == CE_SYMBOL ||
2317 
       ce_in == CE_ANY || ce_out == CE_ANY) return 1;
2318 
    if(ce_in == CE_SYMBOL) {
2319 
	if(ce_out == CE_UTF8) {
2320 
	    size_t nc = 3*strlen(x)+1; /* all in BMP */
2321 
	    R_AllocStringBuffer(nc, cbuff);
2322 
	    Rf_AdobeSymbol2utf8(cbuff->data, x, cbuff->bufsize, TRUE);
2323 
	    return 0;
2324 
	} else return 1;
2325 
    }
63218 ripley 2326 
 
82477 kalibera 2327 
    if(strIsASCII(x)) return 1;
2328 
    if(utf8locale && ce_in == CE_NATIVE && ce_out == CE_UTF8) return 1;
2329 
    if(utf8locale && ce_out == CE_NATIVE && ce_in == CE_UTF8) return 1;
2330 
    if(latin1locale && ce_in == CE_NATIVE && ce_out == CE_LATIN1) return 1;
2331 
    if(latin1locale && ce_out == CE_NATIVE && ce_in == CE_LATIN1) return 1;
63218 ripley 2332 
 
2333 
    switch(ce_in) {
81573 kalibera 2334 
    case CE_NATIVE: fromcode = ""; break;
82477 kalibera 2335 
#ifdef HAVE_ICONV_CP1252
63218 ripley 2336 
    case CE_LATIN1: fromcode = "CP1252"; break;
82477 kalibera 2337 
#else
2338 
    case CE_LATIN1: fromcode = "latin1"; break;
2339 
#endif
63218 ripley 2340 
    case CE_UTF8:   fromcode = "UTF-8"; break;
82477 kalibera 2341 
    default: return 1;
63218 ripley 2342 
    }
2343 
 
2344 
    switch(ce_out) {
81573 kalibera 2345 
    case CE_NATIVE: tocode = ""; break;
82477 kalibera 2346 
    case CE_LATIN1: tocode = "latin1"; break; /* ?? CP1252 */
63218 ripley 2347 
    case CE_UTF8:   tocode = "UTF-8"; break;
82477 kalibera 2348 
    default: return 1;
63218 ripley 2349 
    }
2350 
 
82477 kalibera 2351 
    return reEncodeIconv(x, cbuff, fromcode, tocode, subst);
2352 
}
2353 
 
2354 
/* This may return a R_alloc-ed result, so the caller has to manage the
2355 
   R_alloc stack */
2356 
const char *reEnc(const char *x, cetype_t ce_in, cetype_t ce_out, int subst)
2357 
{
2358 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2359 
    if (reEncode(x, &cbuff, ce_in, ce_out, subst)) return x;
82803 ripley 2360 
    size_t res = strlen(cbuff.data) + 1;
2361 
    char *p = R_alloc(res, 1);
82477 kalibera 2362 
    memcpy(p, cbuff.data, res);
2363 
    R_FreeStringBuffer(&cbuff);
2364 
    return p;
2365 
}
2366 
 
2367 
#ifdef Win32
2368 
/* A version avoiding R_alloc for use in the Rgui editor */
2369 
void reEnc2(const char *x, char *y, int ny,
2370 
	    cetype_t ce_in, cetype_t ce_out, int subst)
2371 
{
2372 
    int res;
2373 
 
2374 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2375 
    if (reEncode(x, &cbuff, ce_in, ce_out, subst)) {
2376 
	strncpy(y, x, ny);
2377 
	y[ny - 1] = '\0';
2378 
	return;
63218 ripley 2379 
    }
82477 kalibera 2380 
    res = strlen(cbuff.data) + 1;
63218 ripley 2381 
    if (res > ny) error("converted string too long for buffer");
63219 ripley 2382 
    memcpy(y, cbuff.data, res);
63218 ripley 2383 
    R_FreeStringBuffer(&cbuff);
2384 
}
2385 
#endif
2386 
 
82477 kalibera 2387 
/* A version that works with arbitrary iconv encodings, used for getting
2388 
   escaped invalid characters for error messages. */
86648 luke 2389 
attribute_hidden
82477 kalibera 2390 
const char *reEnc3(const char *x,
2391 
                   const char *fromcode, const char *tocode, int subst)
2392 
{
2393 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
2394 
    if (reEncodeIconv(x, &cbuff, fromcode, tocode, subst)) return x;
82803 ripley 2395 
    size_t res = strlen(cbuff.data) + 1;
2396 
    char *p = R_alloc(res, 1);
82477 kalibera 2397 
    memcpy(p, cbuff.data, res);
2398 
    R_FreeStringBuffer(&cbuff);
2399 
    return p;
2400 
}
2401 
 
83446 ripley 2402 
attribute_hidden void
44161 ripley 2403 
invalidate_cached_recodings(void)
2404 
{
73116 kalibera 2405 
    if (latin1_obj) {
2406 
	Riconv_close(latin1_obj);
2407 
	latin1_obj = NULL;
2408 
    }
2409 
    if (utf8_obj) {
2410 
	Riconv_close(utf8_obj);
2411 
	utf8_obj = NULL;
2412 
    }
2413 
    if (ucsmb_obj) {
2414 
	Riconv_close(ucsmb_obj);
2415 
	ucsmb_obj = NULL;
2416 
    }
44161 ripley 2417 
#ifdef Win32
73116 kalibera 2418 
    if (latin1_wobj) {
2419 
	Riconv_close(latin1_wobj);
2420 
	latin1_wobj = NULL;
2421 
    }
2422 
    if (utf8_wobj) {
2423 
	Riconv_close(utf8_wobj);
2424 
	utf8_wobj = NULL;
2425 
    }
45446 ripley 2426 
#endif
44161 ripley 2427 
}
2428 
 
2429 
 
64516 ripley 2430 
/* in C11 these could use char32_t */
43953 ripley 2431 
#ifdef WORDS_BIGENDIAN
2432 
static const char UNICODE[] = "UCS-4BE";
32492 ripley 2433 
#else
43953 ripley 2434 
static const char UNICODE[] = "UCS-4LE";
2435 
#endif
2436 
 
44034 ripley 2437 
/* used in gram.c and devX11.c */
44014 ripley 2438 
size_t ucstomb(char *s, const unsigned int wc)
43953 ripley 2439 
{
80402 kalibera 2440 
    char     buf[R_MB_CUR_MAX+1];
43953 ripley 2441 
    void    *cd = NULL ;
2442 
    unsigned int  wcs[2];
2443 
    const char *inbuf = (const char *) wcs;
2444 
    size_t   inbytesleft = sizeof(unsigned int); /* better be 4 */
2445 
    char    *outbuf = buf;
2446 
    size_t   outbytesleft = sizeof(buf);
2447 
    size_t   status;
45446 ripley 2448 
 
43953 ripley 2449 
    if(wc == 0) {*s = '\0'; return 1;}
45446 ripley 2450 
 
43953 ripley 2451 
    memset(buf, 0, sizeof(buf));
2452 
    memset(wcs, 0, sizeof(wcs));
2453 
    wcs[0] = wc;
2454 
 
2455 
    if(ucsmb_obj == NULL) {
2456 
	if((void *)(-1) == (cd = Riconv_open("", UNICODE))) {
2457 
#ifndef  Win32
2458 
	    char tocode[128];
2459 
	    /* locale set fuzzy case */
74969 ripley 2460 
	    strncpy(tocode, locale2charset(NULL), sizeof(tocode) - 1);
70047 ripley 2461 
	    tocode[sizeof(tocode) - 1] = '\0';
43953 ripley 2462 
	    if((void *)(-1) == (cd = Riconv_open(tocode, UNICODE)))
45446 ripley 2463 
		return (size_t)(-1);
43953 ripley 2464 
#else
2465 
	    return (size_t)(-1);
2466 
#endif
2467 
	}
2468 
	ucsmb_obj = cd;
2469 
    }
45446 ripley 2470 
 
43953 ripley 2471 
    status = Riconv(ucsmb_obj, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
2472 
 
2473 
    if (status == (size_t) -1) {
45446 ripley 2474 
	switch(errno){
2475 
	case EINVAL:
2476 
	    return (size_t) -2;
2477 
	case EILSEQ:
2478 
	    return (size_t) -1;
2479 
	case E2BIG:
2480 
	    break;
2481 
	default:
2482 
	    errno = EILSEQ;
2483 
	    return (size_t) -1;
2484 
	}
43953 ripley 2485 
    }
80402 kalibera 2486 
    buf[R_MB_CUR_MAX] = '\0'; /* safety measure */
44170 ripley 2487 
    strcpy(s, buf);
43953 ripley 2488 
    return strlen(buf);
2489 
}
2490 
 
79679 ripley 2491 
/* used in engine.c for non-UTF-8 MBCS */
87901 ripley 2492 
attribute_hidden size_t
43953 ripley 2493 
mbtoucs(unsigned int *wc, const char *s, size_t n)
2494 
{
2495 
    unsigned int  wcs[2];
2496 
    char     buf[16];
2497 
    void    *cd;
2498 
    const char *inbuf = s;
2499 
    size_t   inbytesleft = strlen(s);
2500 
    char    *outbuf = (char *) wcs;
2501 
    size_t   outbytesleft = sizeof(buf);
2502 
    size_t   status;
45446 ripley 2503 
 
43953 ripley 2504 
    if(s[0] == 0) {*wc = 0; return 1;}
45446 ripley 2505 
 
43978 ripley 2506 
    if((void *)(-1) == (cd = Riconv_open(UNICODE, ""))) return (size_t)(-1);
43953 ripley 2507 
    status = Riconv(cd, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
2508 
 
43980 ripley 2509 
    if (status == (size_t) -1) {
45446 ripley 2510 
	switch(errno){
2511 
	case EINVAL:
72952 murdoch 2512 
	    Riconv_close(cd);
45446 ripley 2513 
	    return (size_t) -2;
2514 
	case EILSEQ:
72952 murdoch 2515 
	    Riconv_close(cd);
45446 ripley 2516 
	    return (size_t) -1;
2517 
	case E2BIG:
2518 
	    break;
2519 
	default:
72952 murdoch 2520 
	    Riconv_close(cd);
45446 ripley 2521 
	    errno = EILSEQ;
2522 
	    return (size_t) -1;
2523 
	}
43980 ripley 2524 
    }
46133 ripley 2525 
    Riconv_close(cd);
43953 ripley 2526 
    *wc = wcs[0];
2527 
    return (size_t) 1;
2528 
}
2529 
 
44329 ripley 2530 
/* made available for use in graphics devices */
2531 
size_t ucstoutf8(char *s, const unsigned int wc)
43953 ripley 2532 
{
2533 
    char     buf[16];
2534 
    void    *cd = NULL ;
2535 
    unsigned int  wcs[2];
2536 
    const char *inbuf = (const char *) wcs;
2537 
    size_t   inbytesleft = sizeof(unsigned int); /* better be 4 */
2538 
    char    *outbuf = buf;
2539 
    size_t   outbytesleft = sizeof(buf);
2540 
    size_t   status;
45446 ripley 2541 
 
43953 ripley 2542 
    if(wc == 0) {*s = '\0'; return 1;}
45446 ripley 2543 
 
43953 ripley 2544 
    memset(buf, 0, sizeof(buf));
2545 
    wcs[0] = wc; wcs[1] = 0;
2546 
 
46133 ripley 2547 
    if(ucsutf8_obj == NULL) {
2548 
	if((void *)(-1) == (cd = Riconv_open("UTF-8", UNICODE))) {
2549 
	    error(_("unsupported conversion from '%s' to '%s'"),
2550 
		  UNICODE, "UTF-8");
2551 
	    return (size_t)(-1);
2552 
	}
2553 
	ucsutf8_obj = cd;
2554 
    }
70047 ripley 2555 
 
46133 ripley 2556 
    status = Riconv(ucsutf8_obj, &inbuf, &inbytesleft, &outbuf, &outbytesleft);
43953 ripley 2557 
 
2558 
    if (status == (size_t) -1) {
45446 ripley 2559 
	switch(errno){
2560 
	case E2BIG:
2561 
	    break;
2562 
	default:
64471 ripley 2563 
	    error(_("invalid Unicode point %u"), wc);
2564 
	    return (size_t) -1; // Not reached
45446 ripley 2565 
	}
43953 ripley 2566 
    }
44325 ripley 2567 
    *outbuf = '\0';
2568 
    strcpy(s, buf);
43953 ripley 2569 
    return strlen(buf);
2570 
}
2571 
 
36601 ripley 2572 
/* moved from src/unix/sys-unix.c and src/gnuwin32/extra.c */
2573 
 
2574 
#ifdef HAVE_STAT
2575 
# ifdef HAVE_ACCESS
2576 
#  ifdef HAVE_UNISTD_H
2577 
#   include <unistd.h>
2578 
#  endif
2579 
# endif
2580 
 
41344 ripley 2581 
#ifdef Win32
2582 
# define WIN32_LEAN_AND_MEAN 1
2583 
# include <windows.h> /* For GetShortPathName */
2584 
#endif
2585 
 
36622 ripley 2586 
#if !defined(S_IFDIR) && defined(__S_IFDIR)
2587 
# define S_IFDIR __S_IFDIR
2588 
#endif
2589 
 
87901 ripley 2590 
attribute_hidden int R_isWriteableDir(char *path)
36601 ripley 2591 
{
54797 ripley 2592 
#ifdef Win32
2593 
    struct _stati64 sb;
2594 
#else
36601 ripley 2595 
    struct stat sb;
54797 ripley 2596 
#endif
36601 ripley 2597 
    int isdir = 0;
2598 
    if(!path) return 0;
54797 ripley 2599 
#ifdef Win32
2600 
    if(_stati64(path, &sb) == 0) {
2601 
#else
36601 ripley 2602 
    if(stat(path, &sb) == 0) {
54797 ripley 2603 
#endif
36601 ripley 2604 
	isdir = (sb.st_mode & S_IFDIR) > 0; /* is a directory */
2605 
#ifdef HAVE_ACCESS
2606 
	/* We want to know if the directory is writable by this user,
2607 
	   which mode does not tell us */
2608 
	isdir &= (access(path, W_OK) == 0);
2609 
#endif
2610 
    }
2611 
    return isdir;
2612 
}
2613 
#else
87901 ripley 2614 
attribute_hidden int R_isWriteableDir(char *path)
36601 ripley 2615 
{
2616 
    return 1;
2617 
}
2618 
#endif /* HAVE_STAT */
2619 
 
2620 
#if !HAVE_DECL_MKDTEMP
2621 
extern char * mkdtemp (char *template);
2622 
#endif
2623 
 
52128 ripley 2624 
#ifdef Win32
2625 
# include <ctype.h>
2626 
#endif
2627 
 
86647 luke 2628 
attribute_hidden /* would need to be in an installed header if not hidden */
72621 maechler 2629 
void R_reInitTempDir(int die_on_fail)
36601 ripley 2630 
{
83836 ripley 2631 
    char *tmp = NULL, *tm;
83821 kalibera 2632 
    size_t len;
36601 ripley 2633 
 
83821 kalibera 2634 
#define ERROR_MAYBE_DIE(MSG_) do {		\
72621 maechler 2635 
    if(die_on_fail)				\
2636 
	R_Suicide(MSG_);			\
2637 
    else					\
83821 kalibera 2638 
	errorcall(R_NilValue, MSG_);            \
2639 
} while (0)
72621 maechler 2640 
 
39181 ripley 2641 
    if(R_TempDir) return; /* someone else set it */
83821 kalibera 2642 
    /* getenv("R_SESSION_TMPDIR");   no longer set in R.sh */
2643 
 
2644 
    tm = getenv("TMPDIR");
2645 
    if (!R_isWriteableDir(tm)) {
2646 
	tm = getenv("TMP");
79342 kalibera 2647 
	if (!R_isWriteableDir(tm)) {
83821 kalibera 2648 
	    tm = getenv("TEMP");
79342 kalibera 2649 
	    if (!R_isWriteableDir(tm)) {
36601 ripley 2650 
#ifdef Win32
83821 kalibera 2651 
		tm = getenv("R_USER"); /* this one will succeed */
2652 
		if (!tm)
2653 
		    ERROR_MAYBE_DIE(_("'R_USER' not set"));
36601 ripley 2654 
#else
83821 kalibera 2655 
		tm = "/tmp";
36601 ripley 2656 
#endif
2657 
	    }
2658 
	}
83821 kalibera 2659 
    }
2660 
 
2661 
    /* make sure no spaces in path */
2662 
    int hasspace = 0;
83845 kalibera 2663 
    char *p;
83821 kalibera 2664 
    for (p = tm; *p; p++)
2665 
	if (isspace(*p)) { hasspace = 1; break; }
83847 kalibera 2666 
#ifdef Win32
2667 
    char *suffix = "\\RtmpXXXXXX";
83821 kalibera 2668 
    if (hasspace) {
2669 
	DWORD res = GetShortPathName(tm, NULL, 0);
2670 
	if (res > 0) {
83847 kalibera 2671 
	    len = res + strlen(suffix);
83821 kalibera 2672 
	    tmp = (char *)malloc(len);
2673 
	    if (!tmp)
2674 
		ERROR_MAYBE_DIE(_("cannot allocate 'R_TempDir'"));
2675 
	    DWORD res1 = GetShortPathName(tm, tmp, res);
2676 
	    if (res1 > 0 && res1 < res)
83847 kalibera 2677 
		strcat(tmp, suffix);
83821 kalibera 2678 
	    else { /* very unlikely */
2679 
		free(tmp);
2680 
		tmp = NULL;
2681 
	    }
2682 
	}
2683 
	if (tmp) {
83847 kalibera 2684 
	    /* GetShortPathName may return a long name, so check again */
80742 kalibera 2685 
	    hasspace = 0;
83821 kalibera 2686 
	    for (p = tmp; *p; p++)
80742 kalibera 2687 
		if (isspace(*p)) { hasspace = 1; break; }
36601 ripley 2688 
	}
83847 kalibera 2689 
    }
2690 
#else
2691 
    char *suffix = "/RtmpXXXXXX";
2692 
#endif
2693 
    if (hasspace) {
2694 
	if (tmp)
2695 
	    free(tmp);
2696 
	ERROR_MAYBE_DIE(_("'R_TempDir' contains space"));
2697 
    }
2698 
    if (!tmp) {
2699 
	len = strlen(tm) + strlen(suffix) + 1;
83821 kalibera 2700 
	tmp = (char *)malloc(len);
2701 
	if (!tmp)
2702 
	    ERROR_MAYBE_DIE(_("cannot allocate 'R_TempDir'"));
83847 kalibera 2703 
	strcpy(tmp, tm);
2704 
	strcat(tmp, suffix);
83821 kalibera 2705 
    }
2706 
    if(!mkdtemp(tmp)) {
2707 
	free(tmp);
2708 
	ERROR_MAYBE_DIE(_("cannot create 'R_TempDir'"));
2709 
    }
40392 ripley 2710 
#ifndef Win32
2711 
# ifdef HAVE_SETENV
83821 kalibera 2712 
    if(setenv("R_SESSION_TMPDIR", tmp, 1)) {
2713 
	free(tmp);
2714 
	errorcall(R_NilValue, _("unable to set R_SESSION_TMPDIR"));
2715 
    }
40392 ripley 2716 
# elif defined(HAVE_PUTENV)
83821 kalibera 2717 
    {
2718 
	len = strlen(tmp) + 20;
2719 
	char * buf = (char *) malloc((len) * sizeof(char));
2720 
	if(buf) {
2721 
	    snprintf(buf, len, "R_SESSION_TMPDIR=%s", tmp);
2722 
	    if(putenv(buf)) {
2723 
		free(tmp);
2724 
		free(buf);
40392 ripley 2725 
		errorcall(R_NilValue, _("unable to set R_SESSION_TMPDIR"));
83821 kalibera 2726 
	    }
2727 
	    /* no free here: storage remains in use */
2728 
	} else {
2729 
	    free(tmp);
2730 
	    errorcall(R_NilValue, _("unable to set R_SESSION_TMPDIR"));
36601 ripley 2731 
	}
83821 kalibera 2732 
    }
40392 ripley 2733 
# endif
36601 ripley 2734 
#endif
83821 kalibera 2735 
    R_TempDir = tmp;
2736 
    Sys_TempDir = tmp;
36601 ripley 2737 
}
2738 
 
83446 ripley 2739 
attribute_hidden void InitTempDir(void) {
72621 maechler 2740 
    R_reInitTempDir(/* die_on_fail = */ TRUE);
2741 
}
2742 
 
83821 kalibera 2743 
/* returns malloc'd result */
36601 ripley 2744 
char * R_tmpnam(const char * prefix, const char * tempdir)
2745 
{
54876 murdoch 2746 
    return R_tmpnam2(prefix, tempdir, "");
2747 
}
2748 
 
57745 ripley 2749 
/* NB for use with multicore: parent and all children share the same
70047 ripley 2750 
   session directory and run in parallel.
72621 maechler 2751 
   So as from 2.14.1, we make sure getpid() is part of the process.
57745 ripley 2752 
*/
83821 kalibera 2753 
/* returns malloc'd result */
57745 ripley 2754 
char * R_tmpnam2(const char *prefix, const char *tempdir, const char *fileext)
54876 murdoch 2755 
{
83849 kalibera 2756 
    unsigned int n, pid = getpid();
37091 ripley 2757 
#ifdef Win32
2758 
    char filesep[] = "\\";
2759 
#else
2760 
    char filesep[] = "/";
2761 
#endif
36601 ripley 2762 
 
2763 
    if(!prefix) prefix = "";	/* NULL */
54876 murdoch 2764 
    if(!fileext) fileext = "";  /*  "   */
70047 ripley 2765 
 
36601 ripley 2766 
    for (n = 0; n < 100; n++) {
2767 
	/* try a random number at the end.  Need at least 6 hex digits */
83850 kalibera 2768 
	int r1 = rand();
36601 ripley 2769 
#if RAND_MAX > 16777215
83850 kalibera 2770 
# define TMPNAM2_SNPRINTF(BUF, SIZE) \
2771 
	snprintf(BUF, SIZE, "%s%s%s%x%x%s", tempdir, filesep, prefix, pid, r1, fileext)
36601 ripley 2772 
#else
83850 kalibera 2773 
	int r2 = rand();
2774 
# define TMPNAM2_SNPRINTF(BUF, SIZE) \
2775 
	snprintf(BUF, SIZE, "%s%s%s%x%x%x%s", tempdir, filesep, prefix, pid, r1, r2, fileext)
36601 ripley 2776 
#endif
83850 kalibera 2777 
	size_t needed = TMPNAM2_SNPRINTF(NULL, 0) + 1;
83849 kalibera 2778 
#ifdef Unix
83883 kalibera 2779 
	if (needed > R_PATH_MAX)
83849 kalibera 2780 
	    error(_("temporary name too long"));
2781 
#endif
2782 
	char *res = (char *) malloc(needed);
2783 
	if(!res)
2784 
	    error(_("allocation failed in R_tmpnam2"));
83850 kalibera 2785 
	TMPNAM2_SNPRINTF(res, needed);
83849 kalibera 2786 
	if (!R_FileExists(res))
2787 
	    return res;
2788 
	free(res);
36601 ripley 2789 
    }
83849 kalibera 2790 
    error(_("cannot find unused tempfile name"));
36601 ripley 2791 
}
39743 duncan 2792 
 
77083 kalibera 2793 
void R_free_tmpnam(char *name)
77059 kalibera 2794 
{
2795 
    if (name) free(name);
2796 
}
2797 
 
83446 ripley 2798 
attribute_hidden SEXP do_proctime(SEXP call, SEXP op, SEXP args, SEXP env)
39948 ripley 2799 
{
44103 ripley 2800 
    SEXP ans, nm;
51258 ripley 2801 
 
2802 
    checkArity(op, args);
44103 ripley 2803 
    PROTECT(ans = allocVector(REALSXP, 5));
2804 
    PROTECT(nm = allocVector(STRSXP, 5));
39948 ripley 2805 
    R_getProcTime(REAL(ans));
40050 ripley 2806 
    SET_STRING_ELT(nm, 0, mkChar("user.self"));
2807 
    SET_STRING_ELT(nm, 1, mkChar("sys.self"));
40051 ripley 2808 
    SET_STRING_ELT(nm, 2, mkChar("elapsed"));
40050 ripley 2809 
    SET_STRING_ELT(nm, 3, mkChar("user.child"));
2810 
    SET_STRING_ELT(nm, 4, mkChar("sys.child"));
2811 
    setAttrib(ans, R_NamesSymbol, nm);
39948 ripley 2812 
    setAttrib(ans, R_ClassSymbol, mkString("proc_time"));
44103 ripley 2813 
    UNPROTECT(2);
39948 ripley 2814 
    return ans;
2815 
}
45074 ripley 2816 
 
83446 ripley 2817 
attribute_hidden void resetTimeLimits(void)
45074 ripley 2818 
{
2819 
    double data[5];
2820 
    R_getProcTime(data);
2821 
 
2822 
    elapsedLimit = (elapsedLimitValue > 0) ? data[2] + elapsedLimitValue : -1.0;
45446 ripley 2823 
    if (elapsedLimit2 > 0.0 &&
45074 ripley 2824 
	(elapsedLimit <= 0.0 || elapsedLimit2 < elapsedLimit))
2825 
	elapsedLimit = elapsedLimit2;
2826 
 
2827 
#ifdef Win32
2828 
    cpuLimit = (cpuLimitValue > 0) ? data[0] + data[1] + cpuLimitValue : -1.0;
2829 
#else
2830 
    cpuLimit = (cpuLimitValue > 0) ? data[0] + data[1] + data[3] + data[4] + cpuLimitValue : -1.0;
2831 
#endif
2832 
    if (cpuLimit2 > 0.0 && (cpuLimit <= 0.0 || cpuLimit2 < cpuLimit))
2833 
	cpuLimit = cpuLimit2;
2834 
}
2835 
 
83446 ripley 2836 
attribute_hidden SEXP
45074 ripley 2837 
do_setTimeLimit(SEXP call, SEXP op, SEXP args, SEXP rho)
2838 
{
2839 
    double cpu, elapsed, old_cpu = cpuLimitValue,
2840 
	old_elapsed = elapsedLimitValue;
2841 
    int transient;
2842 
 
2843 
    checkArity(op, args);
2844 
    cpu = asReal(CAR(args));
2845 
    elapsed = asReal(CADR(args));
2846 
    transient = asLogical(CADDR(args));
2847 
 
2848 
    if (R_FINITE(cpu) && cpu > 0) cpuLimitValue = cpu; else cpuLimitValue = -1;
2849 
 
2850 
    if (R_FINITE(elapsed) && elapsed > 0) elapsedLimitValue = elapsed;
2851 
    else elapsedLimitValue = -1;
2852 
 
2853 
    resetTimeLimits();
2854 
 
2855 
    if (transient == TRUE) {
2856 
	cpuLimitValue = old_cpu;
2857 
	elapsedLimitValue = old_elapsed;
2858 
    }
2859 
 
2860 
    return R_NilValue;
2861 
}
2862 
 
83446 ripley 2863 
attribute_hidden SEXP
45074 ripley 2864 
do_setSessionTimeLimit(SEXP call, SEXP op, SEXP args, SEXP rho)
2865 
{
2866 
    double cpu, elapsed, data[5];
2867 
 
2868 
    checkArity(op, args);
2869 
    cpu = asReal(CAR(args));
2870 
    elapsed = asReal(CADR(args));
2871 
    R_getProcTime(data);
2872 
 
45446 ripley 2873 
    if (R_FINITE(cpu) && cpu > 0)
45074 ripley 2874 
#ifdef Win32
2875 
	cpuLimit2 = cpu + data[0] + data[1];
2876 
#else
45446 ripley 2877 
	cpuLimit2 = cpu + data[0] + data[1] + data[3] + data[4];
45074 ripley 2878 
#endif
2879 
    else cpuLimit2 = -1;
2880 
 
2881 
    if (R_FINITE(elapsed) && elapsed > 0) elapsedLimit2 = elapsed + data[2];
2882 
    else elapsedLimit2 = -1;
2883 
 
2884 
    return R_NilValue;
2885 
}
49381 ripley 2886 
 
83446 ripley 2887 
attribute_hidden void R_CheckTimeLimits(void)
81306 luke 2888 
{
2889 
    if (cpuLimit > 0.0 || elapsedLimit > 0.0) {
81307 luke 2890 
 
2891 
	/* On Linux and macOS at least R_getProcTime can be quite slow;
2892 
	   currentTIme is somewhat faster. */
2893 
 
2894 
	/* To reduce overhead, skip checking TIME_CHECK_SKIP times. */
2895 
	const int TIME_CHECK_SKIP = 5;
2896 
	static int check_count = 0;
2897 
	if (check_count < TIME_CHECK_SKIP) {
2898 
	    check_count++;
2899 
	    return;
2900 
	}
2901 
	else check_count = 0;
2902 
 
2903 
	/* Before calling R_getProcTime first use checkTime to make
2904 
	   sure at least TIME_CHECK_DELTA seconds have elapsed since
2905 
	   the last call. */
2906 
	const double TIME_CHECK_DELTA = 0.05;
2907 
	static double check_time = 0;
2908 
	double tm = currentTime();
2909 
	if (tm < check_time)
2910 
	    return;
2911 
	else check_time = tm + TIME_CHECK_DELTA;
2912 
 
81306 luke 2913 
	double cpu, data[5];
2914 
	R_getProcTime(data);
2915 
#ifdef Win32
2916 
	cpu = data[0] + data[1];
2917 
#else
2918 
	cpu = data[0] + data[1] + data[3] + data[4];
2919 
#endif
2920 
	if (elapsedLimit > 0.0 && data[2] > elapsedLimit) {
2921 
	    cpuLimit = elapsedLimit = -1;
2922 
	    if (elapsedLimit2 > 0.0 && data[2] > elapsedLimit2) {
2923 
		elapsedLimit2 = -1.0;
2924 
		error(_("reached session elapsed time limit"));
2925 
	    } else
2926 
		error(_("reached elapsed time limit"));
2927 
	}
2928 
	if (cpuLimit > 0.0 && cpu > cpuLimit) {
2929 
	    cpuLimit = elapsedLimit = -1;
2930 
	    if (cpuLimit2 > 0.0 && cpu > cpuLimit2) {
2931 
		cpuLimit2 = -1.0;
2932 
		error(_("reached session CPU time limit"));
2933 
	    } else
2934 
		error(_("reached CPU time limit"));
2935 
	}
2936 
    }
2937 
}
2938 
 
49383 ripley 2939 
/* moved from character.c in 2.10.0: configure requires this */
49381 ripley 2940 
 
2941 
#ifdef HAVE_GLOB_H
2942 
# include <glob.h>
2943 
#endif
2944 
#ifdef Win32
2945 
# include <dos_wglob.h>
2946 
# define globfree dos_wglobfree
2947 
# define glob_t wglob_t
2948 
#else
2949 
# ifndef GLOB_QUOTE
2950 
#  define GLOB_QUOTE 0
2951 
# endif
2952 
#endif
83446 ripley 2953 
attribute_hidden SEXP do_glob(SEXP call, SEXP op, SEXP args, SEXP env)
49381 ripley 2954 
{
2955 
    SEXP x, ans;
70047 ripley 2956 
    R_xlen_t i, n;
87891 ripley 2957 
    int res, dirmark;
2958 
    bool initialized = false;
49381 ripley 2959 
    glob_t globbuf;
49392 ripley 2960 
#ifdef Win32
49385 ripley 2961 
    R_StringBuffer cbuff = {NULL, 0, MAXELTSIZE};
49392 ripley 2962 
#endif
49381 ripley 2963 
 
2964 
    checkArity(op, args);
2965 
    if (!isString(x = CAR(args)))
2966 
	error(_("invalid '%s' argument"), "paths");
59052 ripley 2967 
    if (!XLENGTH(x)) return allocVector(STRSXP, 0);
49381 ripley 2968 
    dirmark = asLogical(CADR(args));
2969 
    if (dirmark == NA_LOGICAL)
2970 
	error(_("invalid '%s' argument"), "dirmark");
2971 
#ifndef GLOB_MARK
2972 
    if (dirmark)
2973 
	error(_("'dirmark = TRUE' is not supported on this platform"));
2974 
#endif
2975 
 
59052 ripley 2976 
    for (i = 0; i < XLENGTH(x); i++) {
49381 ripley 2977 
	SEXP el = STRING_ELT(x, i);
2978 
	if (el == NA_STRING) continue;
2979 
#ifdef Win32
2980 
	res = dos_wglob(filenameToWchar(el, FALSE),
2981 
			(dirmark ? GLOB_MARK : 0) |
59832 pd 2982 
			GLOB_QUOTE | (initialized ? GLOB_APPEND : 0),
49381 ripley 2983 
			NULL, &globbuf);
2984 
	if (res == GLOB_NOSPACE)
2985 
	    error(_("internal out-of-memory condition"));
2986 
#else
2987 
	res = glob(translateChar(el),
2988 
# ifdef GLOB_MARK
2989 
		   (dirmark ? GLOB_MARK : 0) |
2990 
# endif
59832 pd 2991 
		   GLOB_QUOTE | (initialized ? GLOB_APPEND : 0),
49381 ripley 2992 
		   NULL, &globbuf);
2993 
# ifdef GLOB_ABORTED
2994 
	if (res == GLOB_ABORTED)
2995 
	    warning(_("read error on '%s'"), translateChar(el));
2996 
# endif
2997 
# ifdef GLOB_NOSPACE
2998 
	if (res == GLOB_NOSPACE)
2999 
	    error(_("internal out-of-memory condition"));
3000 
# endif
3001 
#endif
87891 ripley 3002 
	initialized = true;
49381 ripley 3003 
    }
59832 pd 3004 
    n = initialized ? globbuf.gl_pathc : 0;
49381 ripley 3005 
    PROTECT(ans = allocVector(STRSXP, n));
3006 
    for (i = 0; i < n; i++)
3007 
#ifdef Win32
3008 
    {
3009 
	wchar_t *w = globbuf.gl_pathv[i];
3010 
	char *buf;
84260 kalibera 3011 
	size_t nb = wcstoutf8(NULL, w, (size_t)INT_MAX + 2);
72714 murdoch 3012 
	buf = R_AllocStringBuffer(nb, &cbuff);
3013 
	wcstoutf8(buf, w, nb);
49381 ripley 3014 
	SET_STRING_ELT(ans, i, mkCharCE(buf, CE_UTF8));
3015 
    }
3016 
#else
3017 
	SET_STRING_ELT(ans, i, mkChar(globbuf.gl_pathv[i]));
3018 
#endif
3019 
    UNPROTECT(1);
3020 
#ifdef Win32
3021 
    R_FreeStringBufferL(&cbuff);
3022 
#endif
59832 pd 3023 
    if (initialized) globfree(&globbuf);
49381 ripley 3024 
    return ans;
3025 
}
76905 kalibera 3026 
 
3027 
/* isatty is in unistd.h, or io.h on Windows */
3028 
#ifdef Win32
3029 
# include <io.h>
3030 
#endif
3031 
 
3032 
#ifdef Win32
3033 
 
87901 ripley 3034 
attribute_hidden int R_is_redirection_tty(int fd)
76905 kalibera 3035 
{
3036 
    /* for now detects only msys/cygwin redirection tty */
3037 
    HANDLE h = (HANDLE) _get_osfhandle(fd);
3038 
    if (h == INVALID_HANDLE_VALUE || GetFileType(h) != FILE_TYPE_PIPE)
3039 
	return 0;
3040 
    FILE_NAME_INFO *fnInfo;
83821 kalibera 3041 
 
3042 
    /* find out the required FileNameLength */
3043 
    DWORD size = sizeof(FILE_NAME_INFO);
76905 kalibera 3044 
    if (!(fnInfo = (FILE_NAME_INFO*)malloc(size)))
3045 
	return 0;
83821 kalibera 3046 
    fnInfo->FileNameLength = 0; /* most likely not needed */
83954 kalibera 3047 
    BOOL r = GetFileInformationByHandleEx(h, FileNameInfo, fnInfo, size);
83821 kalibera 3048 
    if (r || GetLastError() != ERROR_MORE_DATA) {
3049 
	free(fnInfo);
3050 
	return 0;
3051 
    }
3052 
    /* use the right length */
3053 
    DWORD fnLength = fnInfo->FileNameLength; /* most likely not needed */
3054 
    size = sizeof(FILE_NAME_INFO) + fnLength;
3055 
    free(fnInfo);
3056 
    if (!(fnInfo = (FILE_NAME_INFO*)malloc(size)))
3057 
	return 0;
3058 
    fnInfo->FileNameLength = fnLength;
83954 kalibera 3059 
    r = GetFileInformationByHandleEx(h, FileNameInfo, fnInfo, size);
76905 kalibera 3060 
    int res = 0;
83821 kalibera 3061 
    if (r)
3062 
	/* note that fnInfo->FileName is not null terminated */
76998 kalibera 3063 
	/* e.g. msys-1888ae32e00d56aa-pty0-from-master,
3064 
	        cygwin-e022582115c10879-pty0-from-master */
76905 kalibera 3065 
	/* test borrowed from git */
3066 
	res = ((wcsstr(fnInfo->FileName, L"msys-") ||
3067 
	        wcsstr(fnInfo->FileName, L"cygwin-")) &&
3068 
		wcsstr(fnInfo->FileName, L"-pty"));
3069 
    free(fnInfo);
3070 
    return res;
3071 
}
3072 
#endif
3073 
 
87901 ripley 3074 
attribute_hidden int R_isatty(int fd)
76905 kalibera 3075 
{
3076 
#ifdef Win32
3077 
    if (R_is_redirection_tty(fd))
3078 
	return 1;
3079 
#endif
3080 
    return isatty(fd);
3081 
}
3082