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;
}
}
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;
}
}
