SEXP attribute_hidden do_unsetenv(SEXP call, SEXP op, SEXP args, SEXP env)
{
int i, n;
SEXP ans, vars;
checkArity(op, args);
if (!isString(vars = CAR(args)))
error(_("wrong type for argument"));
n = LENGTH(vars);
#if defined(HAVE_UNSETENV) || defined(HAVE_PUTENV_UNSET) || defined(HAVE_PUTENV_UNSET2)
#ifdef HAVE_UNSETENV
for (i = 0; i < n; i++) unsetenv(translateChar(STRING_ELT(vars, i)));
#elif defined(HAVE_PUTENV_UNSET)
for (i = 0; i < n; i++) {
char buf[1000];
snprintf(buf, 1000, "%s", translateChar(STRING_ELT(vars, i)));
putenv(buf);
}
#elif defined(HAVE_PUTENV_UNSET2)
# ifdef Win32
for (i = 0; i < n; i++) {
const wchar_t *w = wtransChar(STRING_ELT(vars, i));
wchar_t buf[2*wcslen(w)];
wcscpy(buf, w);
wcscat(buf, L"=");
_wputenv(buf);
}
# else
for (i = 0; i < n; i++) {
char buf[1000];
snprintf(buf, 1000, "%s=", translateChar(STRING_ELT(vars, i)));
putenv(buf);
}
# endif
#endif
#elif defined(HAVE_PUTENV) || defined(HAVE_SETENV)
warning(_("this system cannot unset environment variables: setting to \"\""));
n = LENGTH(vars);
for (i = 0; i < n; i++) {
#ifdef HAVE_SETENV
setenv(translateChar(STRING_ELT(vars, i)), "", 1);
#else
Rputenv(translateChar(STRING_ELT(vars, i)), "");
#endif
}
#else
warning(_("'Sys.unsetenv' is not available on this system"));
#endif
PROTECT(ans = allocVector(LGLSXP, n));
for (i = 0; i < n; i++)
LOGICAL(ans)[i] = !getenv(translateChar(STRING_ELT(vars, i)));
UNPROTECT(1);
return ans;
}
SEXP attribute_hidden do_setenv(SEXP call, SEXP op, SEXP args, SEXP env)
{
#if defined(HAVE_PUTENV) || defined(HAVE_SETENV)
int i, n;
SEXP ans, nm, vars;
checkArity(op, args);
if (!isString(nm = CAR(args)))
error(_("wrong type for argument"));
if (!isString(vars = CADR(args)))
error(_("wrong type for argument"));
if(LENGTH(nm) != LENGTH(vars))
error(_("wrong length for argument"));
n = LENGTH(vars);
PROTECT(ans = allocVector(LGLSXP, n));
#ifdef HAVE_SETENV
for (i = 0; i < n; i++)
LOGICAL(ans)[i] = setenv(translateChar(STRING_ELT(nm, i)),
translateChar(STRING_ELT(vars, i)),
1) == 0;
#elif defined(Win32)
for (i = 0; i < n; i++)
LOGICAL(ans)[i] = Rwputenv(wtransChar(STRING_ELT(nm, i)),
wtransChar(STRING_ELT(vars, i))) == 0;
#else
for (i = 0; i < n; i++)
LOGICAL(ans)[i] = Rputenv(translateChar(STRING_ELT(nm, i)),
translateChar(STRING_ELT(vars, i))) == 0;
#endif
UNPROTECT(1);
return ans;
#else
error(_("'Sys.setenv' is not available on this system"));
return R_NilValue; /* -Wall */
#endif
}
SEXP addhistory(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP stamp;
const void *vmax = vmaxget();
args = CDR(args);
stamp = CAR(args);
if (!isString(stamp))
errorcall(call, _("invalid timestamp"));
if (CharacterMode == RGui) {
for (int i = 0; i < LENGTH(stamp); i++)
wgl_histadd(wtransChar(STRING_ELT(stamp, i)));
} else if (R_Interactive && CharacterMode == RTerm) {
for (int i = 0; i < LENGTH(stamp); i++)
gl_histadd(translateChar(STRING_ELT(stamp, i)));
}
vmaxset(vmax);
return R_NilValue;
}
SEXP attribute_hidden do_getenv(SEXP call, SEXP op, SEXP args, SEXP env)
{
int i, j;
SEXP ans;
checkArity(op, args);
if (!isString(CAR(args)))
error(_("wrong type for argument"));
if (!isString(CADR(args)) || LENGTH(CADR(args)) != 1)
error(_("wrong type for argument"));
i = LENGTH(CAR(args));
if (i == 0) {
#ifdef Win32
int n = 0, N;
wchar_t **w;
for (i = 0, w = _wenviron; *w != NULL; i++, w++)
n = max(n, wcslen(*w));
N = 3*n+1;
char buf[N];
PROTECT(ans = allocVector(STRSXP, i));
for (i = 0, w = _wenviron; *w != NULL; i++, w++) {
wcstoutf8(buf, *w, N); buf[N-1] = '\0';
SET_STRING_ELT(ans, i, mkCharCE(buf, CE_UTF8));
}
#else
char **e;
for (i = 0, e = environ; *e != NULL; i++, e++);
PROTECT(ans = allocVector(STRSXP, i));
for (i = 0, e = environ; *e != NULL; i++, e++)
SET_STRING_ELT(ans, i, mkChar(*e));
#endif
} else {
PROTECT(ans = allocVector(STRSXP, i));
for (j = 0; j < i; j++) {
#ifdef Win32
const wchar_t *wnm = wtransChar(STRING_ELT(CAR(args), j));
wchar_t *w = _wgetenv(wnm);
if (w == NULL)
SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
else {
int n = wcslen(w), N = 3*n+1; /* UCS-2 maps to <=3 UTF-8 */
R_CheckStack2(N);
char buf[N];
wcstoutf8(buf, w, N); buf[N-1] = '\0'; /* safety */
SET_STRING_ELT(ans, j, mkCharCE(buf, CE_UTF8));
}
#else
char *s = getenv(translateChar(STRING_ELT(CAR(args), j)));
if (s == NULL)
SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
else {
SEXP tmp;
if(known_to_be_latin1) tmp = mkCharCE(s, CE_LATIN1);
else if(known_to_be_utf8) tmp = mkCharCE(s, CE_UTF8);
else tmp = mkChar(s);
SET_STRING_ELT(ans, j, tmp);
}
#endif
}
}
UNPROTECT(1);
return (ans);
}
SEXP writeClipboard(SEXP text, SEXP sformat)
{
int i, n, format;
HGLOBAL hglb;
char *s;
const char *p;
Rboolean success = FALSE, raw = FALSE;
const void *vmax = vmaxget();
format = asInteger(sformat);
if (TYPEOF(text) == RAWSXP) raw = TRUE;
else if(!isString(text))
error(_("argument must be a character vector or a raw vector"));
n = length(text);
if(n > 0) {
int len = 1;
if(raw) len = n;
else if (format == CF_UNICODETEXT)
for(i = 0; i < n; i++)
len += 2 * (wcslen(wtransChar(STRING_ELT(text, i))) + 2);
else
for(i = 0; i < n; i++)
len += strlen(translateChar(STRING_ELT(text, i))) + 2;
if ( (hglb = GlobalAlloc(GHND, len)) &&
(s = (char *)GlobalLock(hglb)) ) {
if(raw)
for(i = 0; i < n; i++) *s++ = RAW(text)[i];
else if (format == CF_UNICODETEXT) {
const wchar_t *wp;
wchar_t *ws = (wchar_t *) s;
for(i = 0; i < n; i++) {
wp = wtransChar(STRING_ELT(text, i));
while(*wp) *ws++ = *wp++;
*ws++ = L'\r'; *ws++ = L'\n';
}
*ws = L'\0';
} else {
for(i = 0; i < n; i++) {
p = translateChar(STRING_ELT(text, i));
while(*p) *s++ = *p++;
*s++ = '\r'; *s++ = '\n';
}
*s = '\0';
}
GlobalUnlock(hglb);
if (!OpenClipboard(NULL) || !EmptyClipboard()) {
warning(_("unable to open the clipboard"));
GlobalFree(hglb);
} else {
success = SetClipboardData(CF_TEXT, hglb) != 0;
if(!success) {
warning(_("unable to write to the clipboard"));
GlobalFree(hglb);
}
CloseClipboard();
}
}
}
vmaxset(vmax);
return ScalarLogical(success);
}
