void InitTempDir()
{
char *tmp, *tm, tmp1[PATH_MAX+10], *p;
int len;
#ifndef HAVE_MKDTEMP
int res;
#endif
tmp = getenv("R_SESSION_TMPDIR");
if (!tmp) {
/* This looks like it will only be called in the embedded case
since this is done in the script. Also should test if directory
exists rather than just attempting to remove it.
*/
char *buf;
tm = getenv("TMPDIR");
if (!tm) tm = getenv("TMP");
if (!tm) tm = getenv("TEMP");
if (!tm) tm = "/tmp";
#ifdef HAVE_MKDTEMP
sprintf(tmp1, "%s/RtmpXXXXXX", tm);
tmp = mkdtemp(tmp1);
if(!tmp) R_Suicide(_("cannot mkdir R_TempDir"));
#else
sprintf(tmp1, "rm -rf %s/Rtmp%u", tm, (unsigned int)getpid());
R_system(tmp1);
sprintf(tmp1, "%s/Rtmp%u", tm, (unsigned int)getpid());
res = mkdir(tmp1, 0755);
if(res) {
/* Try one more time, in case a dir left around from that
process number from another user */
sprintf(tmp1, "rm -rf %s/Rtmp%u-%d", tm, (unsigned int)getpid(),
rand() % 1000);
R_system(tmp1);
sprintf(tmp1, "%s/Rtmp%u-%d", tm, (unsigned int)getpid(),
rand() % 1000);
res = mkdir(tmp1, 0755);
}
if(res) R_Suicide(_("cannot mkdir R_TempDir"));
#endif
tmp = tmp1;
buf = (char *) malloc((strlen(tmp) + 20) * sizeof(char));
if(buf) {
sprintf(buf, "R_SESSION_TMPDIR=%s", tmp);
putenv(buf);
/* no free here: storage remains in use */
}
}
len = strlen(tmp) + 1;
p = (char *) malloc(len);
if(!p) R_Suicide(_("cannot allocate R_TempDir"));
else {
R_TempDir = p;
strcpy(R_TempDir, tmp);
}
}
/*
* nfile = number of files
* file = array of filenames
* editor = editor to be used.
*/
int R_EditFiles(int nfile, const char **file, const char **title,
const char *editor)
{
char buf[1024];
if (ptr_R_EditFiles) return(ptr_R_EditFiles(nfile, file, title, editor));
if (nfile > 0) {
if (nfile > 1)
R_ShowMessage(_("WARNING: Only editing the first in the list of files"));
if (ptr_R_EditFile) ptr_R_EditFile((char *) file[0]);
else {
/* Quote path if necessary */
if (editor[0] != '"' && Rf_strchr(editor, ' '))
snprintf(buf, 1024, "\"%s\" \"%s\"", editor, file[0]);
else
snprintf(buf, 1024, "%s \"%s\"", editor, file[0]);
if (R_system(buf) == 127)
warningcall(R_NilValue, _("error in running command"));
}
return 0;
}
return 1;
}
int attribute_hidden
Rstd_ShowFiles(int nfile, /* number of files */
const char **file, /* array of filenames */
const char **headers, /* the `headers' args of file.show.
Printed before each file. */
const char *wtitle, /* title for window
= `title' arg of file.show */
Rboolean del, /* should files be deleted after use? */
const char *pager) /* pager to be used */
{
/*
This function can be used to display the named files with the
given titles and overall title. On GUI platforms we could
use a read-only window to display the result. Here we just
make up a temporary file and invoke a pager on it.
*/
int c, i, res;
char *filename;
FILE *fp, *tfp;
char buf[1024];
if (nfile > 0) {
if (pager == NULL || strlen(pager) == 0) pager = "more";
filename = R_tmpnam(NULL, R_TempDir); /* mallocs result */
if ((tfp = R_fopen(filename, "w")) != NULL) {
for(i = 0; i < nfile; i++) {
if (headers[i] && *headers[i])
fprintf(tfp, "%s\n\n", headers[i]);
errno = 0; /* some systems require this */
/* File expansion is now done in file.show(), but
left here in case other callers assumed it */
if ((fp = R_fopen(R_ExpandFileName(file[i]), "r"))
!= NULL) {
while ((c = fgetc(fp)) != EOF)
fputc(c, tfp);
fprintf(tfp, "\n");
fclose(fp);
if(del)
unlink(R_ExpandFileName(file[i]));
}
else
fprintf(tfp, _("Cannot open file '%s': %s\n\n"),
file[i], strerror(errno));
}
fclose(tfp);
}
snprintf(buf, 1024, "'%s' < '%s'", pager, filename); //might contain spaces
res = R_system(buf);
unlink(filename);
free(filename);
return (res != 0);
}
return 1;
}
SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
FILE *fp;
char *x = "r", buf[INTERN_BUFSIZE];
int read=0, i, j;
SEXP tlist = R_NilValue, tchar, rval;
checkArity(op, args);
if (!isValidStringF(CAR(args)))
errorcall(call, _("non-empty character argument expected"));
if (isLogical(CADR(args)))
read = INTEGER(CADR(args))[0];
if (read) {
#ifdef HAVE_POPEN
PROTECT(tlist);
fp = R_popen(CHAR(STRING_ELT(CAR(args), 0)), x);
for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
read = strlen(buf);
if (read > 0 && buf[read-1] == '\n')
buf[read - 1] = '\0'; /* chop final CR */
tchar = mkChar(buf);
UNPROTECT(1);
PROTECT(tlist = CONS(tchar, tlist));
}
pclose(fp);
rval = allocVector(STRSXP, i);;
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
UNPROTECT(1);
return (rval);
#else /* not HAVE_POPEN */
errorcall(call, _("intern=TRUE is not implemented on this platform"));
return R_NilValue;
#endif /* not HAVE_POPEN */
}
else {
#ifdef HAVE_AQUA
R_Busy(1);
#endif
tlist = allocVector(INTSXP, 1);
fflush(stdout);
INTEGER(tlist)[0] = R_system(CHAR(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
R_Busy(0);
#endif
R_Visible = 0;
return tlist;
}
}
void R_CleanTempDir(void)
{
char buf[1024];
if((Sys_TempDir)) {
#if defined(sun) || defined(__sun)
/* On Solaris the working directory must be outside this one */
chdir(R_HomeDir());
#endif
char *p = getenv("R_OSX_VALGRIND");
if (!p) {
snprintf(buf, 1024, "rm -rf %s", Sys_TempDir);
buf[1023] = '\0';
R_system(buf);
} else R_CleanTempDir2();
}
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ed, src, srcfile, Rfn;
char *filename, *editcmd;
const char *cmd;
const void *vmaxsave;
FILE *fp;
#ifdef Win32
SEXP ti;
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
const char *ss = translateChar(STRING_ELT(fn, 0));
filename = R_alloc(strlen(ss), sizeof(char));
strcpy(filename, ss);
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol)))
src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(src); i++)
fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i)));
fclose(fp);
}
#ifdef Win32
ti = CAR(args);
#endif
args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = translateChar(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, CE_NATIVE, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL);
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if (asLogical(GetOption1(install("keep.source")))) {
PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv));
PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename)))));
PROTECT(src = eval(src, R_BaseEnv));
PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv));
PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src));
srcfile = eval(srcfile, R_BaseEnv);
UNPROTECT(5);
} else
srcfile = R_NilValue;
PROTECT(srcfile);
/* <FIXME> setup a context to close the file, and parse and eval
line by line */
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
x = PROTECT(R_ParseFile(fp, -1, &status, srcfile));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(3);
vmaxset(vmaxsave);
return x;
}
SEXP attribute_hidden do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP tlist = R_NilValue;
int intern = 0;
checkArity(op, args);
if (!isValidStringF(CAR(args)))
error(_("non-empty character argument expected"));
intern = asLogical(CADR(args));
if (intern == NA_INTEGER)
error(_("'intern' must be logical and not NA"));
if (intern) { /* intern = TRUE */
FILE *fp;
char *x = "r", buf[INTERN_BUFSIZE];
const char *cmd;
int i, j, res;
SEXP tchar, rval;
PROTECT(tlist);
cmd = translateChar(STRING_ELT(CAR(args), 0));
errno = 0; /* precaution */
if(!(fp = R_popen(cmd, x)))
error(_("cannot popen '%s', probable reason '%s'"),
cmd, strerror(errno));
for (i = 0; fgets(buf, INTERN_BUFSIZE, fp); i++) {
size_t read = strlen(buf);
if(read >= INTERN_BUFSIZE - 1)
warning(_("line %d may be truncated in call to system(, intern = TRUE)"), i + 1);
if (read > 0 && buf[read-1] == '\n')
buf[read - 1] = '\0'; /* chop final CR */
tchar = mkChar(buf);
UNPROTECT(1);
PROTECT(tlist = CONS(tchar, tlist));
}
res = pclose(fp);
#ifdef HAVE_SYS_WAIT_H
if (WIFEXITED(res)) res = WEXITSTATUS(res);
else res = 0;
#else
/* assume that this is shifted if a multiple of 256 */
if ((res % 256) == 0) res = res/256;
#endif
if ((res & 0xff) == 127) {/* 127, aka -1 */
if (errno)
error(_("error in running command: '%s'"), strerror(errno));
else
error(_("error in running command"));
} else if (res) {
if (errno)
warningcall(R_NilValue,
_("running command '%s' had status %d and error message '%s'"),
cmd, res,
strerror(errno));
else
warningcall(R_NilValue,
_("running command '%s' had status %d"),
cmd, res);
}
rval = PROTECT(allocVector(STRSXP, i));
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
if(res) {
SEXP lsym = install("status");
setAttrib(rval, lsym, ScalarInteger(res));
if(errno) {
lsym = install("errmsg");
setAttrib(rval, lsym, mkString(strerror(errno)));
}
}
UNPROTECT(2);
return rval;
}
else { /* intern = FALSE */
#ifdef HAVE_AQUA
R_Busy(1);
#endif
tlist = PROTECT(allocVector(INTSXP, 1));
fflush(stdout);
INTEGER(tlist)[0] = R_system(translateChar(STRING_ELT(CAR(args), 0)));
#ifdef HAVE_AQUA
R_Busy(0);
#endif
UNPROTECT(1);
R_Visible = 0;
return tlist;
}
}
/**
This is the body of the REPL.
It attempts to parse the first line or expression of its input,
and optionally request input from the user if none is available.
If the input can be parsed correctly,
i) the resulting expression is evaluated,
ii) the result assigned to .Last.Value,
iii) top-level task handlers are invoked.
If the input cannot be parsed, i.e. there is a syntax error,
it is incomplete, or we encounter an end-of-file, then we
change the prompt accordingly.
The "cursor" for the input buffer is moved to the next starting
point, i.e. the end of the first line or after the first ;.
*/
int
Rf_ReplIteration(SEXP rho, int savestack, int browselevel, R_ReplState *state)
{
int c, browsevalue;
SEXP value, thisExpr;
Rboolean wasDisplayed = FALSE;
if(!*state->bufp) {
R_Busy(0);
if (R_ReadConsole(R_PromptString(browselevel, state->prompt_type),
state->buf, CONSOLE_BUFFER_SIZE, 1) == 0)
return(-1);
state->bufp = state->buf;
}
#ifdef SHELL_ESCAPE /* not default */
if (*state->bufp == '!') {
R_system(&(state->buf[1]));
state->buf[0] = '\0';
return(0);
}
#endif /* SHELL_ESCAPE */
while((c = *state->bufp++)) {
R_IoBufferPutc(c, &R_ConsoleIob);
if(c == ';' || c == '\n') break;
}
R_PPStackTop = savestack;
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 0, &state->status);
switch(state->status) {
case PARSE_NULL:
/* The intention here is to break on CR but not on other
null statements: see PR#9063 */
if (browselevel && !R_DisableNLinBrowser
&& !strcmp((char *) state->buf, "\n")) return -1;
R_IoBufferWriteReset(&R_ConsoleIob);
state->prompt_type = 1;
return 1;
case PARSE_OK:
R_IoBufferReadReset(&R_ConsoleIob);
R_CurrentExpr = R_Parse1Buffer(&R_ConsoleIob, 1, &state->status);
if (browselevel) {
browsevalue = ParseBrowser(R_CurrentExpr, rho);
if(browsevalue == 1) return -1;
if(browsevalue == 2) {
R_IoBufferWriteReset(&R_ConsoleIob);
return 0;
}
/* PR#15770 We don't want to step into expressions entered at the debug prompt.
The 'S' will be changed back to 's' after the next eval. */
if (R_BrowserLastCommand == 's') R_BrowserLastCommand = 'S';
}
R_Visible = FALSE;
R_EvalDepth = 0;
resetTimeLimits();
PROTECT(thisExpr = R_CurrentExpr);
R_Busy(1);
value = eval(thisExpr, rho);
SET_SYMVALUE(R_LastvalueSymbol, value);
wasDisplayed = R_Visible;
if (R_Visible)
PrintValueEnv(value, rho);
if (R_CollectWarnings)
PrintWarnings();
Rf_callToplevelHandlers(thisExpr, value, TRUE, wasDisplayed);
R_CurrentExpr = value; /* Necessary? Doubt it. */
UNPROTECT(1);
if (R_BrowserLastCommand == 'S') R_BrowserLastCommand = 's';
R_IoBufferWriteReset(&R_ConsoleIob);
state->prompt_type = 1;
return(1);
case PARSE_ERROR:
state->prompt_type = 1;
parseError(R_NilValue, 0);
R_IoBufferWriteReset(&R_ConsoleIob);
return(1);
case PARSE_INCOMPLETE:
R_IoBufferReadReset(&R_ConsoleIob);
state->prompt_type = 2;
return(2);
case PARSE_EOF:
return(-1);
break;
}
return(0);
}
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho)
{
int i, rc;
ParseStatus status;
SEXP x, fn, envir, ti, ed, t;
char *filename, *editcmd, *vmaxsave, *cmd;
FILE *fp;
#ifdef Win32
char *title;
#endif
checkArity(op, args);
vmaxsave = vmaxget();
x = CAR(args); args = CDR(args);
if (TYPEOF(x) == CLOSXP) envir = CLOENV(x);
else envir = R_NilValue;
PROTECT(envir);
fn = CAR(args); args = CDR(args);
if (!isString(fn))
error(_("invalid argument to edit()"));
if (LENGTH(STRING_ELT(fn, 0)) > 0) {
filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char));
strcpy(filename, CHAR(STRING_ELT(fn, 0)));
}
else filename = DefaultFileName;
if (x != R_NilValue) {
if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL)
errorcall(call, _("unable to open file"));
if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++;
if (TYPEOF(x) != CLOSXP || isNull(t = getAttrib(x, R_SourceSymbol)))
t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */
for (i = 0; i < LENGTH(t); i++)
fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i)));
fclose(fp);
}
ti = CAR(args); args = CDR(args);
ed = CAR(args);
if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid"));
cmd = CHAR(STRING_ELT(ed, 0));
if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set"));
editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char));
#ifdef Win32
if (!strcmp(cmd,"internal")) {
if (!isString(ti))
error(_("'title' must be a string"));
if (LENGTH(STRING_ELT(ti, 0)) > 0) {
title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char));
strcpy(title, CHAR(STRING_ELT(ti, 0)));
} else {
title = R_alloc(strlen(filename)+1, sizeof(char));
strcpy(title, filename);
}
Rgui_Edit(filename, title, 1);
}
else {
/* Quote path if necessary */
if(cmd[0] != '"' && Rf_strchr(cmd, ' '))
sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename);
else
sprintf(editcmd, "%s \"%s\"", cmd, filename);
rc = runcmd(editcmd, 1, 1, "");
if (rc == NOLAUNCH)
errorcall(call, _("unable to run editor '%s'"), cmd);
if (rc != 0)
warningcall(call, _("editor ran but returned error status"));
}
#else
if (ptr_R_EditFile)
rc = ptr_R_EditFile(filename);
else {
sprintf(editcmd, "%s %s", cmd, filename);
rc = R_system(editcmd);
}
if (rc != 0)
errorcall(call, _("problem with running editor %s"), cmd);
#endif
if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL)
errorcall(call, _("unable to open file to read"));
R_ParseCnt = 0;
x = PROTECT(R_ParseFile(fp, -1, &status));
fclose(fp);
if (status != PARSE_OK)
errorcall(call,
_("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseError);
R_ResetConsole();
{ /* can't just eval(x) here */
int j, n;
SEXP tmp = R_NilValue;
n = LENGTH(x);
for (j = 0 ; j < n ; j++)
tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv);
x = tmp;
}
if (TYPEOF(x) == CLOSXP && envir != R_NilValue)
SET_CLOENV(x, envir);
UNPROTECT(2);
vmaxset(vmaxsave);
return (x);
}