FILE *RC_fopen(const SEXP fn, const char *mode, const Rboolean expand)
{
const void *vmax = vmaxget();
const char *filename = translateChar(fn), *res;
if(fn == NA_STRING || !filename) return NULL;
if(expand) res = R_ExpandFileName(filename);
else res = filename;
vmaxset(vmax);
return fopen(res, mode);
}
SEXP RTcl_AssignObjToVar(SEXP args)
{
const void *vmax = vmaxget();
Tcl_SetVar2Ex(RTcl_interp,
translateChar(STRING_ELT(CADR(args), 0)),
NULL,
(Tcl_Obj *) R_ExternalPtrAddr(CADDR(args)),
0);
vmaxset(vmax);
return R_NilValue;
}
SEXP RTcl_GetArrayElem(SEXP args)
{
SEXP x, i;
const char *xstr, *istr;
Tcl_Obj *tclobj;
const void *vmax = vmaxget();
x = CADR(args);
i = CADDR(args);
xstr = translateChar(STRING_ELT(x, 0));
istr = translateChar(STRING_ELT(i, 0));
tclobj = Tcl_GetVar2Ex(RTcl_interp, xstr, istr, 0);
vmaxset(vmax);
if (tclobj == NULL)
return R_NilValue;
else
return makeRTclObject(tclobj);
}
/* Translates a hex value into it's appropriate index in the array.
In reality, this just turns the first HASH_SIG_FIGS into decimal */
uint64_t translate(char *n)
{
int count;
uint64_t total = 0, power = 1;
for (count = HASH_SIG_FIGS - 1 ; count >= 0 ; count--) {
total += translateChar(n[count]) * power;
power *= 16;
}
return total;
}
SEXP chooseDir(SEXP def, SEXP caption)
{
const char *p;
char path[MAX_PATH];
if(!isString(def) || length(def) != 1 )
error(_("'default' must be a character string"));
p = translateChar(STRING_ELT(def, 0));
if(strlen(p) >= MAX_PATH) error(_("'default' is overlong"));
strcpy(path, R_ExpandFileName(p));
R_fixbackslash(path);
if(!isString(caption) || length(caption) != 1 )
error(_("'caption' must be a character string"));
p = askcdstring(translateChar(STRING_ELT(caption, 0)), path);
SEXP ans = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, p ? mkChar(p): NA_STRING);
UNPROTECT(1);
return ans;
}
apop_data *get_factors(SEXP ls, char const *varname){
int nls = LENGTH(ls);
if (isNull(ls)) return NULL;
//else:
apop_data *out = apop_text_alloc(NULL, nls, 1);
for (int i = 0; i < nls; i++)
apop_text_add(out, i, 0, translateChar(STRING_ELT(ls, i)));
asprintf(&out->names->title, "<categories for %s>", varname);
apop_data_show(out);
return out;
}
SEXP attribute_hidden do_dynunload(SEXP call, SEXP op, SEXP args, SEXP env)
{
char buf[2 * PATH_MAX];
checkArity(op,args);
if (!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
error(_("character argument expected"));
GetFullDLLPath(call, buf, translateChar(STRING_ELT(CAR(args), 0)));
if(!DeleteDLL(buf))
error(_("shared object '%s\' was not loaded"), buf);
return R_NilValue;
}
/* Match what EncodeString does with encodings */
attribute_hidden
int Rstrlen(SEXP s, int quote)
{
cetype_t ienc = getCharCE(s);
if (ienc == CE_UTF8 || ienc == CE_BYTES)
return Rstrwid(CHAR(s), LENGTH(s), ienc, quote);
const void *vmax = vmaxget();
const char *p = translateChar(s);
int len = Rstrwid(p, (int)strlen(p), CE_NATIVE, quote);
vmaxset(vmax);
return len;
}
/* Returns: */
static
enum pmatch
pstrmatch(SEXP target, SEXP input, size_t slen)
{
const char *st = "";
if(target == R_NilValue)
return NO_MATCH;
switch (TYPEOF(target)) {
case SYMSXP:
st = CHAR(PRINTNAME(target));
break;
case CHARSXP:
st = translateChar(target);
break;
}
if(strncmp(st, translateChar(input), slen) == 0)
return (strlen(st) == slen) ? EXACT_MATCH : PARTIAL_MATCH;
else return NO_MATCH;
}
SEXP winDialog(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP message;
const char * type;
int res=YES;
args = CDR(args);
type = translateChar(STRING_ELT(CAR(args), 0));
message = CADR(args);
if(!isString(message) || length(message) != 1 ||
strlen(translateChar(STRING_ELT(message, 0))) > 255)
error(_("invalid '%s' argument"), "message");
if (strcmp(type, "ok") == 0) {
askok(translateChar(STRING_ELT(message, 0)));
res = 10;
} else if (strcmp(type, "okcancel") == 0) {
res = askokcancel(translateChar(STRING_ELT(message, 0)));
if(res == YES) res = 2;
} else if (strcmp(type, "yesno") == 0) {
res = askyesno(translateChar(STRING_ELT(message, 0)));
} else if (strcmp(type, "yesnocancel") == 0) {
res = askyesnocancel(translateChar(STRING_ELT(message, 0)));
} else
errorcall(call, _("unknown type"));
return ScalarInteger(res);
}
int Fonts::charHeight(unsigned char c) {
byte curChar;
if (!_font)
return 0;
// Space is supposed to be handled like the first actual character (which is decimal 33)
curChar = translateChar(c);
assert(curChar < _charCount);
const ImageFrame &img = (*_font)[curChar];
return img._height + img._offset.y + 1;
}
SEXP Rsockconnect(SEXP sport, SEXP shost)
{
if (length(sport) != 1) error("invalid 'socket' argument");
int port = asInteger(sport);
char *host[1];
host[0] = const_cast<char *>( translateChar(STRING_ELT(shost, 0)));
if(!initialized) internet_Init();
if(initialized > 0)
(*ptr->sockconnect)(&port, host);
else
error(_("socket routines cannot be loaded"));
return ScalarInteger(port); // The socket number
}
/* utils::loadRconsole */
SEXP in_loadRconsole(SEXP sfile)
{
struct structGUI gui;
const void *vmax = vmaxget();
if (!isString(sfile) || LENGTH(sfile) < 1)
error(_("invalid '%s' argument"), "file");
getActive(&gui); /* Will get defaults if there's no active console */
if (loadRconsole(&gui, translateChar(STRING_ELT(sfile, 0)))) applyGUI(&gui);
if (strlen(gui.warning)) warning(gui.warning);
vmaxset(vmax);
return R_NilValue;
}
SEXP RTcl_ObjFromVar(SEXP args)
{
Tcl_Obj *tclobj;
const void *vmax = vmaxget();
tclobj = Tcl_GetVar2Ex(RTcl_interp,
translateChar(STRING_ELT(CADR(args), 0)),
NULL,
0);
SEXP res = makeRTclObject(tclobj);
vmaxset(vmax);
return res;
}
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_readEnviron(SEXP call, SEXP op, SEXP args, SEXP env)
{
checkArity(op, args);
SEXP x = CAR(args);
if (!isString(x) || LENGTH(x) != 1)
errorcall(call, _("argument '%s' must be a character string"), "x");
const char *fn = R_ExpandFileName(translateChar(STRING_ELT(x, 0)));
int res = process_Renviron(fn);
if (!res)
warningcall(call, _("file '%s' cannot be opened for reading"), fn);
return ScalarLogical(res != 0);
}
SEXP setWinProgressBar(SEXP call, SEXP op, SEXP args, SEXP env)
{
args = CDR(args);
SEXP ptr = CAR(args);
winprogressbar *pbar;
double value;
pbar = R_ExternalPtrAddr(ptr);
if(!pbar)
error("invalid progressbar -- has it been closed?");
value = pbar->val;
if(!isNull(CADR(args))) {
int iv;
double val = asReal(CADR(args));
SEXP title = CADDR(args), label = CADDDR(args);
if (R_FINITE(val) && val >= pbar->min && val <= pbar->max) {
iv = pbar->width * (val - pbar->min)/(pbar->max - pbar->min);
setprogressbar(pbar->pb, iv);
pbar->val = val;
}
if (!isNull(title)) {
SEXP ctxt;
if(!isString(title) || length(title) < 1)
errorcall(call, "invalid '%s' argument", "title");
ctxt = STRING_ELT(title, 0);
if (ctxt != NA_STRING)
settext(pbar->wprog, translateChar(ctxt));
}
if(pbar->lab && !isNull(label)) {
SEXP clab;
if(!isString(label) || length(label) < 1)
errorcall(call, "invalid '%s' argument", "label");
clab = STRING_ELT(label, 0);
if (clab != NA_STRING)
settext(pbar->lab, translateChar(clab));
}
}
return ScalarReal(value);
}
attribute_hidden
const char *EncodeEnvironment(SEXP x)
{
const void *vmax = vmaxget();
static char ch[1000];
if (x == R_GlobalEnv)
sprintf(ch, "<environment: R_GlobalEnv>");
else if (x == R_BaseEnv)
sprintf(ch, "<environment: base>");
else if (x == R_EmptyEnv)
sprintf(ch, "<environment: R_EmptyEnv>");
else if (R_IsPackageEnv(x))
snprintf(ch, 1000, "<environment: %s>",
translateChar(STRING_ELT(R_PackageEnvName(x), 0)));
else if (R_IsNamespaceEnv(x))
snprintf(ch, 1000, "<environment: namespace:%s>",
translateChar(STRING_ELT(R_NamespaceEnvSpec(x), 0)));
else snprintf(ch, 1000, "<environment: %p>", (void *)x);
vmaxset(vmax);
return ch;
}
SEXP winMenuItems(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP mname, ans, ansnames;
menuItems *items;
char errmsg[50];
int i;
args = CDR(args);
if (CharacterMode != RGui)
errorcall(call, _("menu functions can only be used in the GUI"));
mname = CAR(args);
if (!isString(mname) || length(mname) != 1)
error(_("invalid '%s' argument"), "menuname");
items = wingetmenuitems(translateChar(STRING_ELT(mname,0)), errmsg);
if (items->numItems == 0) {
sprintf(msgbuf, _("unable to retrieve items for %s (%s)"),
translateChar(STRING_ELT(mname,0)), errmsg);
freemenuitems(items);
errorcall(call, msgbuf);
}
PROTECT(ans = allocVector(STRSXP, items->numItems));
PROTECT(ansnames = allocVector(STRSXP, items->numItems));
for (i = 0; i < items->numItems; i++) {
SET_STRING_ELT(ans, i, mkChar(items->mItems[i]->action));
SET_STRING_ELT(ansnames, i, mkChar(items->mItems[i]->name));
}
setAttrib(ans, R_NamesSymbol, ansnames);
freemenuitems(items);
UNPROTECT(2);
return(ans);
}
SEXP attribute_hidden do_tempfile(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP ans, pattern, fileext, tempdir;
const char *tn, *td, *te;
char *tm;
int i, n1, n2, n3, slen;
checkArity(op, args);
pattern = CAR(args); n1 = length(pattern); args = CDR(args);
tempdir = CAR(args); n2 = length(tempdir); args = CDR(args);
fileext = CAR(args); n3 = length(fileext);
if (!isString(pattern))
error(_("invalid filename pattern"));
if (!isString(tempdir))
error(_("invalid '%s' value"), "tempdir");
if (!isString(fileext))
error(_("invalid file extension"));
if (n1 < 1)
error(_("no 'pattern'"));
if (n2 < 1)
error(_("no 'tempdir'"));
if (n3 < 1)
error(_("no 'fileext'"));
slen = (n1 > n2) ? n1 : n2;
slen = (n3 > slen) ? n3 : slen;
PROTECT(ans = allocVector(STRSXP, slen));
for(i = 0; i < slen; i++) {
tn = translateChar( STRING_ELT( pattern , i%n1 ) );
td = translateChar( STRING_ELT( tempdir , i%n2 ) );
te = translateChar( STRING_ELT( fileext , i%n3 ) );
/* try to get a new file name */
tm = R_tmpnam2(tn, td, te);
SET_STRING_ELT(ans, i, mkChar(tm));
if(tm) free(tm);
}
UNPROTECT(1);
return (ans);
}
SEXP attribute_hidden do_setenv(SEXP call, SEXP op, SEXP args, SEXP env)
{
#if defined(HAVE_PUTENV) || defined(HAVE_SETENV)
int i, n;
SEXP ans, nm, vars;
checkArity(op, args);
if (!isString(nm = CAR(args)))
error(_("wrong type for argument"));
if (!isString(vars = CADR(args)))
error(_("wrong type for argument"));
if(LENGTH(nm) != LENGTH(vars))
error(_("wrong length for argument"));
n = LENGTH(vars);
PROTECT(ans = allocVector(LGLSXP, n));
#ifdef HAVE_SETENV
for (i = 0; i < n; i++)
LOGICAL(ans)[i] = setenv(translateChar(STRING_ELT(nm, i)),
translateChar(STRING_ELT(vars, i)),
1) == 0;
#elif defined(Win32)
for (i = 0; i < n; i++)
LOGICAL(ans)[i] = Rwputenv(wtransChar(STRING_ELT(nm, i)),
wtransChar(STRING_ELT(vars, i))) == 0;
#else
for (i = 0; i < n; i++)
LOGICAL(ans)[i] = Rputenv(translateChar(STRING_ELT(nm, i)),
translateChar(STRING_ELT(vars, i))) == 0;
#endif
UNPROTECT(1);
return ans;
#else
error(_("'Sys.setenv' is not available on this system"));
return R_NilValue; /* -Wall */
#endif
}
SEXP attribute_hidden do_retracemem(SEXP call, SEXP op, SEXP args, SEXP rho)
{
#ifdef R_MEMORY_PROFILING
SEXP object, previous, ans, argList;
char buffer[21];
static SEXP do_retracemem_formals = NULL;
if (do_retracemem_formals == NULL)
do_retracemem_formals = allocFormalsList2(install("x"),
R_PreviousSymbol);
PROTECT(argList = matchArgs(do_retracemem_formals, args, call));
if(CAR(argList) == R_MissingArg) SETCAR(argList, R_NilValue);
if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue);
object = CAR(argList);
if (TYPEOF(object) == CLOSXP ||
TYPEOF(object) == BUILTINSXP ||
TYPEOF(object) == SPECIALSXP)
errorcall(call, _("argument must not be a function"));
previous = CADR(argList);
if(!isNull(previous) && !isString(previous))
errorcall(call, _("invalid '%s' argument"), "previous");
if (RTRACE(object)) {
snprintf(buffer, 21, "<%p>", (void *) object);
ans = mkString(buffer);
} else {
R_Visible = 0;
ans = R_NilValue;
}
if (previous != R_NilValue){
SET_RTRACE(object, 1);
if (R_current_trace_state()) {
/* FIXME: previous will have <0x....> whereas other values are
without the < > */
Rprintf("tracemem[%s -> %p]: ",
translateChar(STRING_ELT(previous, 0)), (void *) object);
memtrace_stack_dump();
}
}
UNPROTECT(1);
return ans;
#else
R_Visible = 0; /* for consistency with other case */
return R_NilValue;
#endif
}
SEXP dotTcl(SEXP args)
{
SEXP ans;
const char *cmd;
Tcl_Obj *val;
const void *vmax = vmaxget();
if(!isValidString(CADR(args)))
error(_("invalid argument"));
cmd = translateChar(STRING_ELT(CADR(args), 0));
val = tk_eval(cmd);
ans = makeRTclObject(val);
vmaxset(vmax);
return ans;
}
SEXP Rsockwrite(SEXP ssock, SEXP sstring)
{
if (length(ssock) != 1) error("invalid 'socket' argument");
int sock = asInteger(ssock), start = 0, end, len;
char *buf = const_cast<char *>( translateChar(STRING_ELT(sstring, 0))), *abuf[1];
end = len = int( strlen(buf));
abuf[0] = buf;
if(!initialized) internet_Init();
if(initialized > 0)
(*ptr->sockwrite)(&sock, abuf, &start, &end, &len);
else
error(_("socket routines cannot be loaded"));
return ScalarInteger(len);
}
/* Are these are always native charset? */
Rboolean pmatch(SEXP formal, SEXP tag, Rboolean exact)
{
const char *f, *t;
const void *vmax = vmaxget();
switch (TYPEOF(formal)) {
case SYMSXP:
f = CHAR(PRINTNAME(formal));
break;
case CHARSXP:
f = CHAR(formal);
break;
case STRSXP:
f = translateChar(STRING_ELT(formal, 0));
break;
default:
goto fail;
}
switch(TYPEOF(tag)) {
case SYMSXP:
t = CHAR(PRINTNAME(tag));
break;
case CHARSXP:
t = CHAR(tag);
break;
case STRSXP:
t = translateChar(STRING_ELT(tag, 0));
break;
default:
goto fail;
}
Rboolean res = psmatch(f, t, exact);
vmaxset(vmax);
return res;
fail:
error(_("invalid partial string match"));
return FALSE;/* for -Wall */
}
/* utils::shortPathName */
SEXP in_shortpath(SEXP paths)
{
SEXP ans, el;
int i, n = LENGTH(paths);
char tmp[MAX_PATH];
wchar_t wtmp[32768];
DWORD res;
const void *vmax = vmaxget();
if(!isString(paths)) error(_("'path' must be a character vector"));
PROTECT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
el = STRING_ELT(paths, i);
if(getCharCE(el) == CE_UTF8) {
res = GetShortPathNameW(filenameToWchar(el, FALSE), wtmp, 32768);
if (res && res <= 32768)
wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
else
strcpy(tmp, translateChar(el));
/* documented to return paths using \, which the API call does
not necessarily do */
R_fixbackslash(tmp);
SET_STRING_ELT(ans, i, mkCharCE(tmp, CE_UTF8));
} else {
res = GetShortPathName(translateChar(el), tmp, MAX_PATH);
if (res == 0 || res > MAX_PATH) strcpy(tmp, translateChar(el));
/* documented to return paths using \, which the API call does
not necessarily do */
R_fixbackslash(tmp);
SET_STRING_ELT(ans, i, mkChar(tmp));
}
}
UNPROTECT(1);
vmaxset(vmax);
return ans;
}
// formerly in src/main/platform.c
SEXP fileedit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP fn, ti, ed;
const char **f, **title, *editor;
int i, n;
const void *vmax = vmaxget();
args = CDR(args);
fn = CAR(args); args = CDR(args);
ti = CAR(args); args = CDR(args);
ed = CAR(args);
n = length(fn);
if (!isString(ed) || length(ed) != 1)
error(_("invalid '%s' specification"), "editor");
if (n > 0) {
if (!isString(fn))
error(_("invalid '%s' specification"), "filename");
f = (const char**) R_alloc(n, sizeof(char*));
title = (const char**) R_alloc(n, sizeof(char*));
/* FIXME convert to UTF-8 on Windows */
for (i = 0; i < n; i++) {
SEXP el = STRING_ELT(fn, 0);
if (!isNull(el))
#ifdef Win32
f[i] = acopy_string(reEnc(CHAR(el), getCharCE(el), CE_UTF8, 1));
#else
f[i] = acopy_string(translateChar(el));
#endif
else
f[i] = "";
if (!isNull(STRING_ELT(ti, i)))
title[i] = acopy_string(translateChar(STRING_ELT(ti, i)));
else
title[i] = "";
}
}
int attribute_hidden R_TextBufferInit(TextBuffer *txtb, SEXP text)
{
int i, k, l, n;
if (isString(text)) {
// translateChar might allocate
void *vmax = vmaxget();
n = length(text);
l = 0;
for (i = 0; i < n; i++) {
if (STRING_ELT(text, i) != R_NilValue) {
k = int( strlen(translateChar(STRING_ELT(text, i))));
if (k > l)
l = k;
}
}
vmaxset(vmax);
txtb->vmax = vmax;
txtb->buf = static_cast<unsigned char *>(RHO_alloc(l+2, sizeof(char))); /* '\n' and '\0' */
txtb->bufp = txtb->buf;
txtb->text = text;
txtb->ntext = n;
txtb->offset = 0;
transferChars(txtb->buf,
translateChar(STRING_ELT(txtb->text, txtb->offset)));
txtb->offset++;
return 1;
}
else {
txtb->vmax = vmaxget();
txtb->buf = nullptr;
txtb->bufp = nullptr;
txtb->text = R_NilValue;
txtb->ntext = 0;
txtb->offset = 1;
return 0;
}
}
static void memtrace_stack_dump(void)
{
RCNTXT *cptr;
for (cptr = R_GlobalContext; cptr; cptr = cptr->nextcontext) {
if ((cptr->callflag & (CTXT_FUNCTION | CTXT_BUILTIN))
&& TYPEOF(cptr->call) == LANGSXP) {
SEXP fun = CAR(cptr->call);
Rprintf("%s ",
TYPEOF(fun) == SYMSXP ? translateChar(PRINTNAME(fun)) :
"<Anonymous>");
}
}
Rprintf("\n");
}
int Fonts::charWidth(unsigned char c) {
byte curChar;
if (!_font)
return 0;
if (c == ' ') {
return 5; // hardcoded space
}
curChar = translateChar(c);
if (curChar < _charCount)
return (*_font)[curChar]._frame.w + 1;
return 0;
}