sys/0000755000176200001440000000000013706211112011062 5ustar liggesuserssys/NAMESPACE0000644000176200001440000000047113706107566012324 0ustar liggesusers# Generated by roxygen2: do not edit by hand export(as_text) export(eval_fork) export(eval_safe) export(exec_background) export(exec_internal) export(exec_status) export(exec_wait) export(r_background) export(r_internal) export(r_wait) export(windows_quote) useDynLib(sys,C_execute) useDynLib(sys,R_exec_status) sys/LICENSE0000644000176200001440000000005113676414705012106 0ustar liggesusersYEAR: 2019 COPYRIGHT HOLDER: Jeroen Ooms sys/man/0000755000176200001440000000000013676414705011660 5ustar liggesuserssys/man/exec_r.Rd0000644000176200001440000000331413676444545013422 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/callr.R \name{exec_r} \alias{exec_r} \alias{r_wait} \alias{r_internal} \alias{r_background} \title{Execute R from R} \usage{ r_wait( args = "--vanilla", std_out = stdout(), std_err = stderr(), std_in = NULL ) r_internal(args = "--vanilla", std_in = NULL, error = TRUE) r_background(args = "--vanilla", std_out = TRUE, std_err = TRUE, std_in = NULL) } \arguments{ \item{args}{command line arguments for R} \item{std_out}{if and where to direct child process \code{STDOUT}. Must be one of \code{TRUE}, \code{FALSE}, filename, connection object or callback function. See section on \emph{Output Streams} below for details.} \item{std_err}{if and where to direct child process \code{STDERR}. Must be one of \code{TRUE}, \code{FALSE}, filename, connection object or callback function. See section on \emph{Output Streams} below for details.} \item{std_in}{a file to send to stdin, usually an R script (see examples).} \item{error}{automatically raise an error if the exit status is non-zero.} } \description{ Convenience wrappers for \link{exec_wait} and \link{exec_internal} that shell out to R itself: \code{R.home("bin/R")}. } \details{ This is a simple but robust way to invoke R commands in a separate process. Use the \href{https://cran.r-project.org/package=callr}{callr} package if you need more sophisticated control over (multiple) R process jobs. } \examples{ # Hello world r_wait("--version") # Run some code r_wait(c('--vanilla', '-q', '-e', 'sessionInfo()')) # Run a script via stdin tmp <- tempfile() writeLines(c("x <- rnorm(100)", "mean(x)"), con = tmp) r_wait(std_in = tmp) } \seealso{ Other sys: \code{\link{exec}} } \concept{sys} sys/man/quote.Rd0000644000176200001440000000117613676414705013311 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/quote.R \name{quote} \alias{quote} \alias{windows_quote} \title{Quote arguments on Windows} \usage{ windows_quote(args) } \arguments{ \item{args}{character vector with arguments} } \description{ Quotes and escapes shell arguments when needed so that they get properly parsed by most Windows programs. This function is used internally to automatically quote system commands, the user should normally not quote arguments manually. } \details{ Algorithm is ported to R from \href{https://github.com/libuv/libuv/blob/v1.23.0/src/win/process.c#L454-L524}{libuv}. } sys/man/exec.Rd0000644000176200001440000001230413676444545013100 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/exec.R \name{exec} \alias{exec} \alias{exec_wait} \alias{sys} \alias{exec_background} \alias{exec_internal} \alias{exec_status} \title{Running System Commands} \usage{ exec_wait( cmd, args = NULL, std_out = stdout(), std_err = stderr(), std_in = NULL, timeout = 0 ) exec_background( cmd, args = NULL, std_out = TRUE, std_err = TRUE, std_in = NULL ) exec_internal(cmd, args = NULL, std_in = NULL, error = TRUE, timeout = 0) exec_status(pid, wait = TRUE) } \arguments{ \item{cmd}{the command to run. Either a full path or the name of a program on the \code{PATH}. On Windows this is automatically converted to a short path using \link{Sys.which}, unless wrapped in \code{\link[=I]{I()}}.} \item{args}{character vector of arguments to pass. On Windows these automatically get quoted using \link{windows_quote}, unless the value is wrapped in \code{\link[=I]{I()}}.} \item{std_out}{if and where to direct child process \code{STDOUT}. Must be one of \code{TRUE}, \code{FALSE}, filename, connection object or callback function. See section on \emph{Output Streams} below for details.} \item{std_err}{if and where to direct child process \code{STDERR}. Must be one of \code{TRUE}, \code{FALSE}, filename, connection object or callback function. See section on \emph{Output Streams} below for details.} \item{std_in}{file path to map std_in} \item{timeout}{maximum time in seconds} \item{error}{automatically raise an error if the exit status is non-zero.} \item{pid}{integer with a process ID} \item{wait}{block until the process completes} } \value{ \code{exec_background} returns a pid. \code{exec_wait} returns an exit code. \code{exec_internal} returns a list with exit code, stdout and stderr strings. } \description{ Powerful replacements for \link{system2} with support for interruptions, background tasks and fine grained control over \code{STDOUT} / \code{STDERR} binary or text streams. } \details{ Each value within the \code{args} vector will automatically be quoted when needed; you should not quote arguments yourself. Doing so anyway could lead to the value being quoted twice on some platforms. The \code{exec_wait} function runs a system command and waits for the child process to exit. When the child process completes normally (either success or error) it returns with the program exit code. Otherwise (if the child process gets aborted) R raises an error. The R user can interrupt the program by sending SIGINT (press ESC or CTRL+C) in which case the child process tree is properly terminated. Output streams \code{STDOUT} and \code{STDERR} are piped back to the parent process and can be sent to a connection or callback function. See the section on \emph{Output Streams} below for details. The \code{exec_background} function starts the program and immediately returns the PID of the child process. This is useful for running a server daemon or background process. Because this is non-blocking, \code{std_out} and \code{std_out} can only be \code{TRUE}/\code{FALSE} or a file path. The state of the process can be checked with \code{exec_status} which returns the exit status, or \code{NA} if the process is still running. If \code{wait = TRUE} then \code{exec_status} blocks until the process completes (but can be interrupted). The child can be killed with \link[tools:pskill]{tools::pskill}. The \code{exec_internal} function is a convenience wrapper around \code{exec_wait} which automatically captures output streams and raises an error if execution fails. Upon success it returns a list with status code, and raw vectors containing stdout and stderr data (use \link{as_text} for converting to text). } \section{Output Streams}{ The \code{std_out} and \code{std_err} parameters are used to control how output streams of the child are processed. Possible values for both foreground and background processes are: \itemize{ \item \code{TRUE}: print child output in R console \item \code{FALSE}: suppress output stream \item \emph{string}: name or path of file to redirect output } In addition the \code{exec_wait} function also supports the following \code{std_out} and \code{std_err} types: \itemize{ \item \emph{connection} a writable R \link{connection} object such as \link{stdout} or \link{stderr} \item \emph{function}: callback function with one argument accepting a raw vector (use \link{as_text} to convert to text). } When using \code{exec_background} with \code{std_out = TRUE} or \code{std_err = TRUE} on Windows, separate threads are used to print output. This works in RStudio and RTerm but not in RGui because the latter has a custom I/O mechanism. Directing output to a file is usually the safest option. } \examples{ # Run a command (interrupt with CTRL+C) status <- exec_wait("date") # Capture std/out out <- exec_internal("date") print(out$status) cat(as_text(out$stdout)) if(nchar(Sys.which("ping"))){ # Run a background process (daemon) pid <- exec_background("ping", "localhost") # Kill it after a while Sys.sleep(2) tools::pskill(pid) # Cleans up the zombie proc exec_status(pid) rm(pid) } } \seealso{ Base \link{system2} and \link{pipe} provide other methods for running a system command with output. Other sys: \code{\link{exec_r}} } \concept{sys} sys/man/deprecated.Rd0000644000176200001440000000064113676414705014250 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/deprecated.R \name{sys-deprecated} \alias{sys-deprecated} \alias{eval_safe} \alias{eval_fork} \title{Deprecated functions} \usage{ eval_safe(...) eval_fork(...) } \arguments{ \item{...}{see respective functions in the unix package} } \description{ These functions have moved into the \code{unix} package. Please update your references. } sys/man/as_text.Rd0000644000176200001440000000106413676444545013624 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/astext.R \name{as_text} \alias{as_text} \title{Convert Raw to Text} \usage{ as_text(x, ...) } \arguments{ \item{x}{vector to be converted to text} \item{...}{parameters passed to \link{readLines} such as \code{encoding} or \code{n}} } \description{ Parses a raw vector as lines of text. This is similar to \link{charToRaw} but splits output by (platform specific) linebreaks and allows for marking output with a given encoding. } \seealso{ \link[base:rawConversion]{base::charToRaw} } sys/DESCRIPTION0000644000176200001440000000223013706211112012565 0ustar liggesusersPackage: sys Type: Package Title: Powerful and Reliable Tools for Running System Commands in R Version: 3.4 Authors@R: c(person("Jeroen", "Ooms", role = c("aut", "cre"), email = "jeroen@berkeley.edu", comment = c(ORCID = "0000-0002-4035-0289")), person("Gábor", "Csárdi", , "csardi.gabor@gmail.com", role = "ctb")) Description: Drop-in replacements for the base system2() function with fine control and consistent behavior across platforms. Supports clean interruption, timeout, background tasks, and streaming STDIN / STDOUT / STDERR over binary or text connections. Arguments on Windows automatically get encoded and quoted to work on different locales. License: MIT + file LICENSE URL: https://github.com/jeroen/sys BugReports: https://github.com/jeroen/sys/issues Encoding: UTF-8 LazyData: true RoxygenNote: 7.1.1 Suggests: unix (>= 1.4), spelling, testthat Language: en-US NeedsCompilation: yes Packaged: 2020-07-22 19:23:54 UTC; jeroen Author: Jeroen Ooms [aut, cre] (), Gábor Csárdi [ctb] Maintainer: Jeroen Ooms Repository: CRAN Date/Publication: 2020-07-23 04:30:02 UTC sys/tests/0000755000176200001440000000000013676414705012247 5ustar liggesuserssys/tests/spelling.R0000644000176200001440000000020213676414705014201 0ustar liggesusersif(requireNamespace('spelling', quietly=TRUE)) spelling::spell_check_test(vignettes = TRUE, error = FALSE, skip_on_cran = TRUE) sys/tests/testthat/0000755000176200001440000000000013706211112014064 5ustar liggesuserssys/tests/testthat/test-stdout.R0000644000176200001440000000310613676414705016531 0ustar liggesuserscontext("stdout and stderr") test_that("test output for std_out equals TRUE/FALSE", { skip_if_not(packageVersion("base") >= "3.2.2", "skipping capture.output tests") is_windows <- identical("windows", tolower(Sys.info()[["sysname"]])) string <- "helloworld" if(is_windows){ output1 <- capture.output(res <- exec_wait('cmd', c('/C', 'echo', string))) output2 <- capture.output(res <- exec_wait('cmd', c('/C', 'echo', string), std_out = FALSE)) output3 <- capture.output(res <- exec_wait('cmd', c('/C', 'echo', string, ">&2"), std_out = FALSE), type = 'message') output4 <- capture.output(res <- exec_wait('cmd', c('/C', 'echo', string, ">&2"), std_out = FALSE, std_err = FALSE), type = 'message') } else { output1 <- capture.output(res <- exec_wait('echo', string)) output2 <- capture.output(res <- exec_wait('echo', string, std_out = FALSE)) command <- sprintf("echo %s >&2", string) output3 <- capture.output(res <- exec_wait("sh", c("-c", command)), type = 'message') output4 <- capture.output(res <- exec_wait("sh", c("-c", command), std_err = FALSE), type = 'message') } expect_equal(sub("\\W+$", "", output1), string) expect_equal(output2, character()) expect_equal(sub("\\W+$", "", output3), string) expect_equal(output4, character()) }) test_that("User supplied callback function", { skip_if_not(nchar(Sys.which('whoami')) > 0) user <- system2("whoami", stdout = TRUE) out <- NULL add <- function(x){ out <<- c(out, x) } res <- exec_wait('whoami', std_out = add) expect_equal(res, 0) expect_equal(as_text(out), user) }) sys/tests/testthat/test-nesting.R0000644000176200001440000000057313676414705016663 0ustar liggesuserscontext("nested jobs") test_that("Jobs can be nested", { skip_if_not(nchar(Sys.which('whoami')) > 0) res1 <- sys::exec_internal("whoami") expect_equal(res1$status, 0) user <- as_text(res1$stdout) res2 <- sys::r_internal(c('--silent', '-e', 'sys::exec_wait("whoami")')) expect_equal(res2$status, 0) output <- as_text(res2$stdout) expect_equal(output[2], user) }) sys/tests/testthat/test-encoding.R0000644000176200001440000000330613676414705016777 0ustar liggesuserscontext("test-encoding") support_unicode_path <- function(){ getRversion() >= "3.6.0" && grepl("(UTF-8|1252)", Sys.getlocale('LC_CTYPE')) } test_that("UTF-8 encoded text arguments", { txt <- readLines(system.file('utf8.txt', package = 'sys', mustWork = TRUE), encoding = 'UTF-8') res <- sys::exec_internal('echo', txt) expect_equal(res$status, 0) con <- rawConnection(res$stdout) output <- readLines(con, encoding = 'UTF-8') close(con) expect_equal(txt, output) }) test_that("UTF-8 filenames, binary data", { skip_if_not(support_unicode_path(), 'System does not support unicode paths') tmp <- paste(tempdir(), "\u0420\u0423\u0421\u0421\u041a\u0418\u0419.txt", sep = "/") tmp <- normalizePath(tmp, mustWork = FALSE) f <- file(tmp, 'wb') serialize(iris, f) close(f) expect_true(file.exists(tmp)) # As a file path res <- if(.Platform$OS.type == "windows"){ sys::exec_internal('cmd', c("/C", "type", tmp)) } else { sys::exec_internal('cat', tmp) } expect_equal(res$status, 0) expect_equal(unserialize(res$stdout), iris) }) test_that("UTF-8 filename as std_in", { skip_if_not(support_unicode_path(), 'System does not support unicode paths') input <- c("foo", "bar", "baz") txt <- readLines(system.file('utf8.txt', package = 'sys', mustWork = TRUE), encoding = 'UTF-8') tmp <- normalizePath(paste(tempdir(), txt, sep = "/"), mustWork = FALSE) f <- file(tmp, 'wb') writeBin(charToRaw(paste(input, collapse = "\n")), con = f, useBytes = TRUE) close(f) expect_true(file.exists(tmp)) res <- exec_internal('sort', std_in = tmp) expect_equal(res$status, 0) con <- rawConnection(res$stdout) output <- readLines(con) close(con) expect_equal(output, sort(input)) }) sys/tests/testthat/test-error.R0000644000176200001440000000262613676414705016346 0ustar liggesuserscontext("error handling") test_that("catching execution errors", { # Test that 'ping' is on the path skip_if_not(as.logical(nchar(Sys.which('ping'))), "ping utility is not available") # Ping has different args for each platform sysname <- tolower(Sys.info()[["sysname"]]) args <- switch(sysname, windows = c("-n", "2", "localhost"), darwin = c("-t2", "localhost"), sunos = c("-s", "localhost", "64", "2"), c("-c2", "localhost") #linux/default ) # Run ping expect_equal(exec_wait("ping", args, std_out = FALSE), 0) # Error for non existing program (win-builder gives a german error) expect_error(exec_wait("doesnotexist"), "Failed to execute.*(file|Datei)") expect_error(exec_background("doesnotexist"), "Failed to execute.*(file|Datei)") # Same without stdout expect_error(exec_wait("doesnotexist", std_out = FALSE, std_err = FALSE), "Failed to execute") expect_error(exec_background("doesnotexist", std_out = FALSE, std_err = FALSE), "Failed to execute") # Program error expect_is(exec_wait("ping", "999.999.999.999.999", std_err = FALSE, std_out = FALSE), "integer") expect_is(exec_background("ping", "999.999.999.999.999", std_err = FALSE, std_out = FALSE), "integer") # Program error with exec_internal expect_error(exec_internal('ping', "999.999.999.999.999")) out <- exec_internal('ping', "999.999.999.999.999", error = FALSE) expect_gt(out$status, 0) }) sys/tests/testthat/test-timeout.R0000644000176200001440000000115213676414705016674 0ustar liggesuserscontext("test-timeout") test_that("exec timeout works", { if(.Platform$OS.type == "windows"){ command = "ping" args = c("-n", "5", "localhost") } else { command = 'sleep' args = '5' } times <- system.time({ expect_error(exec_wait(command, args, timeout = 1.50, std_out = FALSE), "timeout") }) expect_gte(times[['elapsed']], 1.45) expect_lt(times[['elapsed']], 2.50) # Also try with exec_internal times <- system.time({ expect_error(exec_internal(command, args, timeout = 0.50), "timeout") }) expect_gte(times[['elapsed']], 0.45) expect_lt(times[['elapsed']], 1.50) }) sys/tests/testthat/test-stdin.R0000644000176200001440000000052313676414705016330 0ustar liggesuserscontext("test-stdin") test_that("streaming from stdin works", { tmp <- tempfile() input <- c("foo", "bar", "baz") writeLines(input, con = tmp) res <- exec_internal('sort', std_in = tmp) expect_equal(res$status, 0) con <- rawConnection(res$stdout) output <- readLines(con) close(con) expect_equal(output, sort(input)) }) sys/tests/testthat/test-quote.R0000644000176200001440000000142713676414705016350 0ustar liggesuserscontext("test-quote") # Test cases: https://github.com/libuv/libuv/blob/v1.23.0/src/win/process.c#L486-L502 test_that("windows quoting arguments", { input <- c('hello"world', 'hello""world', 'hello\\world', 'hello\\\\world', 'hello\\"world', 'hello\\\\"world', 'hello world\\', '') output <- c('"hello\\"world"', '"hello\\"\\"world"', 'hello\\world', 'hello\\\\world', '"hello\\\\\\"world"', '"hello\\\\\\\\\\"world"', '"hello world\\\\"', '""') expect_equal(windows_quote(input), output) if(.Platform$OS.type == 'windows'){ args <- c('/C', 'echo', 'foo bar') out1 <- exec_internal('cmd', args) out2 <- exec_internal('cmd', I(args)) expect_equal(as_text(out1$stdout), '"foo bar"') expect_equal(as_text(out2$stdout), 'foo bar') } }) sys/tests/testthat/test-binary.R0000644000176200001440000000401313676414705016471 0ustar liggesuserscontext("binary streams") test_that("copy a binary image", { is_windows <- identical("windows", tolower(Sys.info()[["sysname"]])) olddir <- getwd() on.exit(setwd(olddir)) setwd(tempdir()) buf <- serialize(rnorm(1e6), NULL) writeBin(buf, "input.bin") if(is_windows){ res1 <- exec_wait("cmd", c("/C", "type", "input.bin"), std_out = "out1.bin") res2 <- exec_wait("cmd", c("/C", "type", "input.bin", ">&2"), std_err = "out2.bin") pid1 <- exec_background("cmd", c("/C", "type", "input.bin"), std_out = "out3.bin") pid2 <- exec_background("cmd", c("/C", "type", "input.bin", ">&2"), std_err = "out4.bin") data1 <- exec_internal("cmd", c("/C", "type", "input.bin")) data2 <- exec_internal("cmd", c("/C", "type", "input.bin", ">&2")) writeBin(data1$stdout, "out5.bin") writeBin(data2$stderr, "out6.bin") } else { res1 <- exec_wait("cat", "input.bin", std_out = "out1.bin") res2 <- exec_wait("sh", c("-c", "cat input.bin >&2"), std_err = "out2.bin") pid1 <- exec_background("cat", "input.bin", std_out = "out3.bin") pid2 <- exec_background("sh", c("-c", "cat input.bin >&2"), std_err = "out4.bin") data1 <- exec_internal("cat", "input.bin") data2 <- exec_internal("sh", c("-c", "cat input.bin >&2")) writeBin(data1$stdout, "out5.bin") writeBin(data2$stderr, "out6.bin") } on.exit(tools::pskill(pid1), add = TRUE) on.exit(tools::pskill(pid2), add = TRUE) on.exit(unlink(sprintf("out%d.bin", 1:6)), add = TRUE) expect_equal(res1, 0) expect_equal(res2, 0) expect_equal(data1$status, 0) expect_equal(data2$status, 0) expect_is(pid1, "integer") expect_is(pid2, "integer") Sys.sleep(1) hash <- unname(tools::md5sum("input.bin")) expect_equal(hash, unname(tools::md5sum("out1.bin"))) expect_equal(hash, unname(tools::md5sum("out2.bin"))) expect_equal(hash, unname(tools::md5sum("out3.bin"))) expect_equal(hash, unname(tools::md5sum("out4.bin"))) expect_equal(hash, unname(tools::md5sum("out5.bin"))) expect_equal(hash, unname(tools::md5sum("out6.bin"))) }) sys/tests/testthat.R0000644000176200001440000000006213676414705014230 0ustar liggesuserslibrary(testthat) library(sys) test_check("sys") sys/src/0000755000176200001440000000000013706111104011651 5ustar liggesuserssys/src/exec.c0000644000176200001440000002115213706107004012746 0ustar liggesusers/* For SIG_BLOCK */ #ifndef _GNU_SOURCE #define _GNU_SOURCE #endif #include #include #include #include #include #include #include #include #include #include #ifdef __linux__ #include #endif #define r 0 #define w 1 #define waitms 200 #define IS_STRING(x) (Rf_isString(x) && Rf_length(x)) #define IS_TRUE(x) (Rf_isLogical(x) && Rf_length(x) && asLogical(x)) #define IS_FALSE(x) (Rf_isLogical(x) && Rf_length(x) && !asLogical(x)) void kill_process_group(int signum) { kill(0, SIGKILL); // kills process group raise(SIGKILL); // just to be sure } /* prevent potential handlers from cleaning up exit codes */ static void block_sigchld(){ sigset_t block_sigchld; sigemptyset(&block_sigchld); sigaddset(&block_sigchld, SIGCHLD); sigprocmask(SIG_BLOCK, &block_sigchld, NULL); } static void resume_sigchild(){ sigset_t block_sigchld; sigemptyset(&block_sigchld); sigaddset(&block_sigchld, SIGCHLD); sigprocmask(SIG_UNBLOCK, &block_sigchld, NULL); } /* check for system errors */ void bail_if(int err, const char * what){ if(err) Rf_errorcall(R_NilValue, "System failure for: %s (%s)", what, strerror(errno)); } /* In the fork we don't want to use the R API anymore */ void print_if(int err, const char * what){ if(err){ FILE *stream = fdopen(STDERR_FILENO, "w"); if(stream){ fprintf(stream, "System failure for: %s (%s)\n", what, strerror(errno)); fclose(stream); } } } void warn_if(int err, const char * what){ if(err) Rf_warningcall(R_NilValue, "System failure for: %s (%s)", what, strerror(errno)); } void set_pipe(int input, int output[2]){ print_if(dup2(output[w], input) < 0, "dup2() stdout/stderr"); close(output[r]); close(output[w]); } void pipe_set_read(int pipe[2]){ close(pipe[w]); bail_if(fcntl(pipe[r], F_SETFL, O_NONBLOCK) < 0, "fcntl() in pipe_set_read"); } void set_input(const char * file){ close(STDIN_FILENO); int fd = open(file, O_RDONLY); //lowest numbered FD should be 0 print_if(fd != 0, "open() set_input not equal to STDIN_FILENO"); } void set_output(int target, const char * file){ close(target); int fd = open(file, O_WRONLY | O_CREAT, S_IRUSR | S_IWUSR); print_if(fd < 0, "open() set_output"); if(fd == target) return; print_if(fcntl(fd, F_DUPFD, target) < 0, "fcntl() set_output"); close(fd); } void safe_close(int target){ set_output(target, "/dev/null"); } static void check_child_success(int fd, const char * cmd){ int child_errno; int n = read(fd, &child_errno, sizeof(child_errno)); close(fd); if (n) { Rf_errorcall(R_NilValue, "Failed to execute '%s' (%s)", cmd, strerror(child_errno)); } } /* Check for interrupt without long jumping */ void check_interrupt_fn(void *dummy) { R_CheckUserInterrupt(); } int pending_interrupt() { return !(R_ToplevelExec(check_interrupt_fn, NULL)); } int wait_for_action2(int fd1, int fd2){ short events = POLLIN | POLLERR | POLLHUP; struct pollfd ufds[2] = { {fd1, events, events}, {fd2, events, events} }; return poll(ufds, 2, waitms); } static void R_callback(SEXP fun, const char * buf, ssize_t len){ if(!isFunction(fun)) return; int ok; SEXP str = PROTECT(allocVector(RAWSXP, len)); memcpy(RAW(str), buf, len); SEXP call = PROTECT(LCONS(fun, LCONS(str, R_NilValue))); R_tryEval(call, R_GlobalEnv, &ok); UNPROTECT(2); } void print_output(int pipe_out[2], SEXP fun){ static ssize_t len; static char buffer[65336]; while ((len = read(pipe_out[r], buffer, sizeof(buffer))) > 0) R_callback(fun, buffer, len); } SEXP C_execute(SEXP command, SEXP args, SEXP outfun, SEXP errfun, SEXP input, SEXP wait, SEXP timeout){ //split process int block = asLogical(wait); int pipe_out[2]; int pipe_err[2]; int failure[2]; //setup execvp errno pipe bail_if(pipe(failure), "pipe(failure)"); //create io pipes only in blocking mode if(block){ bail_if(pipe(pipe_out) || pipe(pipe_err), "create pipe"); block_sigchld(); } //fork the main process pid_t pid = fork(); bail_if(pid < 0, "fork()"); //CHILD PROCESS if(pid == 0){ if(block){ //undo blocking in child (is this needed at all?) resume_sigchild(); // send stdout/stderr to pipes set_pipe(STDOUT_FILENO, pipe_out); set_pipe(STDERR_FILENO, pipe_err); } else { //redirect stdout in background process if(IS_STRING(outfun)){ set_output(STDOUT_FILENO, CHAR(STRING_ELT(outfun, 0))); } else if(!IS_TRUE(outfun)){ safe_close(STDOUT_FILENO); } //redirect stderr in background process if(IS_STRING(errfun)){ set_output(STDERR_FILENO, CHAR(STRING_ELT(errfun, 0))); } else if(!IS_TRUE(errfun)){ safe_close(STDERR_FILENO); } } //Linux only: set pgid and commit suicide when parent dies #ifdef PR_SET_PDEATHSIG setpgid(0, 0); prctl(PR_SET_PDEATHSIG, SIGTERM); signal(SIGTERM, kill_process_group); #endif //OSX: do NOT change pgid, so we receive signals from parent group // Set STDIN for child (default is /dev/null) if(IS_FALSE(input)){ //set stdin to unreadable /dev/null (O_WRONLY) safe_close(STDIN_FILENO); } else if(!IS_TRUE(input)){ set_input(IS_STRING(input) ? CHAR(STRING_ELT(input, 0)) : "/dev/null"); } //close all file descriptors before exit, otherwise they can segfault for (int i = 3; i < sysconf(_SC_OPEN_MAX); i++) { if(i != failure[w]){ int err = close(i); if(i > 200 && err < 0) break; } } //prepare execv int len = Rf_length(args); char * argv[len + 1]; argv[len] = NULL; for(int i = 0; i < len; i++){ argv[i] = strdup(CHAR(STRING_ELT(args, i))); } //execvp never returns if successful fcntl(failure[w], F_SETFD, FD_CLOEXEC); execvp(CHAR(STRING_ELT(command, 0)), argv); //execvp failed! Send errno to parent print_if(write(failure[w], &errno, sizeof(errno)) < 0, "write to failure pipe"); close(failure[w]); //exit() not allowed by CRAN. raise() should suffice //exit(EXIT_FAILURE); raise(SIGKILL); } //PARENT PROCESS: close(failure[w]); if (!block){ check_child_success(failure[r], CHAR(STRING_ELT(command, 0))); return ScalarInteger(pid); } //blocking: close write end of IO pipes pipe_set_read(pipe_out); pipe_set_read(pipe_err); //start timer struct timeval start, end; double elapsed, totaltime = REAL(timeout)[0]; gettimeofday(&start, NULL); //status -1 means error, 0 means running int status = 0; int killcount = 0; while (waitpid(pid, &status, WNOHANG) >= 0){ //check for timeout if(totaltime > 0){ gettimeofday(&end, NULL); elapsed = (end.tv_sec - start.tv_sec) + (end.tv_usec - start.tv_usec) / 1e6; if(killcount == 0 && elapsed > totaltime){ warn_if(kill(pid, SIGINT), "interrupt child"); killcount++; } else if(killcount == 1 && elapsed > (totaltime + 1)){ warn_if(kill(pid, SIGKILL), "force kill child"); killcount++; } } //for well behaved programs, SIGINT is automatically forwarded if(pending_interrupt()){ //pass interrupt to child. On second try we SIGKILL. warn_if(kill(pid, killcount ? SIGKILL : SIGINT), "kill child"); killcount++; } //make sure to empty the pipes, even if fun == NULL wait_for_action2(pipe_out[r], pipe_err[r]); //print stdout/stderr buffers print_output(pipe_out, outfun); print_output(pipe_err, errfun); } warn_if(close(pipe_out[r]), "close stdout"); warn_if(close(pipe_err[r]), "close stderr"); // check for execvp() error *after* closing pipes and zombie resume_sigchild(); check_child_success(failure[r], CHAR(STRING_ELT(command, 0))); if(WIFEXITED(status)){ return ScalarInteger(WEXITSTATUS(status)); } else { int signal = WTERMSIG(status); if(signal != 0){ if(killcount && elapsed > totaltime){ Rf_errorcall(R_NilValue, "Program '%s' terminated (timeout reached: %.2fsec)", CHAR(STRING_ELT(command, 0)), totaltime); } else { Rf_errorcall(R_NilValue, "Program '%s' terminated by SIGNAL (%s)", CHAR(STRING_ELT(command, 0)), strsignal(signal)); } } Rf_errorcall(R_NilValue, "Program terminated abnormally"); } } SEXP R_exec_status(SEXP rpid, SEXP wait){ int wstat = NA_INTEGER; pid_t pid = asInteger(rpid); do { int res = waitpid(pid, &wstat, WNOHANG); bail_if(res < 0, "waitpid()"); if(res) break; usleep(100*1000); } while (asLogical(wait) && !pending_interrupt()); return ScalarInteger(wstat); } sys/src/init.c0000644000176200001440000000102013676414705012774 0ustar liggesusers#include #include #include // for NULL #include /* .Call calls */ extern SEXP C_execute(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP R_exec_status(SEXP, SEXP); static const R_CallMethodDef CallEntries[] = { {"C_execute", (DL_FUNC) &C_execute, 7}, {"R_exec_status", (DL_FUNC) &R_exec_status, 2}, {NULL, NULL, 0} }; void R_init_sys(DllInfo *dll){ R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); } sys/src/win32/0000755000176200001440000000000013676414705012636 5ustar liggesuserssys/src/win32/exec.c0000644000176200001440000002715613676414705013741 0ustar liggesusers#include #include #include /* NOTES * On Windows, when wait = FALSE and std_out = TRUE or std_err = TRUE * then stdout / stderr get piped to background threads to simulate * the unix behavior of inheriting stdout/stderr in by child. */ #define IS_STRING(x) (Rf_isString(x) && Rf_length(x)) #define IS_TRUE(x) (Rf_isLogical(x) && Rf_length(x) && asLogical(x)) #define IS_FALSE(x) (Rf_isLogical(x) && Rf_length(x) && !asLogical(x)) /* copy from R source */ static const char *formatError(DWORD res){ static char buf[1000], *p; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS, NULL, res, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT), buf, 1000, NULL); p = buf+strlen(buf) -1; if(*p == '\n') *p = '\0'; p = buf+strlen(buf) -1; if(*p == '\r') *p = '\0'; p = buf+strlen(buf) -1; if(*p == '.') *p = '\0'; return buf; } /* check for system errors */ static void bail_if(int err, const char * what){ if(err) Rf_errorcall(R_NilValue, "System failure for: %s (%s)", what, formatError(GetLastError())); } static void warn_if(int err, const char * what){ if(err) Rf_warningcall(R_NilValue, "System failure for: %s (%s)", what, formatError(GetLastError())); } static BOOL can_create_job(){ BOOL is_job = 0; bail_if(!IsProcessInJob(GetCurrentProcess(), NULL, &is_job), "IsProcessInJob"); //Rprintf("Current process is %s\n", is_job ? "a job" : "not a job"); if(!is_job) return 1; JOBOBJECT_BASIC_LIMIT_INFORMATION info; bail_if(!QueryInformationJobObject(NULL, JobObjectBasicLimitInformation, &info, sizeof(JOBOBJECT_BASIC_LIMIT_INFORMATION), NULL), "QueryInformationJobObject"); return info.LimitFlags & JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK || info.LimitFlags & JOB_OBJECT_LIMIT_BREAKAWAY_OK; } /* Check for interrupt without long jumping */ static void check_interrupt_fn(void *dummy) { R_CheckUserInterrupt(); } int pending_interrupt() { return !(R_ToplevelExec(check_interrupt_fn, NULL)); } static int str_to_wchar(const char * str, wchar_t **wstr){ int len = MultiByteToWideChar( CP_UTF8 , 0 , str , -1, NULL , 0 ); *wstr = calloc(len, sizeof(*wstr)); MultiByteToWideChar( CP_UTF8 , 0 , str , -1, *wstr , len ); return len; } static wchar_t* sexp_to_wchar(SEXP args){ int total = 1; wchar_t *out = calloc(total, sizeof(*out)); wchar_t *space = NULL; int spacelen = str_to_wchar(" ", &space); for(int i = 0; i < Rf_length(args); i++){ wchar_t *arg = NULL; const char *str = CHAR(STRING_ELT(args, i)); int len = str_to_wchar(str, &arg); total = total + len; out = realloc(out, (total + spacelen) * sizeof(*out)); if(wcsncat(out, arg, len) == NULL) Rf_error("Failure in wcsncat"); if(i < Rf_length(args) - 1 && wcsncat(out, space, spacelen) == NULL) Rf_error("Failure in wcsncat"); free(arg); } return out; } static void R_callback(SEXP fun, const char * buf, ssize_t len){ if(!isFunction(fun)) return; int ok; SEXP str = PROTECT(allocVector(RAWSXP, len)); memcpy(RAW(str), buf, len); SEXP call = PROTECT(LCONS(fun, LCONS(str, R_NilValue))); R_tryEval(call, R_GlobalEnv, &ok); UNPROTECT(2); } //ReadFile blocks so no need to sleep() //Do NOT call RPrintf here because R is not thread safe! static DWORD WINAPI PrintPipe(HANDLE pipe, FILE *stream){ while(1){ unsigned long len; char buffer[65336]; if(!ReadFile(pipe, buffer, 65337, &len, NULL)){ int err = GetLastError(); if(err != ERROR_BROKEN_PIPE) Rprintf("ReadFile(pipe) failed (%d)\n", err); CloseHandle(pipe); ExitThread(0); return(0); } fprintf(stream, "%.*s", (int) len, buffer); } } static DWORD WINAPI PrintOut(HANDLE pipe){ return PrintPipe(pipe, stdout); } static DWORD WINAPI PrintErr(HANDLE pipe){ return PrintPipe(pipe, stderr); } static void ReadFromPipe(SEXP fun, HANDLE pipe){ unsigned long len = 1; while(1){ bail_if(!PeekNamedPipe(pipe, NULL, 0, NULL, &len, NULL), "PeekNamedPipe"); if(!len) break; char buffer[len]; unsigned long outlen; if(ReadFile(pipe, buffer, len, &outlen, NULL)) R_callback(fun, buffer, outlen); } } static HANDLE fd_read(const char *path){ SECURITY_ATTRIBUTES sa = {0}; sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = TRUE; DWORD dwFlags = FILE_ATTRIBUTE_NORMAL; wchar_t *wpath; str_to_wchar(path, &wpath); HANDLE out = CreateFileW(wpath, GENERIC_READ, FILE_SHARE_READ, &sa, OPEN_EXISTING, dwFlags, NULL); free(wpath); bail_if(out == INVALID_HANDLE_VALUE, "CreateFile"); return out; } /* Create FD in Windows */ static HANDLE fd_write(const char * path){ SECURITY_ATTRIBUTES sa = {0}; sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = TRUE; DWORD dwFlags = FILE_ATTRIBUTE_NORMAL; wchar_t *wpath; str_to_wchar(path, &wpath); HANDLE out = CreateFileW(wpath, GENERIC_WRITE, FILE_SHARE_WRITE, &sa, CREATE_ALWAYS, dwFlags, NULL); free(wpath); bail_if(out == INVALID_HANDLE_VALUE, "CreateFile"); return out; } static BOOL CALLBACK closeWindows(HWND hWnd, LPARAM lpid) { DWORD pid = (DWORD)lpid; DWORD win; GetWindowThreadProcessId(hWnd, &win); if(pid == win) CloseWindow(hWnd); return TRUE; } static void fin_proc(SEXP ptr){ if(!R_ExternalPtrAddr(ptr)) return; CloseHandle(R_ExternalPtrAddr(ptr)); R_ClearExternalPtr(ptr); } // Keeps one process handle open to let exec_status() read exit code static SEXP make_handle_ptr(HANDLE proc){ SEXP ptr = PROTECT(R_MakeExternalPtr(proc, R_NilValue, R_NilValue)); R_RegisterCFinalizerEx(ptr, fin_proc, 1); setAttrib(ptr, R_ClassSymbol, mkString("handle_ptr")); UNPROTECT(1); return ptr; } SEXP C_execute(SEXP command, SEXP args, SEXP outfun, SEXP errfun, SEXP input, SEXP wait, SEXP timeout){ int block = asLogical(wait); SECURITY_ATTRIBUTES sa; sa.nLength = sizeof(sa); sa.lpSecurityDescriptor = NULL; sa.bInheritHandle = TRUE; STARTUPINFOW si = {0}; si.cb = sizeof(STARTUPINFOW); si.dwFlags |= STARTF_USESTDHANDLES; HANDLE pipe_out = NULL; HANDLE pipe_err = NULL; //set STDOUT pipe if(block || IS_TRUE(outfun)){ bail_if(!CreatePipe(&pipe_out, &si.hStdOutput, &sa, 0), "CreatePipe stdout"); bail_if(!SetHandleInformation(pipe_out, HANDLE_FLAG_INHERIT, 0), "SetHandleInformation stdout"); } else if(IS_STRING(outfun)){ si.hStdOutput = fd_write(CHAR(STRING_ELT(outfun, 0))); } //set STDERR if(block || IS_TRUE(errfun)){ bail_if(!CreatePipe(&pipe_err, &si.hStdError, &sa, 0), "CreatePipe stderr"); bail_if(!SetHandleInformation(pipe_err, HANDLE_FLAG_INHERIT, 0), "SetHandleInformation stdout"); } else if(IS_STRING(errfun)){ si.hStdError = fd_write(CHAR(STRING_ELT(errfun, 0))); } if(IS_STRING(input)){ si.hStdInput = fd_read(CHAR(STRING_ELT(input, 0))); } //append args into full command line wchar_t *argv = sexp_to_wchar(args); if(wcslen(argv) >= 32768) Rf_error("Windows commands cannot be longer than 32,768 characters"); PROCESS_INFORMATION pi = {0}; const char * cmd = CHAR(STRING_ELT(command, 0)); // set the process flags BOOL use_job = can_create_job(); DWORD dwCreationFlags = CREATE_NO_WINDOW | CREATE_SUSPENDED | CREATE_BREAKAWAY_FROM_JOB * use_job; /* This will cause orphans unless we install a SIGBREAK handler on the child if(!block) dwCreationFlags |= CREATE_NEW_PROCESS_GROUP; //allows sending CTRL+BREAK */ //printf("ARGV: %S\n", argv); //NOTE capital %S for formatting wchar_t str if(!CreateProcessW(NULL, argv, &sa, &sa, TRUE, dwCreationFlags, NULL, NULL, &si, &pi)){ //Failure to start, probably non existing program. Cleanup. const char *errmsg = formatError(GetLastError()); CloseHandle(pipe_out); CloseHandle(pipe_err); CloseHandle(si.hStdInput); CloseHandle(si.hStdOutput); CloseHandle(si.hStdInput); Rf_errorcall(R_NilValue, "Failed to execute '%s' (%s)", cmd, errmsg); } //CloseHandle(pi.hThread); DWORD pid = GetProcessId(pi.hProcess); HANDLE proc = pi.hProcess; HANDLE thread = pi.hThread; //A 'job' is some sort of process container HANDLE job = CreateJobObject(NULL, NULL); if(use_job){ JOBOBJECT_EXTENDED_LIMIT_INFORMATION joblimits; memset(&joblimits, 0, sizeof joblimits); joblimits.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_BREAKAWAY_OK | JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK | JOB_OBJECT_LIMIT_DIE_ON_UNHANDLED_EXCEPTION | JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE; SetInformationJobObject(job, JobObjectExtendedLimitInformation, &joblimits, sizeof joblimits); bail_if(!AssignProcessToJobObject(job, proc), "AssignProcessToJobObject"); } ResumeThread(thread); CloseHandle(thread); free(argv); //start timer int timeout_reached = 0; struct timeval start, end; double totaltime = REAL(timeout)[0]; gettimeofday(&start, NULL); int res = pid; if(block){ int running = 1; while(running){ //wait 1ms, enough to fix busy waiting. Windows does not support polling on pipes. running = WaitForSingleObject(proc, 1); ReadFromPipe(outfun, pipe_out); ReadFromPipe(errfun, pipe_err); //check for timeout if(totaltime > 0){ gettimeofday(&end, NULL); timeout_reached = ((end.tv_sec - start.tv_sec) + (end.tv_usec - start.tv_usec) / 1e6) > totaltime; } if(pending_interrupt() || timeout_reached){ running = 0; EnumWindows(closeWindows, pid); if(use_job){ bail_if(!TerminateJobObject(job, -2), "TerminateJobObject"); } else { bail_if(!TerminateProcess(proc, -2), "TerminateProcess"); } /*** TerminateJobObject kills all procs and threads if(!TerminateThread(thread, 99)) Rf_errorcall(R_NilValue, "TerminateThread failed %d", GetLastError()); if(!TerminateProcess(proc, 99)) Rf_errorcall(R_NilValue, "TerminateProcess failed: %d", GetLastError()); */ } } DWORD exit_code; warn_if(!CloseHandle(pipe_out), "CloseHandle pipe_out"); warn_if(!CloseHandle(pipe_err), "CloseHandle pipe_err"); warn_if(GetExitCodeProcess(proc, &exit_code) == 0, "GetExitCodeProcess"); warn_if(!CloseHandle(proc), "CloseHandle proc"); warn_if(!CloseHandle(job), "CloseHandle job"); res = exit_code; //if wait=TRUE, return exit code } else { //create background threads to print stdout/stderr if(IS_TRUE(outfun)) bail_if(!CreateThread(NULL, 0, PrintOut, pipe_out, 0, 0), "CreateThread stdout"); if(IS_TRUE(errfun)) bail_if(!CreateThread(NULL, 0, PrintErr, pipe_err, 0, 0), "CreateThread stderr"); } CloseHandle(si.hStdError); CloseHandle(si.hStdOutput); CloseHandle(si.hStdInput); if(timeout_reached && res){ Rf_errorcall(R_NilValue, "Program '%s' terminated (timeout reached: %.2fsec)", CHAR(STRING_ELT(command, 0)), totaltime); } SEXP out = PROTECT(ScalarInteger(res)); if(!block){ setAttrib(out, install("handle"), make_handle_ptr(proc)); if(use_job){ setAttrib(out, install("job"), make_handle_ptr(job)); } } UNPROTECT(1); return out; } SEXP R_exec_status(SEXP rpid, SEXP wait){ DWORD exit_code = NA_INTEGER; int pid = asInteger(rpid); HANDLE proc = OpenProcess(PROCESS_QUERY_INFORMATION | SYNCHRONIZE, FALSE, pid); bail_if(!proc, "OpenProcess()"); do { DWORD res = WaitForSingleObject(proc, 200); bail_if(res == WAIT_FAILED, "WaitForSingleObject()"); if(res != WAIT_TIMEOUT) break; } while(asLogical(wait) && !pending_interrupt()); warn_if(GetExitCodeProcess(proc, &exit_code) == 0, "GetExitCodeProcess"); CloseHandle(proc); return ScalarInteger(exit_code == STILL_ACTIVE ? NA_INTEGER : exit_code); } sys/src/Makevars.win0000644000176200001440000000003613676414705014163 0ustar liggesusersOBJECTS = win32/exec.o init.o sys/NEWS0000644000176200001440000000600413706107045011572 0ustar liggesusers3.4 - Fix performance bug for systems with very large _SC_OPEN_MAX, notably docker. 3.3 - Unix: automatially path.expand() to normalize e.g. homedir - Unix: skip unicode path test on systems without UTF-8 locale. 3.2 - Windows: only use CREATE_BREAKAWAY_FROM_JOB if the process has the permission to do so. This fixes permission errors in certain restricted environments. - Windows: enable JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE to kill orphaned children - Windows: enable JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK to allow for nested jobs 3.1 - Windows: run programs through utils::shortPathName() - New function as_text() for parsing raw vectors into text - Skip a unit test if the 'whoami' program is not available 3.0 - Major cleanup: moved all of the unix specific functions into the unix package - The 'sys' package now only focuses on executing shell commands - Removed configure script, no longer needed - Windows: fix error message when running non-existing command - Fix support for callback functions as std_out / std_err as documented 2.1 - Windows: fix bug introduced in 2.0 when std_out = FALSE - Support std_in = FALSE to restore old behavior of an unreadable stdin (for rtika) - Use fcntl instead of dup2() on unix 2.0 - Breaking change on Windows: the exec functions now automatically convert filepaths to shortpath and quote arguments when needed. Therefore the caller should not shQuote() arguments, because then they will be quoted twice. This makes Windows behavior more consistent with Unix. - Windows: switch to wchar_t filepaths and args for better UTF-8 support - Exec functions have gained a std_in file argument - Add wrappers r_wait() r_internal() and r_background() for convenience - No longer enforce the libapparmor-dev dependency on Debian/Ubuntu. 1.6 - Faster serialization for raw vectors in eval_fork() 1.5 - rlimit values 0 are now ignored and Inf means RLIM_INFINITY - Windows: fix crash for very long commands 1.4 - Fix bug when 'timeout' was given as integer instead of double - Workaround undefined RLIMIT_AS on OpenBSD - Use graphics.off() instead of dev.off() to shut down all graphics devices - Added aa_config() to query apparmor status on supported platforms - On Linux, eval_fork() now kills entire child process group when parent dies - The exec() functions no longer change process group on OSX 1.3 - Use AppArmor (required) on Debian/Ubuntu in eval_safe() - Disable console and finalizers inside forked procs - Add support for rlimits, priority, uid, gid and profile in eval_safe() 1.2: - Windows: show informative system error messages on failures - Unix: exec_background() does not wait for 1/2 a second (#6, #7, @gaborcsardi) - Unix: new functions eval_fork() and eval_safe() - Many little tweaks 1.1: - Switch from SIGHUP to SIGKILL to kill child process - Child now uses a pipe to send errno to parent when execvp() fails - Unit tests that require 'ping' are skipped if 'ping' is not available 1.0: - CRAN release sys/R/0000755000176200001440000000000013676414705011306 5ustar liggesuserssys/R/exec.R0000644000176200001440000002024213676414705012355 0ustar liggesusers#' Running System Commands #' #' Powerful replacements for [system2] with support for interruptions, background #' tasks and fine grained control over `STDOUT` / `STDERR` binary or text streams. #' #' Each value within the `args` vector will automatically be quoted when needed; #' you should not quote arguments yourself. Doing so anyway could lead to the value #' being quoted twice on some platforms. #' #' The `exec_wait` function runs a system command and waits for the child process #' to exit. When the child process completes normally (either success or error) it #' returns with the program exit code. Otherwise (if the child process gets aborted) #' R raises an error. The R user can interrupt the program by sending SIGINT (press #' ESC or CTRL+C) in which case the child process tree is properly terminated. #' Output streams `STDOUT` and `STDERR` are piped back to the parent process and can #' be sent to a connection or callback function. See the section on *Output Streams* #' below for details. #' #' The `exec_background` function starts the program and immediately returns the #' PID of the child process. This is useful for running a server daemon or background #' process. #' Because this is non-blocking, `std_out` and `std_out` can only be `TRUE`/`FALSE` or #' a file path. The state of the process can be checked with `exec_status` which #' returns the exit status, or `NA` if the process is still running. If `wait = TRUE` #' then `exec_status` blocks until the process completes (but can be interrupted). #' The child can be killed with [tools::pskill]. #' #' The `exec_internal` function is a convenience wrapper around `exec_wait` which #' automatically captures output streams and raises an error if execution fails. #' Upon success it returns a list with status code, and raw vectors containing #' stdout and stderr data (use [as_text] for converting to text). #' #' @section Output Streams: #' #' The `std_out` and `std_err` parameters are used to control how output streams #' of the child are processed. Possible values for both foreground and background #' processes are: #' #' - `TRUE`: print child output in R console #' - `FALSE`: suppress output stream #' - *string*: name or path of file to redirect output #' #' In addition the `exec_wait` function also supports the following `std_out` and `std_err` #' types: #' #' - *connection* a writable R [connection] object such as [stdout] or [stderr] #' - *function*: callback function with one argument accepting a raw vector (use #' [as_text] to convert to text). #' #' When using `exec_background` with `std_out = TRUE` or `std_err = TRUE` on Windows, #' separate threads are used to print output. This works in RStudio and RTerm but #' not in RGui because the latter has a custom I/O mechanism. Directing output to a #' file is usually the safest option. #' #' @export #' @return `exec_background` returns a pid. `exec_wait` returns an exit code. #' `exec_internal` returns a list with exit code, stdout and stderr strings. #' @name exec #' @aliases sys #' @seealso Base [system2] and [pipe] provide other methods for running a system #' command with output. #' @family sys #' @rdname exec #' @param cmd the command to run. Either a full path or the name of a program on #' the `PATH`. On Windows this is automatically converted to a short path using #' [Sys.which], unless wrapped in [I()]. #' @param args character vector of arguments to pass. On Windows these automatically #' get quoted using [windows_quote], unless the value is wrapped in [I()]. #' @param std_out if and where to direct child process `STDOUT`. Must be one of #' `TRUE`, `FALSE`, filename, connection object or callback function. See section #' on *Output Streams* below for details. #' @param std_err if and where to direct child process `STDERR`. Must be one of #' `TRUE`, `FALSE`, filename, connection object or callback function. See section #' on *Output Streams* below for details. #' @param std_in file path to map std_in #' @param timeout maximum time in seconds #' @examples # Run a command (interrupt with CTRL+C) #' status <- exec_wait("date") #' #' # Capture std/out #' out <- exec_internal("date") #' print(out$status) #' cat(as_text(out$stdout)) #' #' if(nchar(Sys.which("ping"))){ #' #' # Run a background process (daemon) #' pid <- exec_background("ping", "localhost") #' #' # Kill it after a while #' Sys.sleep(2) #' tools::pskill(pid) #' #' # Cleans up the zombie proc #' exec_status(pid) #' rm(pid) #' } exec_wait <- function(cmd, args = NULL, std_out = stdout(), std_err = stderr(), std_in = NULL, timeout = 0){ # Convert TRUE or filepath into connection objects std_out <- if(isTRUE(std_out) || identical(std_out, "")){ stdout() } else if(is.character(std_out)){ file(normalizePath(std_out, mustWork = FALSE)) } else std_out std_err <- if(isTRUE(std_err) || identical(std_err, "")){ stderr() } else if(is.character(std_err)){ std_err <- file(normalizePath(std_err, mustWork = FALSE)) } else std_err # Define the callbacks outfun <- if(inherits(std_out, "connection")){ if(!isOpen(std_out)){ open(std_out, "wb") on.exit(close(std_out), add = TRUE) } if(identical(summary(std_out)$text, "text")){ function(x){ cat(rawToChar(x), file = std_out) flush(std_out) } } else { function(x){ writeBin(x, con = std_out) flush(std_out) } } } else if(is.function(std_out)){ if(!length(formals(std_out))) stop("Function std_out must take at least one argument") std_out } errfun <- if(inherits(std_err, "connection")){ if(!isOpen(std_err)){ open(std_err, "wb") on.exit(close(std_err), add = TRUE) } if(identical(summary(std_err)$text, "text")){ function(x){ cat(rawToChar(x), file = std_err) flush(std_err) } } else { function(x){ writeBin(x, con = std_err) flush(std_err) } } } else if(is.function(std_err)){ if(!length(formals(std_err))) stop("Function std_err must take at least one argument") std_err } execute(cmd = cmd, args = args, std_out = outfun, std_err = errfun, std_in = std_in, wait = TRUE, timeout = timeout) } #' @export #' @rdname exec exec_background <- function(cmd, args = NULL, std_out = TRUE, std_err = TRUE, std_in = NULL){ if(!is.character(std_out) && !is.logical(std_out)) stop("argument 'std_out' must be TRUE / FALSE or a filename") if(!is.character(std_err) && !is.logical(std_err)) stop("argument 'std_err' must be TRUE / FALSE or a filename") execute(cmd = cmd, args = args, std_out = std_out, std_err = std_err, wait = FALSE, std_in = std_in, timeout = 0) } #' @export #' @rdname exec #' @param error automatically raise an error if the exit status is non-zero. exec_internal <- function(cmd, args = NULL, std_in = NULL, error = TRUE, timeout = 0){ outcon <- rawConnection(raw(0), "r+") on.exit(close(outcon), add = TRUE) errcon <- rawConnection(raw(0), "r+") on.exit(close(errcon), add = TRUE) status <- exec_wait(cmd, args, std_out = outcon, std_err = errcon, std_in = std_in, timeout = timeout) if(isTRUE(error) && !identical(status, 0L)) stop(sprintf("Executing '%s' failed with status %d", cmd, status)) list( status = status, stdout = rawConnectionValue(outcon), stderr = rawConnectionValue(errcon) ) } #' @export #' @rdname exec #' @useDynLib sys R_exec_status #' @param pid integer with a process ID #' @param wait block until the process completes exec_status <- function(pid, wait = TRUE){ .Call(R_exec_status, pid, wait) } #' @useDynLib sys C_execute execute <- function(cmd, args, std_out, std_err, std_in, wait, timeout){ stopifnot(is.character(cmd)) if(.Platform$OS.type == 'windows'){ if(!inherits(cmd, 'AsIs')) cmd <- utils::shortPathName(path.expand(cmd)) if(!inherits(args, 'AsIs')) args <- windows_quote(args) } else { if(!inherits(cmd, 'AsIs')) cmd <- path.expand(cmd) } stopifnot(is.logical(wait)) argv <- enc2utf8(c(cmd, args)) if(length(std_in) && !is.logical(std_in)) # Only files supported for stdin std_in <- enc2utf8(normalizePath(std_in, mustWork = TRUE)) .Call(C_execute, cmd, argv, std_out, std_err, std_in, wait, timeout) } sys/R/callr.R0000644000176200001440000000276213676414705012535 0ustar liggesusers#' Execute R from R #' #' Convenience wrappers for [exec_wait] and [exec_internal] that shell out to #' R itself: `R.home("bin/R")`. #' #' This is a simple but robust way to invoke R commands in a separate process. #' Use the [callr](https://cran.r-project.org/package=callr) package if you #' need more sophisticated control over (multiple) R process jobs. #' #' @export #' @rdname exec_r #' @name exec_r #' @family sys #' @inheritParams exec #' @param args command line arguments for R #' @param std_in a file to send to stdin, usually an R script (see examples). #' @examples # Hello world #' r_wait("--version") #' #' # Run some code #' r_wait(c('--vanilla', '-q', '-e', 'sessionInfo()')) #' #' # Run a script via stdin #' tmp <- tempfile() #' writeLines(c("x <- rnorm(100)", "mean(x)"), con = tmp) #' r_wait(std_in = tmp) r_wait <- function(args = '--vanilla', std_out = stdout(), std_err = stderr(), std_in = NULL){ exec_wait(rbin(), args = args, std_out = std_out, std_err = std_err, std_in = std_in) } #' @export #' @rdname exec_r r_internal <- function(args = '--vanilla', std_in = NULL, error = TRUE){ exec_internal(rbin(), args = args, std_in = std_in, error = error) } #' @export #' @rdname exec_r r_background <- function(args = '--vanilla', std_out = TRUE, std_err = TRUE, std_in = NULL){ exec_background(rbin(), args = args, std_out = std_out, std_err = std_err, std_in = std_in) } rbin <- function(){ cmd <- ifelse(.Platform$OS.type == 'windows', 'Rterm', 'R') file.path(R.home('bin'), cmd) } sys/R/deprecated.R0000644000176200001440000000070713676414705013535 0ustar liggesusers#' Deprecated functions #' #' These functions have moved into the `unix` package. Please update #' your references. #' #' @export #' @name sys-deprecated #' @rdname deprecated #' @param ... see respective functions in the unix package eval_safe <- function(...){ .Deprecated('unix::eval_safe', 'sys') unix::eval_safe(...) } #' @export #' @rdname deprecated eval_fork <- function(...){ .Deprecated('unix::eval_fork', 'sys') unix::eval_fork(...) } sys/R/astext.R0000644000176200001440000000102013676414705012732 0ustar liggesusers#' Convert Raw to Text #' #' Parses a raw vector as lines of text. This is similar to [charToRaw] but #' splits output by (platform specific) linebreaks and allows for marking #' output with a given encoding. #' #' #' @export #' @seealso [base::charToRaw] #' @param x vector to be converted to text #' @param ... parameters passed to [readLines] such as `encoding` or `n` as_text <- function(x, ...){ if(length(x)){ con <- rawConnection(x) on.exit(close(con)) readLines(con, ...) } else { character(0) } } sys/R/quote.R0000644000176200001440000000200113676414705012557 0ustar liggesusers#' Quote arguments on Windows #' #' Quotes and escapes shell arguments when needed so that they get properly parsed #' by most Windows programs. This function is used internally to automatically quote #' system commands, the user should normally not quote arguments manually. #' #' Algorithm is ported to R from #' [libuv](https://github.com/libuv/libuv/blob/v1.23.0/src/win/process.c#L454-L524). #' #' @export #' @rdname quote #' @name quote #' @param args character vector with arguments windows_quote <- function(args){ if(is.null(args)) return(args) stopifnot(is.character(args)) args <- enc2utf8(args) vapply(args, windows_quote_one, character(1), USE.NAMES = FALSE) } windows_quote_one <- function(str){ if(!nchar(str)){ return('""') } if(!grepl('[ \t"]', str)){ return(str) } if(!grepl('["\\]', str)){ return(paste0('"', str, '"')) } str <- gsub('([\\]*)"', '\\1\\1\\\\"', str, useBytes = TRUE) str <- gsub('([\\]+)$', '\\1\\1', str, useBytes = TRUE) paste0('"', str, '"') } sys/MD50000644000176200001440000000277513706211112011405 0ustar liggesusersc4d32ed033fbabbc1d3de19167b3e1fa *DESCRIPTION f35c1dd7a6e913e967bd6e03dd8a3c18 *LICENSE 9c1f8e2d8ed675addf415c3ef5be77f7 *NAMESPACE 6ef2638ab6d1ebe5557c0adc366c547b *NEWS 21e2f14cf7db8259c5bf76c4d88a2196 *R/astext.R 728bafa32212be9a91ed31c2bdfd0ada *R/callr.R 50c5125076999c441c3077914ef170dd *R/deprecated.R ba8ef9bb6b48f62812b2290e890cd32a *R/exec.R 14bed5f4e5e9f156e2299b8fac970bcf *R/quote.R 5cbe3f29bed1c09ac980f07d1efde6ce *inst/WORDLIST 6c786db85c26a880352ad8593ad6250f *inst/utf8.txt 274b774d8605ef21fe7cf0a8d1e24bf9 *man/as_text.Rd 6be9be717cae2396b6faf1863c94dc25 *man/deprecated.Rd 043a8f91c9f37f3bc8176decb6898cf9 *man/exec.Rd 2971e740377131194efe7f6f67176d0a *man/exec_r.Rd b9eda114d61f26b4fa44948b28a3436f *man/quote.Rd 4451ceeee120a005b47df3de92482984 *src/Makevars.win 59ecf0b71e74ccf027f0aa0b22b070c3 *src/exec.c d623e255d620a7f40afa7699505b197e *src/init.c bbd735bd93f714f967c3b251cd94ab3d *src/win32/exec.c 78a7f421feb7208c58c9197ba4eb5edb *tests/spelling.R 7e95dde88a7eec2a10cb0bead876a6bc *tests/testthat.R e7120c55fd5ea95f1e379b7d8ca89cb4 *tests/testthat/test-binary.R 6f73ad3e0d7eb4b6a3ed8d38178f2334 *tests/testthat/test-encoding.R c19a199c3d65a38d2b03533a31b64973 *tests/testthat/test-error.R 17a52a640b0262def033c68395bbf5eb *tests/testthat/test-nesting.R a4c660d029081a26cd63b54e43aa220a *tests/testthat/test-quote.R 8c3a55f1c727ffa56f56fc425de7e00b *tests/testthat/test-stdin.R 849f263186ae614d10bdc58a7977547d *tests/testthat/test-stdout.R b7e4034f3090ce49815e4ce6e346a5fe *tests/testthat/test-timeout.R sys/inst/0000755000176200001440000000000013676414705012062 5ustar liggesuserssys/inst/utf8.txt0000644000176200001440000000002213676414705013503 0ustar liggesusersすし,寿司,鮨 sys/inst/WORDLIST0000644000176200001440000000017213706107711013242 0ustar liggesusersAppVeyor CTRL ESC PID RGui RStudio RTerm SIGINT STDERR STDIN STDOUT callr libuv linebreaks pid pskill stderr stdin stdout