SEXP do_system(SEXP call, SEXP op, SEXP args, SEXP rho)
{
rpipe *fp;
char buf[INTERN_BUFSIZE];
const char *fout = "", *ferr = "";
int vis = 0, flag = 2, i = 0, j, ll = 0;
SEXP cmd, fin, Stdout, Stderr, tlist = R_NilValue, tchar, rval;
int timeout = 0, timedout = 0;
checkArity(op, args);
cmd = CAR(args);
if (!isString(cmd) || LENGTH(cmd) != 1)
errorcall(call, _("character string expected as first argument"));
args = CDR(args);
flag = asInteger(CAR(args)); args = CDR(args);
if (flag >= 20) {vis = -1; flag -= 20;}
else if (flag >= 10) {vis = 0; flag -= 10;}
else vis = 1;
fin = CAR(args);
if (!isString(fin))
errorcall(call, _("character string expected as third argument"));
args = CDR(args);
Stdout = CAR(args);
args = CDR(args);
Stderr = CAR(args);
args = CDR(args);
timeout = asInteger(CAR(args));
if (timeout == NA_INTEGER || timeout < 0 || timeout > 2000000)
/* the limit could be increased, but not much as in milliseconds it
has to fit into a 32-bit unsigned integer */
errorcall(call, _("invalid '%s' argument"), "timeout");
if (timeout && !flag)
errorcall(call, "Timeout with background running processes is not supported.");
if (CharacterMode == RGui) {
/* This is a rather conservative approach: if
Rgui is launched from a console window it does have
standard handles -- but users might well not expect that.
*/
SetStdHandle(STD_INPUT_HANDLE, INVALID_HANDLE_VALUE);
SetStdHandle(STD_OUTPUT_HANDLE, INVALID_HANDLE_VALUE);
SetStdHandle(STD_ERROR_HANDLE, INVALID_HANDLE_VALUE);
if (TYPEOF(Stdout) == STRSXP) fout = CHAR(STRING_ELT(Stdout, 0));
if (TYPEOF(Stderr) == STRSXP) ferr = CHAR(STRING_ELT(Stderr, 0));
} else {
if (flag == 2) flag = 1; /* ignore std.output.on.console */
if (TYPEOF(Stdout) == STRSXP) fout = CHAR(STRING_ELT(Stdout, 0));
else if (asLogical(Stdout) == 0) fout = NULL;
if (TYPEOF(Stderr) == STRSXP) ferr = CHAR(STRING_ELT(Stderr, 0));
else if (asLogical(Stderr) == 0) ferr = NULL;
}
if (flag < 2) { /* Neither intern = TRUE nor
show.output.on.console for Rgui */
ll = runcmd_timeout(CHAR(STRING_ELT(cmd, 0)),
getCharCE(STRING_ELT(cmd, 0)),
flag, vis, CHAR(STRING_ELT(fin, 0)), fout, ferr,
timeout, &timedout);
} else {
/* read stdout +/- stderr from pipe */
int m = 0;
if(flag == 2 /* show on console */ || CharacterMode == RGui) m = 3;
if(TYPEOF(Stderr) == LGLSXP)
m = asLogical(Stderr) ? 2 : 0;
if(m && TYPEOF(Stdout) == LGLSXP && asLogical(Stdout)) m = 3;
fp = rpipeOpen(CHAR(STRING_ELT(cmd, 0)), getCharCE(STRING_ELT(cmd, 0)),
vis, CHAR(STRING_ELT(fin, 0)), m, fout, ferr, timeout);
if (!fp) {
/* If intern = TRUE generate an error */
if (flag == 3) error(runerror());
ll = NOLAUNCH;
} else {
/* FIXME: use REPROTECT */
if (flag == 3) {
PROTECT(tlist);
/* honour intern = FALSE, ignore.stdout = TRUE */
if (m > 0 ||
(!(TYPEOF(Stdout) == LGLSXP && !asLogical(Stdout))))
for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++) {
ll = strlen(buf) - 1;
if ((ll >= 0) && (buf[ll] == '\n')) buf[ll] = '\0';
tchar = mkChar(buf);
UNPROTECT(1); /* tlist */
PROTECT(tlist = CONS(tchar, tlist));
}
} else {
for (i = 0; rpipeGets(fp, buf, INTERN_BUFSIZE); i++)
R_WriteConsole(buf, strlen(buf));
}
ll = rpipeClose(fp, &timedout);
}
}
if (timedout) {
ll = 124;
warningcall(R_NilValue, _("command '%s' timed out"),
CHAR(STRING_ELT(cmd, 0)));
} else if (flag == 3 && ll) {
warningcall(R_NilValue,
_("running command '%s' had status %d"),
CHAR(STRING_ELT(cmd, 0)), ll);
}
if (flag == 3) { /* intern = TRUE: convert pairlist to list */
PROTECT(rval = allocVector(STRSXP, i));
for (j = (i - 1); j >= 0; j--) {
SET_STRING_ELT(rval, j, CAR(tlist));
tlist = CDR(tlist);
}
if(ll) {
SEXP lsym = install("status");
setAttrib(rval, lsym, ScalarInteger(ll));
}
UNPROTECT(2);
return rval;
} else {
rval = ScalarInteger(ll);
R_Visible = 0;
return rval;
}
}
/*
finput is either NULL or the name of a file from which to
redirect stdin for the child.
visible = -1, 0, 1 for hide, minimized, default
io = 0 to read stdout from pipe, 1 to write to pipe,
2 to read stderr from pipe,
3 to read both stdout and stderr from pipe.
*/
rpipe * rpipeOpen(const char *cmd, cetype_t enc, int visible,
const char *finput, int io,
const char *fout, const char *ferr)
{
rpipe *r;
HANDLE hTHIS, hIN, hOUT, hERR, hReadPipe, hWritePipe;
DWORD id;
BOOL res;
int close1 = 0, close2 = 0, close3 = 0;
if (!(r = (rpipe *) malloc(sizeof(struct structRPIPE)))) {
strcpy(RunError, _("Insufficient memory (rpipeOpen)"));
return NULL;
}
r->active = 0;
r->pi.hProcess = NULL;
r->thread = NULL;
res = CreatePipe(&hReadPipe, &hWritePipe, NULL, 0);
if (res == FALSE) {
rpipeClose(r);
strcpy(RunError, "CreatePipe failed");
return NULL;
}
if(io == 1) { /* pipe for R to write to */
hTHIS = GetCurrentProcess();
r->read = hReadPipe;
DuplicateHandle(hTHIS, hWritePipe, hTHIS, &r->write,
0, FALSE, DUPLICATE_SAME_ACCESS);
CloseHandle(hWritePipe);
CloseHandle(hTHIS);
/* This sends stdout and stderr to NUL: */
pcreate(cmd, enc, 1, visible,
r->read, INVALID_HANDLE_VALUE, INVALID_HANDLE_VALUE,
&(r->pi));
r->active = 1;
if (!r->pi.hProcess) return NULL; else return r;
}
/* pipe for R to read from */
hTHIS = GetCurrentProcess();
r->write = hWritePipe;
DuplicateHandle(hTHIS, hReadPipe, hTHIS, &r->read,
0, FALSE, DUPLICATE_SAME_ACCESS);
CloseHandle(hReadPipe);
CloseHandle(hTHIS);
hIN = getInputHandle(finput); /* a file or (usually NUL:) */
if (hIN && finput && finput[0]) close1 = 1;
if ((io == 0 || io == 3))
hOUT = r->write;
else {
if (fout && fout[0]) close2 = 1;
hOUT = getOutputHandle(fout, 0);
}
if (io >= 2)
hERR = r->write;
else {
if (ferr && ferr[0]) close3 = 1;
hERR = getOutputHandle(ferr, 1);
}
pcreate(cmd, enc, 0, visible, hIN, hOUT, hERR, &(r->pi));
if (close1) CloseHandle(hIN);
if (close2) CloseHandle(hOUT);
if (close3) CloseHandle(hERR);
r->active = 1;
if (!r->pi.hProcess)
return NULL;
if (!(r->thread = CreateThread(NULL, 0, threadedwait, r, 0, &id))) {
rpipeClose(r);
strcpy(RunError, "CreateThread failed");
return NULL;
}
return r;
}
