sys/0000755000176200001440000000000013527251422011073 5ustar liggesuserssys/NAMESPACE0000644000176200001440000000047113446662541012324 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/LICENSE0000644000176200001440000000005113457675176012116 0ustar liggesusersYEAR: 2019 COPYRIGHT HOLDER: Jeroen Ooms sys/man/0000755000176200001440000000000013441241001011631 5ustar liggesuserssys/man/exec_r.Rd0000644000176200001440000000330513370113203013371 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.Rd0000644000176200001440000000117613441237745013306 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.Rd0000644000176200001440000001225713441244776013101 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.Rd0000644000176200001440000000064113434761563014247 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.Rd0000644000176200001440000000106013441242600013572 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:charToRaw]{base::charToRaw} } sys/DESCRIPTION0000644000176200001440000000223013527251422012576 0ustar liggesusersPackage: sys Type: Package Title: Powerful and Reliable Tools for Running System Commands in R Version: 3.3 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: 6.1.1 Suggests: unix (>= 1.4), spelling, testthat Language: en-US NeedsCompilation: yes Packaged: 2019-08-21 11:45:42 UTC; jeroen Author: Jeroen Ooms [aut, cre] (), Gábor Csárdi [ctb] Maintainer: Jeroen Ooms Repository: CRAN Date/Publication: 2019-08-21 14:20:02 UTC sys/tests/0000755000176200001440000000000013446663441012245 5ustar liggesuserssys/tests/spelling.R0000644000176200001440000000020213366651723014200 0ustar liggesusersif(requireNamespace('spelling', quietly=TRUE)) spelling::spell_check_test(vignettes = TRUE, error = FALSE, skip_on_cran = TRUE) sys/tests/testthat/0000755000176200001440000000000013527251422014075 5ustar liggesuserssys/tests/testthat/test-stdout.R0000644000176200001440000000310613441243555016522 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.R0000644000176200001440000000057313446550730016655 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.R0000644000176200001440000000330613527216712016770 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.R0000644000176200001440000000262613434766165016350 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.R0000644000176200001440000000114413463255772016676 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.5, std_out = FALSE), "timeout") }) expect_gte(times[['elapsed']], 1.5) expect_lt(times[['elapsed']], 2.5) # Also try with exec_internal times <- system.time({ expect_error(exec_internal(command, args, timeout = 0.5), "timeout") }) expect_gte(times[['elapsed']], 0.5) expect_lt(times[['elapsed']], 1.5) }) sys/tests/testthat/test-stdin.R0000644000176200001440000000052313366671463016332 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.R0000644000176200001440000000142713441243573016341 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.R0000644000176200001440000000401313366651723016470 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.R0000644000176200001440000000006213446663441014226 0ustar liggesuserslibrary(testthat) library(sys) test_check("sys") sys/src/0000755000176200001440000000000013527227337011672 5ustar liggesuserssys/src/exec.c0000644000176200001440000002104713446550730012762 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]) close(i); } //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.c0000644000176200001440000000102013434026571012764 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/0000755000176200001440000000000013446661715012636 5ustar liggesuserssys/src/win32/exec.c0000644000176200001440000002715613447437755013747 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.win0000644000176200001440000000003613434476524014162 0ustar liggesusersOBJECTS = win32/exec.o init.o sys/NEWS0000644000176200001440000000565513527216771011615 0ustar liggesusers3.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/0000755000176200001440000000000013441240733011272 5ustar liggesuserssys/R/exec.R0000644000176200001440000002024213515142247012344 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.R0000644000176200001440000000276213370113172012516 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.R0000644000176200001440000000070713434761560013531 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.R0000644000176200001440000000102013441242572012721 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.R0000644000176200001440000000200113441237724012551 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/MD50000644000176200001440000000277513527251422011416 0ustar liggesusers30fcf4afecea5166d5ac6fb6f0492a7d *DESCRIPTION f35c1dd7a6e913e967bd6e03dd8a3c18 *LICENSE 9c1f8e2d8ed675addf415c3ef5be77f7 *NAMESPACE 38aa529e28701bae1d9fdc0b4cfc7203 *NEWS 21e2f14cf7db8259c5bf76c4d88a2196 *R/astext.R 728bafa32212be9a91ed31c2bdfd0ada *R/callr.R 50c5125076999c441c3077914ef170dd *R/deprecated.R ba8ef9bb6b48f62812b2290e890cd32a *R/exec.R 14bed5f4e5e9f156e2299b8fac970bcf *R/quote.R 5b4875f3218c8cbfd689e0ae3e504c72 *inst/WORDLIST 6c786db85c26a880352ad8593ad6250f *inst/utf8.txt f67555fb43bac6e78c67450365d38d11 *man/as_text.Rd 6be9be717cae2396b6faf1863c94dc25 *man/deprecated.Rd be58888f6ca6a19e9839f56c8ad2a285 *man/exec.Rd 553555e5dbed7e751116f5e2632de8e1 *man/exec_r.Rd b9eda114d61f26b4fa44948b28a3436f *man/quote.Rd 4451ceeee120a005b47df3de92482984 *src/Makevars.win e86a11b9f643becd4da8471133943134 *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 aab612f83c705b9d6d30687bcf2650bb *tests/testthat/test-timeout.R sys/inst/0000755000176200001440000000000013367556172012064 5ustar liggesuserssys/inst/utf8.txt0000644000176200001440000000002213367556172013505 0ustar liggesusersすし,寿司,鮨 sys/inst/WORDLIST0000644000176200001440000000017213433773507013253 0ustar liggesusersAppVeyor callr CTRL ESC libuv pid PID pskill RGui RStudio RTerm sandboxing SIGINT stderr STDERR stdin STDIN stdout STDOUT