| /* |
| * R : A Computer Language for Statistical Data Analysis |
| * Copyright (C) 1995, 1996 Robert Gentleman and Ross Ihaka |
| * Copyright (C) 1997--2017 The R Core Team |
| * |
| * This program is free software; you can redistribute it and/or modify |
| * it under the terms of the GNU General Public License as published by |
| * the Free Software Foundation; either version 2 of the License, or |
| * (at your option) any later version. |
| * |
| * This program is distributed in the hope that it will be useful, |
| * but WITHOUT ANY WARRANTY; without even the implied warranty of |
| * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| * GNU General Public License for more details. |
| * |
| * You should have received a copy of the GNU General Public License |
| * along with this program; if not, a copy is available at |
| * https://www.R-project.org/Licenses/ |
| */ |
| |
| /* <UTF8> |
| char here is mainly handled as a whole string. |
| Does handle file names. |
| Chopping final \n is OK in UTF-8. |
| */ |
| |
| |
| /* See system.txt for a description of functions */ |
| |
| #ifdef HAVE_CONFIG_H |
| # include <config.h> |
| #endif |
| |
| #define R_USE_SIGNALS 1 |
| #include <Defn.h> |
| #include <Internal.h> |
| #include <Fileio.h> |
| #include <Rmath.h> /* for fround */ |
| #include "Runix.h" |
| |
| #ifdef HAVE_UNISTD_H |
| # include <unistd.h> |
| #endif |
| |
| #ifndef HAVE_GETRUSAGE |
| # ifdef HAVE_SYS_TIME_H |
| # include <sys/times.h> |
| # endif |
| #endif |
| |
| #ifdef HAVE_FCNTL_H |
| # include <fcntl.h> |
| #endif |
| |
| #if defined(HAVE_SYS_RESOURCE_H) && defined(HAVE_GETRUSAGE) |
| /* on macOS it seems sys/resource.h needs sys/time.h first */ |
| # include <sys/time.h> |
| # include <sys/resource.h> |
| #endif |
| |
| #include <errno.h> |
| |
| /* |
| * 4) INITIALIZATION AND TERMINATION ACTIONS |
| */ |
| |
| attribute_hidden |
| FILE *R_OpenInitFile(void) |
| { |
| char buf[PATH_MAX], *home, *p = getenv("R_PROFILE_USER"); |
| FILE *fp; |
| |
| fp = NULL; |
| if (LoadInitFile) { |
| if(p) { |
| if(!*p) return NULL; /* set to "" */ |
| return R_fopen(R_ExpandFileName(p), "r"); |
| } |
| if((fp = R_fopen(".Rprofile", "r"))) |
| return fp; |
| if((home = getenv("HOME")) == NULL) |
| return NULL; |
| snprintf(buf, PATH_MAX, "%s/.Rprofile", home); |
| if((fp = R_fopen(buf, "r"))) |
| return fp; |
| } |
| return fp; |
| } |
| /* |
| * R_CleanUp is interface-specific |
| */ |
| |
| /* |
| * 5) FILESYSTEM INTERACTION |
| */ |
| |
| |
| /* |
| * R_ShowFiles is interface-specific |
| */ |
| |
| /* |
| * R_ChooseFile is interface-specific |
| */ |
| |
| #if defined(HAVE_LIBREADLINE) && defined(HAVE_TILDE_EXPAND_WORD) |
| char *R_ExpandFileName_readline(const char *s, char *buff); /* sys-std.c */ |
| #endif |
| |
| static char newFileName[PATH_MAX]; |
| static int HaveHOME=-1; |
| static char UserHOME[PATH_MAX]; |
| |
| /* Only interpret inputs of the form ~ and ~/... */ |
| static const char *R_ExpandFileName_unix(const char *s, char *buff) |
| { |
| char *p; |
| |
| if(s[0] != '~') return s; |
| if(strlen(s) > 1 && s[1] != '/') return s; |
| if(HaveHOME < 0) { |
| p = getenv("HOME"); |
| if(p && *p && (strlen(p) < PATH_MAX)) { |
| strcpy(UserHOME, p); |
| HaveHOME = 1; |
| } else |
| HaveHOME = 0; |
| } |
| if(HaveHOME > 0 && (strlen(UserHOME) + strlen(s+1) < PATH_MAX)) { |
| strcpy(buff, UserHOME); |
| strcat(buff, s+1); |
| return buff; |
| } else return s; |
| } |
| |
| /* tilde_expand (in libreadline) mallocs storage for its return value. |
| The R entry point does not require that storage to be freed, so we |
| copy the value to a static buffer, to void a memory leak in R<=1.6.0. |
| |
| This is not thread-safe, but as R_ExpandFileName is a public entry |
| point (in R-exts.texi) it will need to deprecated and replaced by a |
| version which takes a buffer as an argument. |
| |
| BDR 10/2002 |
| */ |
| |
| extern Rboolean UsingReadline; |
| |
| const char *R_ExpandFileName(const char *s) |
| { |
| #if defined(HAVE_LIBREADLINE) && defined(HAVE_TILDE_EXPAND_WORD) |
| if(UsingReadline) { |
| const char * c = R_ExpandFileName_readline(s, newFileName); |
| /* we can return the result only if tilde_expand is not broken */ |
| if (!c || c[0]!='~' || (c[1]!='\0' && c[1]!='/')) |
| return c; |
| } |
| #endif |
| return R_ExpandFileName_unix(s, newFileName); |
| } |
| |
| |
| /* |
| * 7) PLATFORM DEPENDENT FUNCTIONS |
| */ |
| |
| SEXP attribute_hidden do_machine(SEXP call, SEXP op, SEXP args, SEXP env) |
| { |
| checkArity(op, args); |
| return mkString("Unix"); |
| } |
| |
| # ifdef HAVE_SYS_TIMES_H |
| # include <sys/times.h> /* times */ |
| # endif |
| |
| static double clk_tck, StartTime; |
| |
| void R_setStartTime(void) |
| { |
| #ifdef HAVE_SYSCONF |
| clk_tck = (double) sysconf(_SC_CLK_TCK); |
| #else |
| # ifndef CLK_TCK |
| /* this is in ticks/second, generally 60 on BSD style Unix, 100? on SysV |
| */ |
| # ifdef HZ |
| # define CLK_TCK HZ |
| # else |
| # define CLK_TCK 60 |
| # endif |
| # endif /* not CLK_TCK */ |
| clk_tck = (double) CLK_TCK; |
| #endif |
| /* printf("CLK_TCK = %d\n", CLK_TCK); */ |
| StartTime = currentTime(); |
| } |
| |
| /* NOTE |
| This used to use times() for elapsed times, which is measured in |
| clock ticks (which can overflow). It is possible this version uses |
| time() and so is in seconds. But even Cygwin has gettimeofday. |
| */ |
| attribute_hidden |
| void R_getProcTime(double *data) |
| { |
| /* docs say this is rounded to the nearest ms */ |
| double et = currentTime() - StartTime; |
| data[2] = 1e-3 * rint(1000*et); |
| #ifdef HAVE_GETRUSAGE |
| /* all known current OSes */ |
| struct rusage self, children; |
| getrusage(RUSAGE_SELF, &self); |
| getrusage(RUSAGE_CHILDREN, &children); |
| data[0] = (double) self.ru_utime.tv_sec + |
| 1e-3 * (self.ru_utime.tv_usec/1000); |
| data[1] = (double) self.ru_stime.tv_sec + |
| 1e-3 * (self.ru_stime.tv_usec/1000); |
| data[3] = (double) children.ru_utime.tv_sec + |
| 1e-3 * (children.ru_utime.tv_usec/1000); |
| data[4] = (double) children.ru_stime.tv_sec + |
| 1e-3 * (children.ru_stime.tv_usec/1000); |
| #else |
| /* Not known to be currently used */ |
| struct tms timeinfo; |
| times(&timeinfo); |
| data[0] = fround(timeinfo.tms_utime / clk_tck, 3); |
| data[1] = fround(timeinfo.tms_stime / clk_tck, 3); |
| data[3] = fround(timeinfo.tms_cutime / clk_tck, 3); |
| data[4] = fround(timeinfo.tms_cstime / clk_tck, 3); |
| #endif |
| } |
| |
| /* used in memory.c */ |
| /* FIXME: maybe should try to find the increment for getrusage */ |
| attribute_hidden |
| double R_getClockIncrement(void) |
| { |
| return 1.0 / clk_tck; |
| } |
| |
| |
| #ifdef HAVE_SYS_WAIT_H |
| # include <sys/wait.h> |
| #endif |
| |
| /* The timeout support is inspired by timeout utility from coreutils. |
| However, here the child process creates a new process group rather than |
| the parent (R) process, because changing the group leader for the whole |
| of R might have undesirable consequences. According to comments in |
| coreutils, this could lead to issues with propagating signals between |
| foreground and background process groups. Like with coreutils, the |
| timeout is not always enforced: an external application can run longer |
| than the timeout when it creates a new process group or when it spawns a |
| child process and exits without waiting for it to finish (becomes a |
| daemon). This implementation only works for processes that do not read |
| from the standard input - the new process group is always created, and |
| hence the executed process can no longer access the terminal. To prevent |
| interference with job control, the new process is thus started with |
| standard input redirected from /dev/null. Note that while the timeout |
| utility allows to run processes also without creating the new group |
| (option `foreground`), that approach would interfere with job control in |
| "/bin/sh" that is documented to be used by the R system call. There does |
| not seem to be a simple way to address this issue, and hence interactive |
| applications cannot be executed with timeout (and note the same issues |
| arise when timeout utility is used with /bin/sh). |
| |
| Currently we only have a single global structure and hence only one call |
| to R_popen_timeout/R_system_timeout may be active at the same time. A more |
| general implementation could use a linked list and identify entries by |
| file pointer and child pid. |
| |
| Background jobs (ending with &) are not supported. */ |
| |
| #define KILL_SIGNAL1 SIGINT |
| #define KILL_SIGNAL2 SIGTERM |
| #define KILL_SIGNAL3 SIGKILL |
| #define EMERGENCY_TIMEOUT 20 |
| |
| /* The child processes are sent KILL_SIGNAL1 after the specified timeout. |
| As a backup, KILL_SIGNAL2 would be sent after additional EMERGENCY_TIMEOUT |
| seconds. As a backup of the backup, KILL_SIGNAL3 would be sent after yet |
| additional EMERGENCY_TIMEOUT seconds. |
| |
| SIGINT is used first because it seems to be handled better by applications: |
| applications happen to wait for child processes to terminate, and hence |
| their execution is included into getrusage/RUSAGE_CHILDREN (proc.time). |
| As follows from empirical observations, SIGTERM can sometimes terminate |
| applications that cannot be terminated by SIGINT. */ |
| |
| int kill_signals[] = { KILL_SIGNAL1, KILL_SIGNAL2, KILL_SIGNAL3 }; |
| static struct { |
| pid_t child_pid; |
| int timedout; /* set when the child has been timed out */ |
| int kill_attempts; /* 1 after sending KILL_SIGNAL1, etc */ |
| sigset_t oldset; |
| struct sigaction oldalrm, oldint, oldquit, oldhup, oldterm, oldttin, |
| oldttou, oldchld; |
| RCNTXT cntxt; /* for popen/pclose */ |
| FILE *fp; /* for popen/pclose, sanity check */ |
| } tost; |
| |
| static void timeout_handler(int sig); |
| static void timeout_init() |
| { |
| tost.child_pid = 0; |
| tost.timedout = 0; |
| tost.kill_attempts = 0; |
| sigprocmask(0, NULL, &tost.oldset); |
| sigaction(SIGALRM, NULL, &tost.oldalrm); |
| sigaction(SIGINT, NULL, &tost.oldint); |
| sigaction(SIGQUIT, NULL, &tost.oldquit); |
| sigaction(SIGHUP, NULL, &tost.oldhup); |
| sigaction(SIGTERM, NULL, &tost.oldterm); |
| sigaction(SIGTTIN, NULL, &tost.oldttin); |
| sigaction(SIGTTOU, NULL, &tost.oldttou); |
| sigaction(SIGCHLD, NULL, &tost.oldchld); |
| tost.fp = NULL; |
| |
| /* install handler */ |
| struct sigaction sa; |
| sigemptyset(&sa.sa_mask); |
| sa.sa_handler = &timeout_handler; |
| sa.sa_flags = SA_RESTART; |
| sigaction(SIGALRM, &sa, NULL); |
| sigaction(SIGINT, &sa, NULL); |
| sigaction(SIGQUIT, &sa, NULL); |
| sigaction(SIGHUP, &sa, NULL); |
| sigaction(SIGTERM, &sa, NULL); |
| sigaction(SIGCHLD, &sa, NULL); |
| } |
| |
| static void timeout_cleanup_set(sigset_t *ss) |
| { |
| sigemptyset(ss); |
| sigaddset(ss, SIGALRM); |
| sigaddset(ss, SIGINT); |
| sigaddset(ss, SIGQUIT); |
| sigaddset(ss, SIGHUP); |
| sigaddset(ss, SIGTERM); |
| sigaddset(ss, SIGTTIN); |
| sigaddset(ss, SIGTTOU); |
| sigaddset(ss, SIGCHLD); |
| } |
| |
| static void timeout_cleanup() |
| { |
| sigset_t ss; |
| timeout_cleanup_set(&ss); |
| sigprocmask(SIG_BLOCK, &ss, NULL); |
| alarm(0); /* clear alarm */ |
| |
| sigaction(SIGALRM, &tost.oldalrm, NULL); |
| sigaction(SIGINT, &tost.oldint, NULL); |
| sigaction(SIGQUIT, &tost.oldquit, NULL); |
| sigaction(SIGHUP, &tost.oldhup, NULL); |
| sigaction(SIGTERM, &tost.oldterm, NULL); |
| sigaction(SIGTTIN, &tost.oldttin, NULL); |
| sigaction(SIGTTOU, &tost.oldttou, NULL); |
| sigaction(SIGCHLD, &tost.oldchld, NULL); |
| |
| sigprocmask(SIG_SETMASK, &tost.oldset, NULL); |
| } |
| |
| static void timeout_handler(int sig) |
| { |
| if (sig == SIGCHLD) |
| return; /* needed for sigsuspend() to be interrupted */ |
| if (tost.child_pid > 0 && sig == SIGALRM) { |
| tost.timedout = 1; |
| if (tost.kill_attempts < 3) { |
| sig = kill_signals[tost.kill_attempts]; |
| if (tost.kill_attempts < 2) { |
| int saveerrno = errno; |
| alarm(EMERGENCY_TIMEOUT); |
| errno = saveerrno; |
| } |
| tost.kill_attempts++; |
| } else |
| sig = KILL_SIGNAL1; /* should not happen */ |
| } |
| if (tost.child_pid > 0) { |
| /* parent, received a signal */ |
| |
| kill(tost.child_pid, sig); |
| /* NOTE: don't signal the group and don't send SIGCONT |
| for interactive jobs */ |
| int saveerrno = errno; |
| /* on macOS, killpg fails with EPERM for groups with zombies */ |
| killpg(tost.child_pid, sig); |
| errno = saveerrno; |
| if (sig != SIGKILL && sig != SIGCONT) { |
| kill(tost.child_pid, SIGCONT); |
| saveerrno = errno; |
| /* on macOS, killpg fails with EPERM for groups with zombies */ |
| killpg(tost.child_pid, SIGCONT); |
| errno = saveerrno; |
| } |
| } else if (tost.child_pid == 0) { |
| /* child */ |
| _exit(128 + sig); /* arbitrary status, such as in timeout utility */ |
| } |
| /* tost.child_pid is -1 when child process no longer exists */ |
| } |
| |
| static pid_t timeout_wait(int *wstatus) |
| { |
| pid_t wres; |
| |
| /* make sure we do not accidentally send signals to a new process |
| with re-used pid from the child */ |
| sigset_t ss; |
| timeout_cleanup_set(&ss); |
| sigset_t unblocked_ss; |
| sigprocmask(SIG_BLOCK, &ss, &unblocked_ss); |
| |
| int saveerrno = errno; |
| while((wres = waitpid(tost.child_pid, wstatus, WNOHANG)) == 0) |
| sigsuspend(&unblocked_ss); |
| |
| if (errno == EINTR) |
| /* EINTR is not really an error but expected situation here, however, |
| R's "system" call would report any non-zero errno as an error. */ |
| errno = saveerrno; |
| if (wres == tost.child_pid) |
| tost.child_pid = -1; /* the process no longer exists */ |
| timeout_cleanup(); |
| return wres; |
| } |
| |
| static void timeout_cend(void *data) |
| { |
| if (tost.child_pid > 0) { |
| timeout_handler(SIGALRM); |
| timeout_wait(NULL); |
| } |
| timeout_cleanup(); |
| } |
| |
| /* Fork with blocked SIGCHLD to make sure that tost.child_pid is set |
| in the parent before the signal is received. Also makes sure |
| SIGCHLD is unblocked in the parent after the call. */ |
| static void timeout_fork() |
| { |
| sigset_t css; |
| sigemptyset(&css); |
| sigaddset(&css, SIGCHLD); |
| sigprocmask(SIG_BLOCK, &css, NULL); |
| tost.child_pid = fork(); |
| sigprocmask(SIG_UNBLOCK, &css, NULL); |
| } |
| |
| /* R_popen_timeout, R_pclose_timeout - a partial implementation of popen/close |
| with support for timeout. The POSIX/Unix popen/pclose cannot be re-used, |
| because the PID of the child process is not accessible via POSIX API. |
| |
| This simple implementation only supports a single pipe to be open at a time |
| and R_system_timeout cannot be used at the same time. |
| |
| It does not support close-on-exec ("e" flag). |
| A pipe opened with R_popen_timeout cannot be closed by pclose. |
| A pipe opened with popen cannot be closed by R_pclose_timeout. |
| Timeout is in seconds. After timing out, the child process is interrupted. |
| */ |
| static FILE *R_popen_timeout(const char *cmd, const char *type, int timeout) |
| { |
| /* close-on-exec is not supported */ |
| if (!type || type[1] || (type[0] != 'r' && type[0] != 'w')) { |
| errno = EINVAL; |
| return NULL; |
| } |
| int doread = (type[0] == 'r'); |
| int pipefd[2]; |
| int parent_end, child_end; |
| if (pipe(pipefd) < 0) |
| return NULL; |
| if (doread) { |
| parent_end = pipefd[0]; |
| child_end = pipefd[1]; |
| } else { |
| parent_end = pipefd[1]; |
| child_end = pipefd[0]; |
| } |
| |
| /* Earlier version of R would block SIGPROF here on old Apple systems |
| following Luke's recommendation on how to fix PR#1140 (see R_open, |
| R_system). */ |
| |
| timeout_init(); |
| |
| /* set up a context to recover from R error between popen and pclose */ |
| begincontext(&tost.cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, |
| R_NilValue, R_NilValue); |
| tost.cntxt.cenddata = NULL; |
| tost.cntxt.cend = &timeout_cend; |
| |
| signal(SIGTTIN, SIG_IGN); |
| signal(SIGTTOU, SIG_IGN); |
| timeout_fork(); |
| |
| if (tost.child_pid == 0) { |
| /* child */ |
| setpgid(0, 0); /* NOTE: don't create new group in interactive jobs */ |
| signal(SIGTTIN, SIG_DFL); |
| signal(SIGTTOU, SIG_DFL); |
| dup2(child_end, doread ? 1 : 0); |
| close(child_end); |
| close(parent_end); |
| close(doread ? 0 : 1); |
| /* ensure there is no read from terminal to avoid SIGTTIN */ |
| if (open("/dev/null", O_RDONLY) < 0) { |
| perror("Cannot open /dev/null for reading:"); |
| _exit(127); |
| } |
| execl("/bin/sh", "sh", "-c", cmd, (char *)NULL); |
| _exit(127); /* execl failed */ |
| } else if (tost.child_pid > 0) { |
| /* parent */ |
| close(child_end); |
| tost.fp = fdopen(parent_end, type); |
| if (!tost.fp) { |
| close(parent_end); |
| return NULL; |
| } |
| |
| sigset_t ss; |
| sigemptyset(&ss); |
| sigaddset(&ss, SIGALRM); |
| sigprocmask(SIG_UNBLOCK, &ss, NULL); |
| alarm(timeout); /* will get SIGALRM on timeout */ |
| |
| return tost.fp; |
| } else { |
| close(parent_end); |
| return NULL; |
| } |
| } |
| |
| int R_pclose_timeout(FILE *fp) |
| { |
| if (fp != tost.fp) |
| /* should not happen */ |
| error("Invalid file pointer in pclose"); |
| |
| /* Do not use fclose, because on Solaris it sets errno to "Invalid seek" |
| when the pipe is already closed (e.g. because of timeout). fclose would |
| not return an error, but it would set errno and the non-zero errno would |
| then be reported by R's "system" function. */ |
| int fd = fileno(fp); |
| if (fd >= 0) |
| close(fd); |
| |
| pid_t wres; |
| int wstatus; |
| |
| wres = timeout_wait(&wstatus); |
| endcontext(&tost.cntxt); |
| |
| if (wres < 0) |
| return -1; |
| return wstatus; |
| } |
| |
| /* Similar to system, but supports timeout in seconds. |
| Calls to R_system_timeout cannot be used when a pipe is open using |
| R_popen_timeout. |
| */ |
| static int R_system_timeout(const char *cmd, int timeout) |
| { |
| if (!cmd) |
| return R_system(cmd); |
| |
| /* Earlier version of R would block SIGPROF here on old Apple systems |
| following Luke's recommendation on how to fix PR#1140 (see R_open, |
| R_system). */ |
| |
| timeout_init(); |
| signal(SIGTTIN, SIG_IGN); |
| signal(SIGTTOU, SIG_IGN); |
| timeout_fork(); |
| |
| if (tost.child_pid == 0) { |
| /* child */ |
| close(0); |
| /* ensure there is no read from terminal to avoid SIGTTIN */ |
| if (open("/dev/null", O_RDONLY) < 0) { |
| perror("Cannot open /dev/null for reading:"); |
| _exit(127); |
| } |
| setpgid(0, 0); |
| signal(SIGTTIN, SIG_DFL); |
| signal(SIGTTOU, SIG_DFL); |
| |
| execl("/bin/sh", "sh", "-c", cmd, (char *)NULL); |
| _exit(127); /* execl failed */ |
| } else if (tost.child_pid > 0) { |
| /* parent */ |
| sigset_t ss; |
| sigemptyset(&ss); |
| sigaddset(&ss, SIGALRM); |
| sigprocmask(SIG_UNBLOCK, &ss, NULL); |
| alarm(timeout); /* will get SIGALRM on timeout */ |
| |
| int wstatus; |
| timeout_wait(&wstatus); |
| if (tost.child_pid != -1) |
| return -1; |
| #ifdef HAVE_SYS_WAIT_H |
| if (WIFEXITED(wstatus)) wstatus = WEXITSTATUS(wstatus); |
| #else |
| /* assume that this is shifted if a multiple of 256 */ |
| if ((wstatus % 256) == 0) wstatus = wstatus/256; |
| #endif |
| if (wstatus == -1) { |
| /* this means that system() failed badly - it didn't |
| even get to try to run the shell */ |
| warning(_("system call failed: %s"), strerror(errno)); |
| /* R system() is documented to return 127 on failure, and a lot of |
| code relies on that - it will misinterpret -1 as success */ |
| wstatus = 127; |
| } |
| return wstatus; |
| } else |
| return -1; |
| } |
| |
| static void warn_status(const char *cmd, int res) |
| { |
| if (!res) |
| return; |
| |
| if (errno) |
| /* FIXME: TK: non-zero errno is a sign of an error only when |
| a function that modified it also signals an error by its |
| return value, usually -1 or EOF. We should not be reporting |
| an error here (CERT ERR30-C).*/ |
| /* on Solaris, if the command ends with non-zero status and timeout |
| is 0, "Illegal seek" error is reported; the timeout version |
| works this around by using close(fileno) */ |
| warning(_("running command '%s' had status %d and error message '%s'"), |
| cmd, res, strerror(errno)); |
| else |
| warning(_("running command '%s' had status %d"), cmd, res); |
| } |
| |
| #define INTERN_BUFSIZE 8096 |
| SEXP attribute_hidden do_system(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP tlist = R_NilValue; |
| int intern = 0; |
| int timeout = 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")); |
| timeout = asInteger(CADDR(args)); |
| if (timeout == NA_INTEGER || timeout < 0) |
| error(_("invalid '%s' argument"), "timeout"); |
| const char *cmd = translateChar(STRING_ELT(CAR(args), 0)); |
| if (timeout > 0) { |
| /* command ending with & is not supported by timeout */ |
| const void *vmax = vmaxget(); |
| const char *c = translateCharUTF8(STRING_ELT(CAR(args), 0)); |
| int last_is_amp = 0; |
| int len = 0; |
| for(;*c; c += len) { |
| len = utf8clen(*c); |
| if (len == 1) { |
| if (*c == '&') |
| last_is_amp = 1; |
| else if (*c != ' ' && *c != '\t' && *c != '\r' && *c != '\n') |
| last_is_amp = 0; |
| } else |
| last_is_amp = 0; |
| } |
| if (last_is_amp) |
| error("Timeout with background running processes is not supported."); |
| vmaxset(vmax); |
| } |
| if (intern) { /* intern = TRUE */ |
| FILE *fp; |
| char *x = "r", |
| #ifdef HAVE_GETLINE |
| *buf = NULL; |
| size_t buf_len = 0; |
| #else |
| buf[INTERN_BUFSIZE]; |
| #endif |
| int i, j, res; |
| SEXP tchar, rval; |
| |
| PROTECT(tlist); |
| errno = 0; /* precaution */ |
| if (timeout == 0) |
| fp = R_popen(cmd, x); |
| else |
| fp = R_popen_timeout(cmd, x, timeout); |
| if(!fp) |
| error(_("cannot popen '%s', probable reason '%s'"), |
| cmd, strerror(errno)); |
| #ifdef HAVE_GETLINE |
| size_t read; |
| for(i = 0; (read = getline(&buf, &buf_len, fp)) != (size_t)-1; i++) { |
| if (buf[read - 1] == '\n') |
| #else |
| 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') |
| #endif |
| buf[read - 1] = '\0'; /* chop final CR */ |
| tchar = mkChar(buf); |
| UNPROTECT(1); |
| PROTECT(tlist = CONS(tchar, tlist)); |
| } |
| #ifdef HAVE_GETLINE |
| if (buf != NULL) |
| free(buf); |
| #endif |
| if (timeout == 0) |
| res = pclose(fp); |
| else |
| res = R_pclose_timeout(fp); |
| |
| /* On Solaris, pclose sometimes returns -1 and sets errno to ESPIPE |
| (Illegal seek). In that case, do_system reports 0 exit status and |
| displays a warning via warn_status. ESPIPE is not mentioned by |
| POSIX as possible outcome of pclose. */ |
| |
| #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")); |
| } |
| |
| if (timeout && tost.timedout) { |
| res = 124; |
| warning(_("command '%s' timed out after %ds"), cmd, timeout); |
| } else |
| warn_status(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); |
| int res; |
| if (timeout == 0) |
| res = R_system(cmd); |
| else |
| res = R_system_timeout(cmd, timeout); |
| if (res == 127) |
| warning(_("error in running command")); |
| if (timeout && tost.timedout) { |
| res = 124; |
| warning(_("command '%s' timed out after %ds"), cmd, timeout); |
| } |
| INTEGER(tlist)[0] = res; |
| #ifdef HAVE_AQUA |
| R_Busy(0); |
| #endif |
| UNPROTECT(1); |
| R_Visible = 0; |
| return tlist; |
| } |
| } |
| |
| #ifdef HAVE_SYS_UTSNAME_H |
| # include <sys/utsname.h> |
| |
| # ifdef HAVE_UNISTD_H |
| # include <unistd.h> |
| # endif |
| |
| # ifdef HAVE_PWD_H |
| # include <pwd.h> |
| # endif |
| |
| SEXP attribute_hidden do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| SEXP ans, ansnames; |
| struct utsname name; |
| char *login; |
| |
| checkArity(op, args); |
| PROTECT(ans = allocVector(STRSXP, 8)); |
| if(uname(&name) == -1) { |
| UNPROTECT(1); |
| return R_NilValue; |
| } |
| SET_STRING_ELT(ans, 0, mkChar(name.sysname)); |
| SET_STRING_ELT(ans, 1, mkChar(name.release)); |
| SET_STRING_ELT(ans, 2, mkChar(name.version)); |
| SET_STRING_ELT(ans, 3, mkChar(name.nodename)); |
| SET_STRING_ELT(ans, 4, mkChar(name.machine)); |
| login = getlogin(); |
| SET_STRING_ELT(ans, 5, login ? mkChar(login) : mkChar("unknown")); |
| #if defined(HAVE_PWD_H) && defined(HAVE_GETPWUID) && defined(HAVE_GETUID) |
| { |
| struct passwd *stpwd; |
| stpwd = getpwuid(getuid()); |
| SET_STRING_ELT(ans, 6, stpwd ? mkChar(stpwd->pw_name) : mkChar("unknown")); |
| } |
| #else |
| SET_STRING_ELT(ans, 6, mkChar("unknown")); |
| #endif |
| #if defined(HAVE_PWD_H) && defined(HAVE_GETPWUID) && defined(HAVE_GETEUID) |
| { |
| struct passwd *stpwd; |
| stpwd = getpwuid(geteuid()); |
| SET_STRING_ELT(ans, 7, stpwd ? mkChar(stpwd->pw_name) : mkChar("unknown")); |
| } |
| #else |
| SET_STRING_ELT(ans, 7, mkChar("unknown")); |
| #endif |
| PROTECT(ansnames = allocVector(STRSXP, 8)); |
| SET_STRING_ELT(ansnames, 0, mkChar("sysname")); |
| SET_STRING_ELT(ansnames, 1, mkChar("release")); |
| SET_STRING_ELT(ansnames, 2, mkChar("version")); |
| SET_STRING_ELT(ansnames, 3, mkChar("nodename")); |
| SET_STRING_ELT(ansnames, 4, mkChar("machine")); |
| SET_STRING_ELT(ansnames, 5, mkChar("login")); |
| SET_STRING_ELT(ansnames, 6, mkChar("user")); |
| SET_STRING_ELT(ansnames, 7, mkChar("effective_user")); |
| setAttrib(ans, R_NamesSymbol, ansnames); |
| UNPROTECT(2); |
| return ans; |
| } |
| #else /* not HAVE_SYS_UTSNAME_H */ |
| SEXP do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho) |
| { |
| warning(_("Sys.info() is not implemented on this system")); |
| return R_NilValue; /* -Wall */ |
| } |
| #endif /* not HAVE_SYS_UTSNAME_H */ |
| |
| /* The pointer here is used in the Mac GUI */ |
| #include <R_ext/eventloop.h> /* for R_PolledEvents */ |
| #include <R_ext/Rdynload.h> |
| |
| #define R_INTERFACE_PTRS 1 |
| #include <Rinterface.h> /* for ptr_R_ProcessEvents */ |
| |
| void R_ProcessEvents(void) |
| { |
| #ifdef HAVE_AQUA |
| /* disable ProcessEvents in child, |
| since we can't call CoreFoundation there. */ |
| if (ptr_R_ProcessEvents && !R_isForkedChild) ptr_R_ProcessEvents(); |
| #else |
| /* We might in due course want to always inhibit in a child */ |
| if (ptr_R_ProcessEvents) ptr_R_ProcessEvents(); |
| #endif |
| R_PolledEvents(); |
| if (cpuLimit > 0.0 || elapsedLimit > 0.0) { |
| double cpu, data[5]; |
| R_getProcTime(data); |
| cpu = data[0] + data[1] + data[3] + data[4]; |
| if (elapsedLimit > 0.0 && data[2] > elapsedLimit) { |
| cpuLimit = elapsedLimit = -1; |
| if (elapsedLimit2 > 0.0 && data[2] > elapsedLimit2) { |
| elapsedLimit2 = -1.0; |
| error(_("reached session elapsed time limit")); |
| } else |
| error(_("reached elapsed time limit")); |
| } |
| if (cpuLimit > 0.0 && cpu > cpuLimit) { |
| cpuLimit = elapsedLimit = -1; |
| if (cpuLimit2 > 0.0 && cpu > cpuLimit2) { |
| cpuLimit2 = -1.0; |
| error(_("reached session CPU time limit")); |
| } else |
| error(_("reached CPU time limit")); |
| } |
| } |
| } |
| |
| |
| /* |
| * helpers for start-up code |
| */ |
| |
| #ifdef __FreeBSD__ |
| # ifdef HAVE_FLOATINGPOINT_H |
| # include <floatingpoint.h> |
| # endif |
| #endif |
| |
| /* patch from Ei-ji Nakama for Intel compilers on ix86. |
| From http://www.nakama.ne.jp/memo/ia32_linux/R-2.1.1.iccftzdaz.patch.txt. |
| Since updated to include x86_64. |
| */ |
| #if (defined(__i386) || defined(__x86_64)) && defined(__INTEL_COMPILER) && __INTEL_COMPILER > 800 |
| #include <xmmintrin.h> |
| #include <pmmintrin.h> |
| #endif |
| |
| /* exported for Rembedded.h */ |
| void fpu_setup(Rboolean start) |
| { |
| if (start) { |
| #ifdef __FreeBSD__ |
| fpsetmask(0); |
| #endif |
| |
| #if (defined(__i386) || defined(__x86_64)) && defined(__INTEL_COMPILER) && __INTEL_COMPILER > 800 |
| _MM_SET_FLUSH_ZERO_MODE(_MM_FLUSH_ZERO_OFF); |
| _MM_SET_DENORMALS_ZERO_MODE(_MM_DENORMALS_ZERO_OFF); |
| #endif |
| } else { |
| #ifdef __FreeBSD__ |
| fpsetmask(~0); |
| #endif |
| } |
| } |