1#' Run external command, and wait until finishes 2#' 3#' `run` provides an interface similar to [base::system()] and 4#' [base::system2()], but based on the [process] class. This allows some 5#' extra features, see below. 6#' 7#' `run` supports 8#' * Specifying a timeout for the command. If the specified time has 9#' passed, and the process is still running, it will be killed 10#' (with all its child processes). 11#' * Calling a callback function for each line or each chunk of the 12#' standard output and/or error. A chunk may contain multiple lines, and 13#' can be as short as a single character. 14#' * Cleaning up the subprocess, or the whole process tree, before exiting. 15#' 16#' @section Callbacks: 17#' 18#' Some notes about the callback functions. The first argument of a 19#' callback function is a character scalar (length 1 character), a single 20#' output or error line. The second argument is always the [process] 21#' object. You can manipulate this object, for example you can call 22#' `$kill()` on it to terminate it, as a response to a message on the 23#' standard output or error. 24#' 25#' @section Error conditions: 26#' 27#' `run()` throws error condition objects if the process is interrupted, 28#' timeouts or fails (if `error_on_status` is `TRUE`): 29#' * On interrupt, a condition with classes `system_command_interrupt`, 30#' `interrupt`, `condition` is signalled. This can be caught with 31#' `tryCatch(..., interrupt = ...)`. 32#' * On timeout, a condition with classes `system_command_timeout_error`, 33#' `system_command_error`, `error`, `condition` is thrown. 34#' * On error (if `error_on_status` is `TRUE`), an error with classes 35#' `system_command_status_error`, `system_command_error`, `error`, 36#' `condition` is thrown. 37#' 38#' All of these conditions have the fields: 39#' * `message`: the error message, 40#' * `stderr`: the standard error of the process, or the standard output 41#' of the process if `stderr_to_stdout` was `TRUE`. 42#' * `call`: the captured call to `run()`. 43#' * `echo`: the value of the `echo` argument. 44#' * `stderr_to_stdout`: the value of the `stderr_to_stdout` argument. 45#' * `status`: the exit status for `system_command_status_error` errors. 46#' 47#' @param command Character scalar, the command to run. If you are 48#' running `.bat` or `.cmd` files on Windows, make sure you read the 49#' 'Batch files' section in the [process] manual page. 50#' @param args Character vector, arguments to the command. 51#' @param error_on_status Whether to throw an error if the command returns 52#' with a non-zero status, or it is interrupted. The error classes are 53#' `system_command_status_error` and `system_command_timeout_error`, 54#' respectively, and both errors have class `system_command_error` as 55#' well. See also "Error conditions" below. 56#' @param wd Working directory of the process. If `NULL`, the current 57#' working directory is used. 58#' @param echo_cmd Whether to print the command to run to the screen. 59#' @param echo Whether to print the standard output and error 60#' to the screen. Note that the order of the standard output and error 61#' lines are not necessarily correct, as standard output is typically 62#' buffered. If the standard output and/or error is redirected to a 63#' file or they are ignored, then they also not echoed. 64#' @param spinner Whether to show a reassuring spinner while the process 65#' is running. 66#' @param timeout Timeout for the process, in seconds, or as a `difftime` 67#' object. If it is not finished before this, it will be killed. 68#' @param stdout What to do with the standard output. By default it 69#' is collected in the result, and you can also use the 70#' `stdout_line_callback` and `stdout_callback` arguments to pass 71#' callbacks for output. If it is the empty string (`""`), then 72#' the child process inherits the standard output stream of the 73#' R process. (If the main R process does not have a standard output 74#' stream, e.g. in RGui on Windows, then an error is thrown.) 75#' If it is `NULL`, then standard output is discarded. If it is a string 76#' other than `"|"` and `""`, then it is taken as a file name and the 77#' output is redirected to this file. 78#' @param stderr What to do with the standard error. By default it 79#' is collected in the result, and you can also use the 80#' `stderr_line_callback` and `stderr_callback` arguments to pass 81#' callbacks for output. If it is the empty string (`""`), then 82#' the child process inherits the standard error stream of the 83#' R process. (If the main R process does not have a standard error 84#' stream, e.g. in RGui on Windows, then an error is thrown.) 85#' If it is `NULL`, then standard error is discarded. If it is a string 86#' other than `"|"` and `""`, then it is taken as a file name and the 87#' standard error is redirected to this file. 88#' @param stdout_line_callback `NULL`, or a function to call for every 89#' line of the standard output. See `stdout_callback` and also more 90#' below. 91#' @param stdout_callback `NULL`, or a function to call for every chunk 92#' of the standard output. A chunk can be as small as a single character. 93#' At most one of `stdout_line_callback` and `stdout_callback` can be 94#' non-`NULL`. 95#' @param stderr_line_callback `NULL`, or a function to call for every 96#' line of the standard error. See `stderr_callback` and also more 97#' below. 98#' @param stderr_callback `NULL`, or a function to call for every chunk 99#' of the standard error. A chunk can be as small as a single character. 100#' At most one of `stderr_line_callback` and `stderr_callback` can be 101#' non-`NULL`. 102#' @param stderr_to_stdout Whether to redirect the standard error to the 103#' standard output. Specifying `TRUE` here will keep both in the 104#' standard output, correctly interleaved. However, it is not possible 105#' to deduce where pieces of the output were coming from. If this is 106#' `TRUE`, the standard error callbacks (if any) are never called. 107#' @param env Environment variables of the child process. If `NULL`, 108#' the parent's environment is inherited. On Windows, many programs 109#' cannot function correctly if some environment variables are not 110#' set, so we always set `HOMEDRIVE`, `HOMEPATH`, `LOGONSERVER`, 111#' `PATH`, `SYSTEMDRIVE`, `SYSTEMROOT`, `TEMP`, `USERDOMAIN`, 112#' `USERNAME`, `USERPROFILE` and `WINDIR`. To append new environment 113#' variables to the ones set in the current process, specify 114#' `"current"` in `env`, without a name, and the appended ones with 115#' names. The appended ones can overwrite the current ones. 116#' @param windows_verbatim_args Whether to omit the escaping of the 117#' command and the arguments on windows. Ignored on other platforms. 118#' @param windows_hide_window Whether to hide the window of the 119#' application on windows. Ignored on other platforms. 120#' @param encoding The encoding to assume for `stdout` and 121#' `stderr`. By default the encoding of the current locale is 122#' used. Note that `processx` always reencodes the output of 123#' both streams in UTF-8 currently. 124#' @param cleanup_tree Whether to clean up the child process tree after 125#' the process has finished. 126#' @param ... Extra arguments are passed to `process$new()`, see 127#' [process]. Note that you cannot pass `stout` or `stderr` here, 128#' because they are used internally by `run()`. You can use the 129#' `stdout_callback`, `stderr_callback`, etc. arguments to manage 130#' the standard output and error, or the [process] class directly 131#' if you need more flexibility. 132#' @return A list with components: 133#' * status The exit status of the process. If this is `NA`, then the 134#' process was killed and had no exit status. 135#' * stdout The standard output of the command, in a character scalar. 136#' * stderr The standard error of the command, in a character scalar. 137#' * timeout Whether the process was killed because of a timeout. 138#' 139#' @export 140#' @examplesIf .Platform$OS.type == "unix" 141#' # This works on Unix systems 142#' run("ls") 143#' system.time(run("sleep", "10", timeout = 1, error_on_status = FALSE)) 144#' system.time( 145#' run( 146#' "sh", c("-c", "for i in 1 2 3 4 5; do echo $i; sleep 1; done"), 147#' timeout = 2, error_on_status = FALSE 148#' ) 149#' ) 150#' 151#' @examplesIf FALSE 152#' # This works on Windows systems, if the ping command is available 153#' run("ping", c("-n", "1", "127.0.0.1")) 154#' run("ping", c("-n", "6", "127.0.0.1"), timeout = 1, 155#' error_on_status = FALSE) 156 157run <- function( 158 command = NULL, args = character(), error_on_status = TRUE, wd = NULL, 159 echo_cmd = FALSE, echo = FALSE, spinner = FALSE, 160 timeout = Inf, stdout = "|", stderr = "|", 161 stdout_line_callback = NULL, stdout_callback = NULL, 162 stderr_line_callback = NULL, stderr_callback = NULL, 163 stderr_to_stdout = FALSE, env = NULL, 164 windows_verbatim_args = FALSE, windows_hide_window = FALSE, 165 encoding = "", cleanup_tree = FALSE, ...) { 166 167 assert_that(is_flag(error_on_status)) 168 assert_that(is_time_interval(timeout)) 169 assert_that(is_flag(spinner)) 170 assert_that(is_string_or_null(stdout)) 171 assert_that(is_string_or_null(stderr)) 172 assert_that(is.null(stdout_line_callback) || 173 is.function(stdout_line_callback)) 174 assert_that(is.null(stderr_line_callback) || 175 is.function(stderr_line_callback)) 176 assert_that(is.null(stdout_callback) || is.function(stdout_callback)) 177 assert_that(is.null(stderr_callback) || is.function(stderr_callback)) 178 assert_that(is_flag(cleanup_tree)) 179 assert_that(is_flag(stderr_to_stdout)) 180 ## The rest is checked by process$new() 181 "!DEBUG run() Checked arguments" 182 183 if (!interactive()) spinner <- FALSE 184 185 ## Run the process 186 if (stderr_to_stdout) stderr <- "2>&1" 187 pr <- process$new( 188 command, args, echo_cmd = echo_cmd, wd = wd, 189 windows_verbatim_args = windows_verbatim_args, 190 windows_hide_window = windows_hide_window, 191 stdout = stdout, stderr = stderr, env = env, encoding = encoding, 192 cleanup_tree = cleanup_tree, ... 193 ) 194 "#!DEBUG run() Started the process: `pr$get_pid()`" 195 196 ## We make sure that the process is eliminated 197 if (cleanup_tree) { 198 on.exit(pr$kill_tree(), add = TRUE) 199 } else { 200 on.exit(pr$kill(), add = TRUE) 201 } 202 203 ## If echo, then we need to create our own callbacks. 204 ## These are merged to user callbacks if there are any. 205 if (echo) { 206 stdout_callback <- echo_callback(stdout_callback, "stdout") 207 stderr_callback <- echo_callback(stderr_callback, "stderr") 208 } 209 210 ## Make the process interruptible, and kill it on interrupt 211 runcall <- sys.call() 212 resenv <- new.env(parent = emptyenv()) 213 has_stdout <- !is.null(stdout) && stdout == "|" 214 has_stderr <- !is.null(stderr) && stderr %in% c("|", "2>&1") 215 216 if (has_stdout) { 217 resenv$outbuf <- make_buffer() 218 on.exit(resenv$outbuf$done(), add = TRUE) 219 } 220 if (has_stderr) { 221 resenv$errbuf <- make_buffer() 222 on.exit(resenv$errbuf$done(), add = TRUE) 223 } 224 225 res <- tryCatch( 226 run_manage(pr, timeout, spinner, stdout, stderr, 227 stdout_line_callback, stdout_callback, 228 stderr_line_callback, stderr_callback, resenv), 229 interrupt = function(e) { 230 "!DEBUG run() process `pr$get_pid()` killed on interrupt" 231 out <- if (has_stdout) { 232 resenv$outbuf$push(pr$read_output()) 233 resenv$outbuf$push(pr$read_output()) 234 resenv$outbuf$read() 235 } 236 err <- if (has_stderr) { 237 resenv$errbuf$push(pr$read_error()) 238 resenv$errbuf$push(pr$read_error()) 239 resenv$errbuf$read() 240 } 241 tryCatch(pr$kill(), error = function(e) NULL) 242 signalCondition(new_process_interrupt_cond( 243 list( 244 interrupt = TRUE, stderr = err, stdout = out, 245 command = command, args = args 246 ), 247 runcall, echo = echo, stderr_to_stdout = stderr_to_stdout 248 )) 249 cat("\n") 250 invokeRestart("abort") 251 } 252 ) 253 254 if (error_on_status && (is.na(res$status) || res$status != 0)) { 255 "!DEBUG run() error on status `res$status` for process `pr$get_pid()`" 256 throw(new_process_error(res, call = sys.call(), echo = echo, 257 stderr_to_stdout, res$status, command = command, 258 args = args)) 259 } 260 261 res 262} 263 264echo_callback <- function(user_callback, type) { 265 force(user_callback) 266 force(type) 267 function(x, ...) { 268 if (type == "stderr" && has_package("cli")) x <- cli::col_red(x) 269 cat(x, sep = "") 270 if (!is.null(user_callback)) user_callback(x, ...) 271 } 272} 273 274run_manage <- function(proc, timeout, spinner, stdout, stderr, 275 stdout_line_callback, stdout_callback, 276 stderr_line_callback, stderr_callback, resenv) { 277 278 timeout <- as.difftime(timeout, units = "secs") 279 start_time <- proc$get_start_time() 280 281 has_stdout <- !is.null(stdout) && stdout == "|" 282 has_stderr <- !is.null(stderr) && stderr %in% c("|", "2>&1") 283 284 pushback_out <- "" 285 pushback_err <- "" 286 287 do_output <- function() { 288 289 ok <- FALSE 290 if (has_stdout) { 291 newout <- tryCatch({ 292 ret <- proc$read_output(2000) 293 ok <- TRUE 294 ret 295 }, error = function(e) NULL) 296 297 if (length(newout) && nzchar(newout)) { 298 if (!is.null(stdout_callback)) stdout_callback(newout, proc) 299 resenv$outbuf$push(newout) 300 if (!is.null(stdout_line_callback)) { 301 newout <- paste0(pushback_out, newout) 302 pushback_out <<- "" 303 lines <- strsplit(newout, "\r?\n")[[1]] 304 if (last_char(newout) != "\n") { 305 pushback_out <<- utils::tail(lines, 1) 306 lines <- utils::head(lines, -1) 307 } 308 lapply(lines, function(x) stdout_line_callback(x, proc)) 309 } 310 } 311 } 312 313 if (has_stderr) { 314 newerr <- tryCatch({ 315 ret <- proc$read_error(2000) 316 ok <- TRUE 317 ret 318 }, error = function(e) NULL) 319 320 if (length(newerr) && nzchar(newerr)) { 321 resenv$errbuf$push(newerr) 322 if (!is.null(stderr_callback)) stderr_callback(newerr, proc) 323 if (!is.null(stderr_line_callback)) { 324 newerr <- paste0(pushback_err, newerr) 325 pushback_err <<- "" 326 lines <- strsplit(newerr, "\r?\n")[[1]] 327 if (last_char(newerr) != "\n") { 328 pushback_err <<- utils::tail(lines, 1) 329 lines <- utils::head(lines, -1) 330 } 331 lapply(lines, function(x) stderr_line_callback(x, proc)) 332 } 333 } 334 } 335 336 ok 337 } 338 339 spin <- (function() { 340 state <- 1L 341 phases <- c("-", "\\", "|", "/") 342 function() { 343 cat("\r", phases[state], "\r", sep = "") 344 state <<- state %% length(phases) + 1L 345 utils::flush.console() 346 } 347 })() 348 349 timeout_happened <- FALSE 350 351 while (proc$is_alive()) { 352 ## Timeout? Maybe finished by now... 353 if (!is.null(timeout) && is.finite(timeout) && 354 Sys.time() - start_time > timeout) { 355 if (proc$kill(close_connections = FALSE)) timeout_happened <- TRUE 356 "!DEBUG Timeout killed run() process `proc$get_pid()`" 357 break 358 } 359 360 ## Otherwise just poll for 200ms, or less if a timeout is sooner. 361 ## We cannot poll until the end, even if there is not spinner, 362 ## because RStudio does not send a SIGINT to the R process, 363 ## so interruption does not work. 364 if (!is.null(timeout) && timeout < Inf) { 365 remains <- timeout - (Sys.time() - start_time) 366 remains <- max(0, as.integer(as.numeric(remains) * 1000)) 367 if (spinner) remains <- min(remains, 200) 368 } else { 369 remains <- 200 370 } 371 "!DEBUG run is polling for `remains` ms, process `proc$get_pid()`" 372 polled <- proc$poll_io(remains) 373 374 ## If output/error, then collect it 375 if (any(polled == "ready")) do_output() 376 377 if (spinner) spin() 378 } 379 380 ## Needed to get the exit status 381 "!DEBUG run() waiting to get exit status, process `proc$get_pid()`" 382 proc$wait() 383 384 ## We might still have output 385 "!DEBUG run() reading leftover output / error, process `proc$get_pid()`" 386 while ((has_stdout && proc$is_incomplete_output()) || 387 (proc$has_error_connection() && proc$is_incomplete_error())) { 388 proc$poll_io(-1) 389 if (!do_output()) break 390 } 391 392 if (spinner) cat("\r \r") 393 394 list( 395 status = proc$get_exit_status(), 396 stdout = if (has_stdout) resenv$outbuf$read(), 397 stderr = if (has_stderr) resenv$errbuf$read(), 398 timeout = timeout_happened 399 ) 400} 401 402new_process_error <- function(result, call, echo, stderr_to_stdout, 403 status = NA_integer_, command, args) { 404 if (isTRUE(result$timeout)) { 405 new_process_timeout_error(result, call, echo, stderr_to_stdout, status, 406 command, args) 407 } else { 408 new_process_status_error(result, call, echo, stderr_to_stdout, status, 409 command, args) 410 } 411} 412 413new_process_status_error <- function(result, call, echo, stderr_to_stdout, 414 status = NA_integer_, command, args) { 415 err <- new_error( 416 "System command '", basename(command), "' failed", 417 call. = call 418 ) 419 err$stderr <- if (stderr_to_stdout) result$stdout else result$stderr 420 err$echo <- echo 421 err$stderr_to_stdout <- stderr_to_stdout 422 err$status <- status 423 424 add_class(err, c("system_command_status_error", "system_command_error")) 425} 426 427new_process_interrupt_cond <- function(result, call, echo, stderr_to_stdout, 428 status = NA_integer_) { 429 cond <- new_cond( 430 "System command '", basename(result$command), "' interrupted", 431 call. = call 432 ) 433 cond$stderr <- if (stderr_to_stdout) result$stdout else result$stderr 434 cond$echo <- echo 435 cond$stderr_to_stdout <- stderr_to_stdout 436 cond$status <- status 437 438 add_class(cond, c("system_command_interrupt", "interrupt")) 439} 440 441new_process_timeout_error <- function(result, call, echo, stderr_to_stdout, 442 status = NA_integer_, command, args) { 443 err <- new_error( 444 "System command '", basename(command), "' timed out", call. = call) 445 err$stderr <- if (stderr_to_stdout) result$stdout else result$stderr 446 err$echo <- echo 447 err$stderr_to_stdout <- stderr_to_stdout 448 err$status <- status 449 450 add_class(err, c("system_command_timeout_error", "system_command_error")) 451} 452 453#' @export 454 455conditionMessage.system_command_error <- function(c) { 456 paste(format(c), collapse = "\n") 457} 458 459#' @export 460 461format.system_command_error <- function(x, ...) { 462 parts <- system_error_parts(x) 463} 464 465#' @export 466 467print.system_command_error <- function(x, ...) { 468 cat(format(x, ...), sep = "\n") 469} 470 471system_error_parts <- function(x) { 472 exit <- if (!is.na(x$status)) paste0(", exit status: ", x$status) 473 msg <- paste0(x$message, exit) 474 parts <- if (x$echo) { 475 paste0(msg, ", stdout & stderr were printed") 476 } else { 477 std <- if (x$stderr_to_stdout) "stdout + stderr" else "stderr" 478 out <- last_stderr_lines(x$stderr, std) 479 c(paste0(msg, out[1]), out[-1]) 480 } 481} 482 483last_stderr_lines <- function(text, std) { 484 if (!nzchar(text)) return(paste0(", ", std, " empty")) 485 lines <- strsplit(text, "\r?\n")[[1]] 486 487 if (is_interactive()) { 488 pref <- paste0( 489 ", ", std, if (length(lines) > 10) " (last 10 lines)", ":") 490 out <- paste0("E> ", utils::tail(lines, 10)) 491 c(pref, out) 492 } else { 493 out <- paste0("E> ", lines) 494 c(paste0(", ", std, ":"), out) 495 } 496} 497