diff --git a/.Rbuildignore b/.Rbuildignore index 7f111acd..b6a19cdd 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -30,3 +30,5 @@ ^src/.*[.]gcno$ ^dev-lib$ ^vignettes$ +^[\.]?air\.toml$ +^\.vscode$ diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index b1c7571a..9ce0693c 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -8,7 +8,6 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] name: R-CMD-check.yaml diff --git a/.github/workflows/pkgdown.yaml b/.github/workflows/pkgdown.yaml index 4bbce750..bfc9f4db 100644 --- a/.github/workflows/pkgdown.yaml +++ b/.github/workflows/pkgdown.yaml @@ -4,7 +4,6 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] release: types: [published] workflow_dispatch: diff --git a/.github/workflows/test-coverage.yaml b/.github/workflows/test-coverage.yaml index 98822609..0ab748d6 100644 --- a/.github/workflows/test-coverage.yaml +++ b/.github/workflows/test-coverage.yaml @@ -4,7 +4,6 @@ on: push: branches: [main, master] pull_request: - branches: [main, master] name: test-coverage.yaml @@ -35,14 +34,16 @@ jobs: clean = FALSE, install_path = file.path(normalizePath(Sys.getenv("RUNNER_TEMP"), winslash = "/"), "package") ) + print(cov) covr::to_cobertura(cov) shell: Rscript {0} - - uses: codecov/codecov-action@v4 + - uses: codecov/codecov-action@v5 with: - fail_ci_if_error: ${{ github.event_name != 'pull_request' && true || false }} - file: ./cobertura.xml - plugin: noop + # Fail if error if not on PR, or if on PR and token is given + fail_ci_if_error: ${{ github.event_name != 'pull_request' || secrets.CODECOV_TOKEN }} + files: ./cobertura.xml + plugins: noop disable_search: true token: ${{ secrets.CODECOV_TOKEN }} diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 00000000..344f76eb --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,5 @@ +{ + "recommendations": [ + "Posit.air-vscode" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 00000000..f2d0b79d --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,6 @@ +{ + "[r]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "Posit.air-vscode" + } +} diff --git a/DESCRIPTION b/DESCRIPTION index 4109943f..d9c37b36 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -5,7 +5,8 @@ Authors@R: c( person("Gábor", "Csárdi", , "csardi.gabor@gmail.com", role = c("aut", "cre", "cph"), comment = c(ORCID = "0000-0001-7098-9676")), person("Winston", "Chang", role = "aut"), - person("Posit Software, PBC", role = c("cph", "fnd")), + person("Posit Software, PBC", role = c("cph", "fnd"), + comment = c(ROR = "03wc8by49")), person("Ascent Digital Services", role = c("cph", "fnd")) ) Description: Tools to run system processes in the background. It can @@ -38,6 +39,7 @@ Suggests: withr Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 +Config/usethis/last-upkeep: 2025-04-25 Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.3.2 diff --git a/LICENSE b/LICENSE index 4f638ffc..649f164c 100644 --- a/LICENSE +++ b/LICENSE @@ -1,2 +1,2 @@ -YEAR: 2016-2024 +YEAR: 2025 COPYRIGHT HOLDER: processx core team, see COPYRIGHTS file diff --git a/LICENSE.md b/LICENSE.md index 17bee3e9..84d1d54a 100644 --- a/LICENSE.md +++ b/LICENSE.md @@ -1,6 +1,6 @@ # MIT License -Copyright (c) 2023 processx authors +Copyright (c) 2025 processx authors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/R/aaa-import-standalone-rstudio-detect.R b/R/aaa-import-standalone-rstudio-detect.R index 262f7580..623105ba 100644 --- a/R/aaa-import-standalone-rstudio-detect.R +++ b/R/aaa-import-standalone-rstudio-detect.R @@ -10,7 +10,6 @@ # --- rstudio <- local({ - standalone_env <- environment() parent.env(standalone_env) <- baseenv() @@ -28,7 +27,8 @@ rstudio <- local({ "RSTUDIO_CONSOLE_COLOR", "RSTUDIOAPI_IPC_REQUESTS_FILE", "XPC_SERVICE_NAME", - "ASCIICAST") + "ASCIICAST" + ) d <- list( pid = Sys.getpid(), @@ -65,8 +65,10 @@ rstudio <- local({ if (clear_cache) data <<- NULL if (!is.null(data)) return(get_caps(data)) - if ((rspid <- Sys.getenv("RSTUDIO_SESSION_PID")) != "" && - any(c("ps", "cli") %in% loadedNamespaces())) { + if ( + (rspid <- Sys.getenv("RSTUDIO_SESSION_PID")) != "" && + any(c("ps", "cli") %in% loadedNamespaces()) + ) { detect_new(rspid, clear_cache) } else { detect_old(clear_cache) @@ -99,31 +101,26 @@ rstudio <- local({ # direct subprocess new$type <- if (rspid == parentpid) { - if (pane == "job") { "rstudio_job" - } else if (pane == "build") { "rstudio_build_pane" - } else if (pane == "render") { "rstudio_render_pane" - - } else if (pane == "terminal" && new$tty && - new$envs["ASCIICAST"] != "true") { + } else if ( + pane == "terminal" && new$tty && new$envs["ASCIICAST"] != "true" + ) { # not possible, because there is a shell in between, just in case "rstudio_terminal" - } else { # don't know what kind of direct subprocess "rstudio_subprocess" } - - } else if (pane == "terminal" && new$tty && - new$envs[["ASCIICAST"]] != "true") { + } else if ( + pane == "terminal" && new$tty && new$envs[["ASCIICAST"]] != "true" + ) { # not a direct subproces, so check other criteria as well "rstudio_terminal" - } else { # don't know what kind of subprocess "rstudio_subprocess" @@ -133,7 +130,6 @@ rstudio <- local({ } detect_old <- function(clear_cache = FALSE) { - # Cache unless told otherwise cache <- TRUE new <- get_data() @@ -141,20 +137,16 @@ rstudio <- local({ new$type <- if (new$envs[["RSTUDIO"]] != "1") { # 1. Not RStudio at all "not_rstudio" - } else if (new$gui == "RStudio" && new$api) { # 2. RStudio console, properly initialized "rstudio_console" - - } else if (! new$api && basename(new$args[1]) == "RStudio") { + } else if (!new$api && basename(new$args[1]) == "RStudio") { # 3. RStudio console, initializing cache <- FALSE "rstudio_console_starting" - } else if (new$gui == "Rgui") { # Still not RStudio, but Rgui that was started from RStudio "not_rstudio" - } else if (new$tty && new$envs[["ASCIICAST"]] != "true") { # 4. R in the RStudio terminal # This could also be a subprocess of the console or build pane @@ -162,29 +154,31 @@ rstudio <- local({ # out, without inspecting some process data with ps::ps_*(). # At least we rule out asciicast "rstudio_terminal" - - } else if (! new$tty && - new$envs[["RSTUDIO_TERM"]] == "" && - new$envs[["R_BROWSER"]] == "false" && - new$envs[["R_PDFVIEWER"]] == "false" && - is_build_pane_command(new$args)) { + } else if ( + !new$tty && + new$envs[["RSTUDIO_TERM"]] == "" && + new$envs[["R_BROWSER"]] == "false" && + new$envs[["R_PDFVIEWER"]] == "false" && + is_build_pane_command(new$args) + ) { # 5. R in the RStudio build pane # https://github.com/rstudio/rstudio/blob/master/src/cpp/session/ # modules/build/SessionBuild.cpp#L231-L240 "rstudio_build_pane" - - } else if (new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && - grepl("rstudio", new$envs[["XPC_SERVICE_NAME"]])) { + } else if ( + new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && + grepl("rstudio", new$envs[["XPC_SERVICE_NAME"]]) + ) { # RStudio job, XPC_SERVICE_NAME=0 in the subprocess of a job # process. Hopefully this is reliable. "rstudio_job" - - } else if (new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && - any(grepl("SourceWithProgress.R", new$args))) { + } else if ( + new$envs[["RSTUDIOAPI_IPC_REQUESTS_FILE"]] != "" && + any(grepl("SourceWithProgress.R", new$args)) + ) { # Or we can check SourceWithProgress.R in the command line, see # https://github.com/r-lib/cli/issues/367 "rstudio_job" - } else { # Otherwise it is a subprocess of the console, terminal or # build pane, and it is hard to say which, so we do not try. diff --git a/R/aaassertthat.R b/R/aaassertthat.R index 70f49404..88644097 100644 --- a/R/aaassertthat.R +++ b/R/aaassertthat.R @@ -1,4 +1,3 @@ - assert_that <- function(..., env = parent.frame(), msg = NULL) { res <- see_if(..., env = env, msg = msg) if (res) return(TRUE) @@ -6,7 +5,7 @@ assert_that <- function(..., env = parent.frame(), msg = NULL) { throw(new_assert_error(attr(res, "msg"))) } -new_assert_error <- function (message, call = NULL) { +new_assert_error <- function(message, call = NULL) { cond <- new_error(message, call. = call) class(cond) <- c("assert_error", class(cond)) cond @@ -16,17 +15,19 @@ see_if <- function(..., env = parent.frame(), msg = NULL) { asserts <- eval(substitute(alist(...))) for (assertion in asserts) { - res <- tryCatch({ - eval(assertion, env) - }, new_assert_error = function(e) { - structure(FALSE, msg = e$message) - }) + res <- tryCatch( + { + eval(assertion, env) + }, + new_assert_error = function(e) { + structure(FALSE, msg = e$message) + } + ) check_result(res) # Failed, so figure out message to produce if (!res) { - if (is.null(msg)) - msg <- get_message(res, assertion, env) + if (is.null(msg)) msg <- get_message(res, assertion, env) return(structure(FALSE, msg = msg)) } } @@ -36,7 +37,9 @@ see_if <- function(..., env = parent.frame(), msg = NULL) { check_result <- function(x) { if (!is.logical(x)) - throw(new_assert_error("assert_that: assertion must return a logical value")) + throw(new_assert_error( + "assert_that: assertion must return a logical value" + )) if (any(is.na(x))) throw(new_assert_error("assert_that: missing values present in assertion")) if (length(x) != 1) { @@ -68,7 +71,7 @@ get_message <- function(res, call, env = parent.frame()) { fail_default <- function(call, env) { call_string <- deparse(call, width.cutoff = 60L) if (length(call_string) > 1L) { - call_string <- paste0(call_string[1L], "...") + call_string <- paste0(call_string[1L], "...") } paste0(call_string, " is not TRUE") diff --git a/R/assertions.R b/R/assertions.R index c1f3d078..20d5356b 100644 --- a/R/assertions.R +++ b/R/assertions.R @@ -1,8 +1,7 @@ - is_string <- function(x) { is.character(x) && - length(x) == 1 && - !is.na(x) + length(x) == 1 && + !is.na(x) } on_failure(is_string) <- function(call, env) { @@ -19,8 +18,8 @@ on_failure(is_string_or_null) <- function(call, env) { is_flag <- function(x) { is.logical(x) && - length(x) == 1 && - !is.na(x) + length(x) == 1 && + !is.na(x) } on_failure(is_flag) <- function(call, env) { diff --git a/R/base64.R b/R/base64.R index a55b7b4c..f1f71081 100644 --- a/R/base64.R +++ b/R/base64.R @@ -1,4 +1,3 @@ - #' Base64 Encoding and Decoding #' #' @param x Raw vector to encode / decode. diff --git a/R/cleancall.R b/R/cleancall.R index 8023d6dc..11e4d246 100644 --- a/R/cleancall.R +++ b/R/cleancall.R @@ -1,4 +1,3 @@ - call_with_cleanup <- function(ptr, ...) { .Call(c_cleancall_call, pairlist(ptr, ...), parent.frame()) } diff --git a/R/client-lib.R b/R/client-lib.R index ab77dfa6..cdc8c51c 100644 --- a/R/client-lib.R +++ b/R/client-lib.R @@ -1,4 +1,3 @@ - client <- new.env(parent = emptyenv()) local({ @@ -27,7 +26,6 @@ local({ # devtools single <- system.file("src", paste0("client", ext), package = "processx") client[[paste0("arch-", arch)]] <- read_all(single) - } else { # not devtools single <- file.path(libs, paste0("client", ext)) @@ -35,7 +33,6 @@ local({ # not multiarch bts <- file.size(single) client[[paste0("arch-", arch)]] <- read_all(single) - } else { # multiarch multi <- dir(libs) @@ -62,7 +59,7 @@ load_client_lib <- function(client) { sym_encode <- getNativeSymbolInfo("processx_base64_encode", lib) sym_decode <- getNativeSymbolInfo("processx_base64_decode", lib) sym_disinh <- getNativeSymbolInfo("processx_disable_inheritance", lib) - sym_write <- getNativeSymbolInfo("processx_write", lib) + sym_write <- getNativeSymbolInfo("processx_write", lib) sym_setout <- getNativeSymbolInfo("processx_set_stdout", lib) sym_seterr <- getNativeSymbolInfo("processx_set_stderr", lib) sym_setoutf <- getNativeSymbolInfo("processx_set_stdout_to_file", lib) @@ -122,7 +119,8 @@ load_client_lib <- function(client) { reg.finalizer( env, function(e) if (".finalize" %in% names(e)) e$.finalize(), - onexit = TRUE) + onexit = TRUE + ) ## Clear the cleanup method on.exit(NULL) diff --git a/R/connections.R b/R/connections.R index fddd84a6..f2cb4f99 100644 --- a/R/connections.R +++ b/R/connections.R @@ -1,4 +1,3 @@ - #' Processx connections #' #' These functions are currently experimental and will change @@ -22,7 +21,8 @@ conn_create_fd <- function(fd, encoding = "", close = TRUE) { assert_that( is_integerish_scalar(fd), is_string(encoding), - is_flag(close)) + is_flag(close) + ) fd <- as.integer(fd) chain_call(c_processx_connection_create_fd, fd, encoding, close) } @@ -92,9 +92,17 @@ conn_create_fd <- function(fd, encoding = "", close = TRUE) { #' @rdname processx_fifos #' @export -conn_create_fifo <- function(filename = NULL, read = NULL, write = NULL, - encoding = "", nonblocking = TRUE) { - if (is.null(read) && is.null(write)) { read <- TRUE; write <- FALSE } +conn_create_fifo <- function( + filename = NULL, + read = NULL, + write = NULL, + encoding = "", + nonblocking = TRUE +) { + if (is.null(read) && is.null(write)) { + read <- TRUE + write <- FALSE + } if (is.null(read)) read <- !write if (is.null(write)) write <- !read @@ -107,7 +115,7 @@ conn_create_fifo <- function(filename = NULL, read = NULL, write = NULL, is_flag(read), is_flag(write), read || write, - ! (read && write), + !(read && write), is_string(encoding), is_flag(nonblocking) ) @@ -178,9 +186,17 @@ make_pipe_file_name <- function(filename) { #' #' close(reader) -conn_connect_fifo <- function(filename, read = NULL, write = NULL, - encoding = "", nonblocking = TRUE) { - if (is.null(read) && is.null(write)) { read <- TRUE; write <- FALSE } +conn_connect_fifo <- function( + filename, + read = NULL, + write = NULL, + encoding = "", + nonblocking = TRUE +) { + if (is.null(read) && is.null(write)) { + read <- TRUE + write <- FALSE + } if (is.null(read)) read <- !write if (is.null(write)) write <- !read @@ -193,7 +209,7 @@ conn_connect_fifo <- function(filename, read = NULL, write = NULL, is_flag(read), is_flag(write), read || write, - ! (read && write), + !(read && write), is_string(encoding), is_flag(nonblocking) ) @@ -240,12 +256,13 @@ conn_file_name <- function(con) { #' @rdname processx_connections #' @export -conn_create_pipepair <- function(encoding = "", - nonblocking = c(TRUE, FALSE)) { +conn_create_pipepair <- function(encoding = "", nonblocking = c(TRUE, FALSE)) { assert_that( is_string(encoding), - is.logical(nonblocking), length(nonblocking) == 2, - !any(is.na(nonblocking))) + is.logical(nonblocking), + length(nonblocking) == 2, + !any(is.na(nonblocking)) + ) chain_call(c_processx_connection_create_pipepair, encoding, nonblocking) } @@ -260,8 +277,7 @@ conn_create_pipepair <- function(encoding = "", #' @rdname processx_connections #' @export -conn_read_chars <- function(con, n = -1) - UseMethod("conn_read_chars", con) +conn_read_chars <- function(con, n = -1) UseMethod("conn_read_chars", con) #' @rdname processx_connections #' @export @@ -284,8 +300,7 @@ processx_conn_read_chars <- function(con, n = -1) { #' @rdname processx_connections #' @export -conn_read_lines <- function(con, n = -1) - UseMethod("conn_read_lines", con) +conn_read_lines <- function(con, n = -1) UseMethod("conn_read_lines", con) #' @rdname processx_connections #' @export @@ -309,8 +324,7 @@ processx_conn_read_lines <- function(con, n = -1) { #' @rdname processx_connections #' @export -conn_is_incomplete <- function(con) - UseMethod("conn_is_incomplete", con) +conn_is_incomplete <- function(con) UseMethod("conn_is_incomplete", con) #' @rdname processx_connections #' @export @@ -324,7 +338,7 @@ conn_is_incomplete.processx_connection <- function(con) { processx_conn_is_incomplete <- function(con) { assert_that(is_connection(con)) - ! chain_call(c_processx_connection_is_eof, con) + !chain_call(c_processx_connection_is_eof, con) } #' @details @@ -346,8 +360,12 @@ conn_write <- function(con, str, sep = "\n", encoding = "") #' @rdname processx_connections #' @export -conn_write.processx_connection <- function(con, str, sep = "\n", - encoding = "") { +conn_write.processx_connection <- function( + con, + str, + sep = "\n", + encoding = "" +) { processx_conn_write(con, str, sep, encoding) } @@ -357,9 +375,10 @@ conn_write.processx_connection <- function(con, str, sep = "\n", processx_conn_write <- function(con, str, sep = "\n", encoding = "") { assert_that( is_connection(con), - (is.character(str) && all(! is.na(str))) || is.raw(str), + (is.character(str) && all(!is.na(str))) || is.raw(str), is_string(sep), - is_string(encoding)) + is_string(encoding) + ) if (is.character(str)) { pstr <- paste(str, collapse = sep) @@ -382,7 +401,10 @@ processx_conn_write <- function(con, str, sep = "\n", encoding = "") { #' @export conn_create_file <- function(filename, read = NULL, write = NULL) { - if (is.null(read) && is.null(write)) { read <- TRUE; write <- FALSE } + if (is.null(read) && is.null(write)) { + read <- TRUE + write <- FALSE + } if (is.null(read)) read <- !write if (is.null(write)) write <- !read @@ -390,7 +412,8 @@ conn_create_file <- function(filename, read = NULL, write = NULL) { is_string(filename), is_flag(read), is_flag(write), - read || write) + read || write + ) chain_call(c_processx_connection_create_file, filename, read, write) } @@ -408,7 +431,8 @@ conn_create_file <- function(filename, read = NULL, write = NULL) { conn_set_stdout <- function(con, drop = TRUE) { assert_that( is_connection(con), - is_flag(drop)) + is_flag(drop) + ) flush(stdout()) invisible(chain_call(c_processx_connection_set_stdout, con, drop)) @@ -424,7 +448,8 @@ conn_set_stdout <- function(con, drop = TRUE) { conn_set_stderr <- function(con, drop = TRUE) { assert_that( is_connection(con), - is_flag(drop)) + is_flag(drop) + ) flush(stderr()) invisible(chain_call(c_processx_connection_set_stderr, con, drop)) @@ -542,7 +567,6 @@ is_valid_fd <- function(fd) { #' @export conn_create_unix_socket <- function(filename = NULL, encoding = "") { - assert_that( is_string_or_null(filename), is_string(encoding) @@ -561,7 +585,6 @@ conn_create_unix_socket <- function(filename = NULL, encoding = "") { #' @export conn_connect_unix_socket <- function(filename, encoding = "") { - assert_that( is_string_or_null(filename), is_string(encoding) diff --git a/R/initialize.R b/R/initialize.R index 3d7b6d4a..f46f7d04 100644 --- a/R/initialize.R +++ b/R/initialize.R @@ -1,4 +1,3 @@ - #' Start a process #' #' @param self this @@ -22,14 +21,30 @@ #' #' @keywords internal -process_initialize <- function(self, private, command, args, - stdin, stdout, stderr, pty, pty_options, - connections, poll_connection, env, cleanup, - cleanup_tree, wd, echo_cmd, supervise, - windows_verbatim_args, windows_hide_window, - windows_detached_process, encoding, - post_process) { - +process_initialize <- function( + self, + private, + command, + args, + stdin, + stdout, + stderr, + pty, + pty_options, + connections, + poll_connection, + env, + cleanup, + cleanup_tree, + wd, + echo_cmd, + supervise, + windows_verbatim_args, + windows_hide_window, + windows_detached_process, + encoding, + post_process +) { "!DEBUG process_initialize `command`" assert_that( @@ -39,7 +54,8 @@ process_initialize <- function(self, private, command, args, is_std_conn(stdout), is_std_conn(stderr), is_flag(pty), - is.list(pty_options), is_named(pty_options), + is.list(pty_options), + is_named(pty_options), is_connection_list(connections), is.null(poll_connection) || is_flag(poll_connection), is.null(env) || is_env_vector(env), @@ -51,11 +67,14 @@ process_initialize <- function(self, private, command, args, is_flag(windows_hide_window), is_flag(windows_detached_process), is_string(encoding), - is.function(post_process) || is.null(post_process)) + is.function(post_process) || is.null(post_process) + ) if (cleanup_tree && !cleanup) { - warning("`cleanup_tree` overrides `cleanup`, and process will be ", - "killed on GC") + warning( + "`cleanup_tree` overrides `cleanup`, and process will be ", + "killed on GC" + ) cleanup <- TRUE } @@ -78,8 +97,10 @@ process_initialize <- function(self, private, command, args, def <- default_pty_options() pty_options <- utils::modifyList(def, pty_options) if (length(bad <- setdiff(names(def), names(pty_options)))) { - throw(new_error("Uknown pty option(s): ", - paste(paste0("`", bad, "`"), collapse = ", "))) + throw(new_error( + "Uknown pty option(s): ", + paste(paste0("`", bad, "`"), collapse = ", ") + )) } pty_options$rows <- as.integer(pty_options$rows) pty_options$cols <- as.integer(pty_options$cols) @@ -114,8 +135,7 @@ process_initialize <- function(self, private, command, args, private$post_process <- post_process poll_connection <- poll_connection %||% - (!identical(stdout, "|") && !identical(stderr, "|") && - !length(connections)) + (!identical(stdout, "|") && !identical(stderr, "|") && !length(connections)) if (poll_connection) { pipe <- conn_create_pipepair() connections <- c(connections, list(pipe[[2]])) @@ -137,9 +157,19 @@ process_initialize <- function(self, private, command, args, "!DEBUG process_initialize exec()" private$status <- chain_call( c_processx_exec, - command, c(command, args), pty, pty_options, - connections, env, windows_verbatim_args, windows_hide_window, - windows_detached_process, private, cleanup, wd, encoding, + command, + c(command, args), + pty, + pty_options, + connections, + env, + windows_verbatim_args, + windows_hide_window, + windows_detached_process, + private, + cleanup, + wd, + encoding, paste0("PROCESSX_", private$tree_id, "=YES") ) @@ -166,7 +196,7 @@ process_initialize <- function(self, private, command, args, stderr <- full_path(stderr) ## Store the output and error files, we'll open them later if needed - private$stdin <- stdin + private$stdin <- stdin private$stdout <- stdout private$stderr <- stderr diff --git a/R/io.R b/R/io.R index d805d161..13569621 100644 --- a/R/io.R +++ b/R/io.R @@ -1,4 +1,3 @@ - process_has_input_connection <- function(self, private) { "!DEBUG process_has_input_connection `private$get_short_name()`" !is.null(private$stdin_pipe) @@ -21,22 +20,19 @@ process_has_poll_connection <- function(self, private) { process_get_input_connection <- function(self, private) { "!DEBUG process_get_input_connection `private$get_short_name()`" - if (!self$has_input_connection()) - throw(new_error("stdin is not a pipe.")) + if (!self$has_input_connection()) throw(new_error("stdin is not a pipe.")) private$stdin_pipe } process_get_output_connection <- function(self, private) { "!DEBUG process_get_output_connection `private$get_short_name()`" - if (!self$has_output_connection()) - throw(new_error("stdout is not a pipe.")) + if (!self$has_output_connection()) throw(new_error("stdout is not a pipe.")) private$stdout_pipe } process_get_error_connection <- function(self, private) { "!DEBUG process_get_error_connection `private$get_short_name()`" - if (!self$has_error_connection()) - throw(new_error("stderr is not a pipe.")) + if (!self$has_error_connection()) throw(new_error("stderr is not a pipe.")) private$stderr_pipe } @@ -57,7 +53,6 @@ process_read_error <- function(self, private, n) { "!DEBUG process_read_error `private$get_short_name()`" con <- process_get_error_connection(self, private) chain_call(c_processx_connection_read_chars, con, n) - } process_read_output_lines <- function(self, private, n) { @@ -77,12 +72,12 @@ process_read_error_lines <- function(self, private, n) { process_is_incompelete_output <- function(self, private) { con <- process_get_output_connection(self, private) - ! chain_call(c_processx_connection_is_eof, con) + !chain_call(c_processx_connection_is_eof, con) } process_is_incompelete_error <- function(self, private) { con <- process_get_error_connection(self, private) - ! chain_call(c_processx_connection_is_eof, con) + !chain_call(c_processx_connection_is_eof, con) } process_read_all_output <- function(self, private) { @@ -145,13 +140,13 @@ process_get_error_file <- function(self, private) { # Corresponds to processx.h, update there as well poll_codes <- c( - "nopipe", # PXNOPIPE - "ready", # PXREADY - "timeout", # PXTIMEOUT - "closed", # PXCLOSED - "silent", # PXSILENT - "event", # PXEVENT - "connect" # PXCONNECT + "nopipe", # PXNOPIPE + "ready", # PXREADY + "timeout", # PXTIMEOUT + "closed", # PXCLOSED + "silent", # PXSILENT + "event", # PXEVENT + "connect" # PXCONNECT ) process_poll_io <- function(self, private, ms) { diff --git a/R/named_pipe.R b/R/named_pipe.R index 4a23915f..e55789de 100644 --- a/R/named_pipe.R +++ b/R/named_pipe.R @@ -7,7 +7,6 @@ named_pipe_tempfile <- function(prefix = "pipe") { # several seconds the first time it's called in an R session. So we'll do it # manually with paste0. paste0("\\\\.\\pipe", tempfile(prefix, "")) - } else { tempfile(prefix) } @@ -33,7 +32,9 @@ is_pipe_open.unix_named_pipe <- function(pipe) { is_open <- NA tryCatch( is_open <- isOpen(pipe$handle), - error = function(e) { is_open <<- FALSE } + error = function(e) { + is_open <<- FALSE + } ) is_open @@ -48,7 +49,6 @@ create_named_pipe <- function(name) { ), class = c("windows_named_pipe", "named_pipe") ) - } else { structure( list( @@ -84,8 +84,7 @@ write_lines_named_pipe.windows_named_pipe <- function(pipe, text) { # Make sure it ends with \n len <- nchar(text) - if (substr(text, len, len) != "\n") - text <- paste0(text, "\n") + if (substr(text, len, len) != "\n") text <- paste0(text, "\n") chain_call(c_processx_write_named_pipe, pipe$handle, text) } diff --git a/R/on-load.R b/R/on-load.R index 6ade28dd..2799cd4e 100644 --- a/R/on-load.R +++ b/R/on-load.R @@ -1,4 +1,3 @@ - ## nocov start .onLoad <- function(libname, pkgname) { @@ -13,8 +12,10 @@ } supervisor_reset() - if (Sys.getenv("DEBUGME", "") != "" && - requireNamespace("debugme", quietly = TRUE)) { + if ( + Sys.getenv("DEBUGME", "") != "" && + requireNamespace("debugme", quietly = TRUE) + ) { debugme::debugme() } diff --git a/R/poll.R b/R/poll.R index 92bbf9b5..67f3ca02 100644 --- a/R/poll.R +++ b/R/poll.R @@ -1,4 +1,3 @@ - #' Poll for process I/O or termination #' #' Wait until one of the specified connections or processes produce @@ -102,5 +101,6 @@ poll <- function(processes, ms) { curl_fds <- function(fds) { structure( list(fds$reads, fds$writes, fds$exceptions), - class = "processx_curl_fds") + class = "processx_curl_fds" + ) } diff --git a/R/print.R b/R/print.R index 1937e82a..42039ac8 100644 --- a/R/print.R +++ b/R/print.R @@ -1,6 +1,4 @@ - process_format <- function(self, private) { - state <- if (self$is_alive()) { pid <- self$get_pid() paste0("running, pid ", paste(pid, collapse = ", "), ".") @@ -10,7 +8,9 @@ process_format <- function(self, private) { paste0( "PROCESS ", - "'", private$get_short_name(), "', ", + "'", + private$get_short_name(), + "', ", state, "\n" ) diff --git a/R/process-helpers.R b/R/process-helpers.R index 70d1873c..d1e7e62a 100644 --- a/R/process-helpers.R +++ b/R/process-helpers.R @@ -1,4 +1,3 @@ - process__exists <- function(pid) { chain_call(c_processx__process_exists, pid) } diff --git a/R/process.R b/R/process.R index 93708d55..85ec87e5 100644 --- a/R/process.R +++ b/R/process.R @@ -1,4 +1,3 @@ - #' @useDynLib processx, .registration = TRUE, .fixes = "c_" NULL @@ -96,7 +95,6 @@ dummy_r6 <- function() R6::R6Class process <- R6::R6Class( "process", public = list( - #' @description #' Start a new process in the background, and then return immediately. #' @@ -208,20 +206,52 @@ process <- R6::R6Class( #' finished. Currently it only runs if `$get_result()` is called. #' It is only run once. - initialize = function(command = NULL, args = character(), - stdin = NULL, stdout = NULL, stderr = NULL, pty = FALSE, - pty_options = list(), connections = list(), poll_connection = NULL, - env = NULL, cleanup = TRUE, cleanup_tree = FALSE, wd = NULL, - echo_cmd = FALSE, supervise = FALSE, windows_verbatim_args = FALSE, - windows_hide_window = FALSE, windows_detached_process = !cleanup, - encoding = "", post_process = NULL) - - process_initialize(self, private, command, args, stdin, - stdout, stderr, pty, pty_options, connections, - poll_connection, env, cleanup, cleanup_tree, wd, - echo_cmd, supervise, windows_verbatim_args, - windows_hide_window, windows_detached_process, - encoding, post_process), + initialize = function( + command = NULL, + args = character(), + stdin = NULL, + stdout = NULL, + stderr = NULL, + pty = FALSE, + pty_options = list(), + connections = list(), + poll_connection = NULL, + env = NULL, + cleanup = TRUE, + cleanup_tree = FALSE, + wd = NULL, + echo_cmd = FALSE, + supervise = FALSE, + windows_verbatim_args = FALSE, + windows_hide_window = FALSE, + windows_detached_process = !cleanup, + encoding = "", + post_process = NULL + ) + process_initialize( + self, + private, + command, + args, + stdin, + stdout, + stderr, + pty, + pty_options, + connections, + poll_connection, + env, + cleanup, + cleanup_tree, + wd, + echo_cmd, + supervise, + windows_verbatim_args, + windows_hide_window, + windows_detached_process, + encoding, + post_process + ), #' @description #' Terminate the process. It also terminate all of its child @@ -259,8 +289,7 @@ process <- R6::R6Class( #' @param signal An integer scalar, the id of the signal to send to #' the process. See [tools::pskill()] for the list of signals. - signal = function(signal) - process_signal(self, private, signal), + signal = function(signal) process_signal(self, private, signal), #' @description #' Send an interrupt to the process. On Unix this is a @@ -268,21 +297,18 @@ process <- R6::R6Class( #' the terminal prompt. On Windows, it is a CTRL+BREAK keypress. #' Applications may catch these events. By default they will quit. - interrupt = function() - process_interrupt(self, private), + interrupt = function() process_interrupt(self, private), #' @description #' Query the process id. #' @return Integer scalar, the process id of the process. - get_pid = function() - process_get_pid(self, private), + get_pid = function() process_get_pid(self, private), #' @description Check if the process is alive. #' @return Logical scalar. - is_alive = function() - process_is_alive(self, private), + is_alive = function() process_is_alive(self, private), #' @description #' Wait until the process finishes, or a timeout happens. @@ -295,8 +321,7 @@ process <- R6::R6Class( #' through `parallel::mcparallel()`. #' @return It returns the process itself, invisibly. - wait = function(timeout = -1) - process_wait(self, private, timeout), + wait = function(timeout = -1) process_wait(self, private, timeout), #' @description #' `$get_exit_status` returns the exit code of the process if it has @@ -307,36 +332,31 @@ process <- R6::R6Class( #' status of the process. One such package is parallel, if used with #' fork clusters, e.g. through the `parallel::mcparallel()` function. - get_exit_status = function() - process_get_exit_status(self, private), + get_exit_status = function() process_get_exit_status(self, private), #' @description #' `format(p)` or `p$format()` creates a string representation of the #' process, usually for printing. - format = function() - process_format(self, private), + format = function() process_format(self, private), #' @description #' `print(p)` or `p$print()` shows some information about the #' process on the screen, whether it is running and it's process id, etc. - print = function() - process_print(self, private), + print = function() process_print(self, private), #' @description #' `$get_start_time()` returns the time when the process was #' started. - get_start_time = function() - process_get_start_time(self, private), + get_start_time = function() process_get_start_time(self, private), #' @description #' `$is_supervised()` returns whether the process is being tracked by #' supervisor process. - is_supervised = function() - process_is_supervised(self, private), + is_supervised = function() process_is_supervised(self, private), #' @description #' `$supervise()` if passed `TRUE`, tells the supervisor to start @@ -347,8 +367,7 @@ process <- R6::R6Class( #' @param status Whether to turn on of off the supervisor for this #' process. - supervise = function(status) - process_supervise(self, private, status), + supervise = function(status) process_supervise(self, private, status), ## Output @@ -359,15 +378,13 @@ process <- R6::R6Class( #' will work only if `stdout="|"` was used. Otherwise, it will throw an #' error. - read_output = function(n = -1) - process_read_output(self, private, n), + read_output = function(n = -1) process_read_output(self, private, n), #' @description #' `$read_error()` is similar to `$read_output`, but it reads #' from the standard error stream. - read_error = function(n = -1) - process_read_error(self, private, n), + read_error = function(n = -1) process_read_error(self, private, n), #' @description #' `$read_output_lines()` reads lines from standard output connection @@ -430,14 +447,13 @@ process <- R6::R6Class( #' `$has_poll_connection()` return `TRUE` if there is a poll connection, #' `FALSE` otherwise. - has_poll_connection = function() - process_has_poll_connection(self, private), + has_poll_connection = function() process_has_poll_connection(self, private), #' @description #' `$get_input_connection()` returns a connection object, to the #' standard input stream of the process. - get_input_connection = function() + get_input_connection = function() process_get_input_connection(self, private), #' @description @@ -462,8 +478,7 @@ process <- R6::R6Class( #' It returns a character scalar. This will return content only if #' `stdout="|"` was used. Otherwise, it will throw an error. - read_all_output = function() - process_read_all_output(self, private), + read_all_output = function() process_read_all_output(self, private), #' @description #' `$read_all_error()` waits for all standard error from the process. @@ -473,8 +488,7 @@ process <- R6::R6Class( #' It returns a character scalar. This will return content only if #' `stderr="|"` was used. Otherwise, it will throw an error. - read_all_error = function() - process_read_all_error(self, private), + read_all_error = function() process_read_all_error(self, private), #' @description #' `$read_all_output_lines()` waits for all standard output lines @@ -523,140 +537,122 @@ process <- R6::R6Class( #' this returns the absolute path to the file. If `stdin` was `"|"` or #' `NULL`, this simply returns that value. - get_input_file = function() - process_get_input_file(self, private), + get_input_file = function() process_get_input_file(self, private), #' @description #' `$get_output_file()` if the `stdout` argument was a filename, #' this returns the absolute path to the file. If `stdout` was `"|"` or #' `NULL`, this simply returns that value. - get_output_file = function() - process_get_output_file(self, private), + get_output_file = function() process_get_output_file(self, private), #' @description #' `$get_error_file()` if the `stderr` argument was a filename, #' this returns the absolute path to the file. If `stderr` was `"|"` or #' `NULL`, this simply returns that value. - get_error_file = function() - process_get_error_file(self, private), + get_error_file = function() process_get_error_file(self, private), #' @description #' `$poll_io()` polls the process's connections for I/O. See more in #' the _Polling_ section, and see also the [poll()] function #' to poll on multiple processes. - poll_io = function(timeout) - process_poll_io(self, private, timeout), + poll_io = function(timeout) process_poll_io(self, private, timeout), #' @description #' `$get_poll_connetion()` returns the poll connection, if the process has #' one. - get_poll_connection = function() - process_get_poll_connection(self, private), + get_poll_connection = function() process_get_poll_connection(self, private), #' @description #' `$get_result()` returns the result of the post processesing function. #' It can only be called once the process has finished. If the process has #' no post-processing function, then `NULL` is returned. - get_result = function() - process_get_result(self, private), + get_result = function() process_get_result(self, private), #' @description #' `$as_ps_handle()` returns a [ps::ps_handle] object, corresponding to #' the process. - as_ps_handle = function() - process_as_ps_handle(self, private), + as_ps_handle = function() process_as_ps_handle(self, private), #' @description #' Calls [ps::ps_name()] to get the process name. - get_name = function() - ps_method(ps::ps_name, self), + get_name = function() ps_method(ps::ps_name, self), #' @description #' Calls [ps::ps_exe()] to get the path of the executable. - get_exe = function() - ps_method(ps::ps_exe, self), + get_exe = function() ps_method(ps::ps_exe, self), #' @description #' Calls [ps::ps_cmdline()] to get the command line. - get_cmdline = function() - ps_method(ps::ps_cmdline, self), + get_cmdline = function() ps_method(ps::ps_cmdline, self), #' @description #' Calls [ps::ps_status()] to get the process status. - get_status = function() - ps_method(ps::ps_status, self), + get_status = function() ps_method(ps::ps_status, self), #' @description #' calls [ps::ps_username()] to get the username. - get_username = function() - ps_method(ps::ps_username, self), + get_username = function() ps_method(ps::ps_username, self), #' @description #' Calls [ps::ps_cwd()] to get the current working directory. - get_wd = function() - ps_method(ps::ps_cwd, self), + get_wd = function() ps_method(ps::ps_cwd, self), #' @description #' Calls [ps::ps_cpu_times()] to get CPU usage data. - get_cpu_times = function() - ps_method(ps::ps_cpu_times, self), + get_cpu_times = function() ps_method(ps::ps_cpu_times, self), #' @description #' Calls [ps::ps_memory_info()] to get memory data. - get_memory_info = function() - ps_method(ps::ps_memory_info, self), + get_memory_info = function() ps_method(ps::ps_memory_info, self), #' @description #' Calls [ps::ps_suspend()] to suspend the process. - suspend = function() - ps_method(ps::ps_suspend, self), + suspend = function() ps_method(ps::ps_suspend, self), #' @description #' Calls [ps::ps_resume()] to resume a suspended process. - resume = function() - ps_method(ps::ps_resume, self) + resume = function() ps_method(ps::ps_resume, self) ), private = list( - - command = NULL, # Save 'command' argument here - args = NULL, # Save 'args' argument here - cleanup = NULL, # cleanup argument - cleanup_tree = NULL, # cleanup_tree argument - stdin = NULL, # stdin argument or stream - stdout = NULL, # stdout argument or stream - stderr = NULL, # stderr argument or stream - pty = NULL, # whether we should create a PTY - pty_options = NULL, # various PTY options - pstdin = NULL, # the original stdin argument - pstdout = NULL, # the original stdout argument - pstderr = NULL, # the original stderr argument - cleanfiles = NULL, # which temp stdout/stderr file(s) to clean up - wd = NULL, # working directory (or NULL for current) - starttime = NULL, # timestamp of start - echo_cmd = NULL, # whether to echo the command + command = NULL, # Save 'command' argument here + args = NULL, # Save 'args' argument here + cleanup = NULL, # cleanup argument + cleanup_tree = NULL, # cleanup_tree argument + stdin = NULL, # stdin argument or stream + stdout = NULL, # stdout argument or stream + stderr = NULL, # stderr argument or stream + pty = NULL, # whether we should create a PTY + pty_options = NULL, # various PTY options + pstdin = NULL, # the original stdin argument + pstdout = NULL, # the original stdout argument + pstderr = NULL, # the original stderr argument + cleanfiles = NULL, # which temp stdout/stderr file(s) to clean up + wd = NULL, # working directory (or NULL for current) + starttime = NULL, # timestamp of start + echo_cmd = NULL, # whether to echo the command windows_verbatim_args = NULL, windows_hide_window = NULL, - status = NULL, # C file handle + status = NULL, # C file handle - supervised = FALSE, # Whether process is tracked by supervisor + supervised = FALSE, # Whether process is tracked by supervisor stdin_pipe = NULL, stdout_pipe = NULL, @@ -676,14 +672,16 @@ process <- R6::R6Class( tree_id = NULL, finalize = function() { - if (!is.null(private$tree_id) && private$cleanup_tree && - ps::ps_is_supported()) self$kill_tree() + if ( + !is.null(private$tree_id) && + private$cleanup_tree && + ps::ps_is_supported() + ) + self$kill_tree() }, - get_short_name = function() - process_get_short_name(self, private), - close_connections = function() - process_close_connections(self, private) + get_short_name = function() process_get_short_name(self, private), + close_connections = function() process_close_connections(self, private) ) ) @@ -693,7 +691,8 @@ process <- R6::R6Class( process_wait <- function(self, private, timeout) { "!DEBUG process_wait `private$get_short_name()`" chain_clean_call( - c_processx_wait, private$status, + c_processx_wait, + private$status, as.integer(timeout), private$get_short_name() ) @@ -707,14 +706,21 @@ process_is_alive <- function(self, private) { process_get_exit_status <- function(self, private) { "!DEBUG process_get_exit_status `private$get_short_name()`" - chain_call(c_processx_get_exit_status, private$status, - private$get_short_name()) + chain_call( + c_processx_get_exit_status, + private$status, + private$get_short_name() + ) } process_signal <- function(self, private, signal) { "!DEBUG process_signal `private$get_short_name()` `signal`" - chain_call(c_processx_signal, private$status, as.integer(signal), - private$get_short_name()) + chain_call( + c_processx_signal, + private$status, + as.integer(signal), + private$get_short_name() + ) } process_interrupt <- function(self, private) { @@ -724,15 +730,18 @@ process_interrupt <- function(self, private) { st <- run(get_tool("interrupt"), c(pid, "c"), error_on_status = FALSE) if (st$status == 0) TRUE else FALSE } else { - chain_call(c_processx_interrupt, private$status, - private$get_short_name()) + chain_call(c_processx_interrupt, private$status, private$get_short_name()) } } process_kill <- function(self, private, grace, close_connections) { "!DEBUG process_kill '`private$get_short_name()`', pid `self$get_pid()`" - ret <- chain_call(c_processx_kill, private$status, as.numeric(grace), - private$get_short_name()) + ret <- chain_call( + c_processx_kill, + private$status, + as.numeric(grace), + private$get_short_name() + ) if (close_connections) private$close_connections() ret } @@ -741,7 +750,8 @@ process_kill_tree <- function(self, private, grace, close_connections) { "!DEBUG process_kill_tree '`private$get_short_name()`', pid `self$get_pid()`" if (!ps::ps_is_supported()) { throw(new_not_implemented_error( - "kill_tree is not supported on this platform")) + "kill_tree is not supported on this platform" + )) } ret <- get("ps_kill_tree", asNamespace("ps"))(private$tree_id) @@ -765,7 +775,6 @@ process_supervise <- function(self, private, status) { if (status && !self$is_supervised()) { supervisor_watch_pid(self$get_pid()) private$supervised <- TRUE - } else if (!status && self$is_supervised()) { supervisor_unwatch_pid(self$get_pid()) private$supervised <- FALSE diff --git a/R/run.R b/R/run.R index 52eaf096..93548640 100644 --- a/R/run.R +++ b/R/run.R @@ -155,24 +155,41 @@ #' error_on_status = FALSE) run <- function( - command = NULL, args = character(), error_on_status = TRUE, wd = NULL, - echo_cmd = FALSE, echo = FALSE, spinner = FALSE, - timeout = Inf, stdout = "|", stderr = "|", - stdout_line_callback = NULL, stdout_callback = NULL, - stderr_line_callback = NULL, stderr_callback = NULL, - stderr_to_stdout = FALSE, env = NULL, - windows_verbatim_args = FALSE, windows_hide_window = FALSE, - encoding = "", cleanup_tree = FALSE, ...) { - + command = NULL, + args = character(), + error_on_status = TRUE, + wd = NULL, + echo_cmd = FALSE, + echo = FALSE, + spinner = FALSE, + timeout = Inf, + stdout = "|", + stderr = "|", + stdout_line_callback = NULL, + stdout_callback = NULL, + stderr_line_callback = NULL, + stderr_callback = NULL, + stderr_to_stdout = FALSE, + env = NULL, + windows_verbatim_args = FALSE, + windows_hide_window = FALSE, + encoding = "", + cleanup_tree = FALSE, + ... +) { assert_that(is_flag(error_on_status)) assert_that(is_time_interval(timeout)) assert_that(is_flag(spinner)) assert_that(is_string_or_null(stdout)) assert_that(is_string_or_null(stderr)) - assert_that(is.null(stdout_line_callback) || - is.function(stdout_line_callback)) - assert_that(is.null(stderr_line_callback) || - is.function(stderr_line_callback)) + assert_that( + is.null(stdout_line_callback) || + is.function(stdout_line_callback) + ) + assert_that( + is.null(stderr_line_callback) || + is.function(stderr_line_callback) + ) assert_that(is.null(stdout_callback) || is.function(stdout_callback)) assert_that(is.null(stderr_callback) || is.function(stderr_callback)) assert_that(is_flag(cleanup_tree)) @@ -185,11 +202,18 @@ run <- function( ## Run the process if (stderr_to_stdout) stderr <- "2>&1" pr <- process$new( - command, args, echo_cmd = echo_cmd, wd = wd, + command, + args, + echo_cmd = echo_cmd, + wd = wd, windows_verbatim_args = windows_verbatim_args, windows_hide_window = windows_hide_window, - stdout = stdout, stderr = stderr, env = env, encoding = encoding, - cleanup_tree = cleanup_tree, ... + stdout = stdout, + stderr = stderr, + env = env, + encoding = encoding, + cleanup_tree = cleanup_tree, + ... ) "#!DEBUG run() Started the process: `pr$get_pid()`" @@ -223,9 +247,18 @@ run <- function( } res <- tryCatch( - run_manage(pr, timeout, spinner, stdout, stderr, - stdout_line_callback, stdout_callback, - stderr_line_callback, stderr_callback, resenv), + run_manage( + pr, + timeout, + spinner, + stdout, + stderr, + stdout_line_callback, + stdout_callback, + stderr_line_callback, + stderr_callback, + resenv + ), interrupt = function(e) { "!DEBUG run() process `pr$get_pid()` killed on interrupt" out <- if (has_stdout) { @@ -241,10 +274,15 @@ run <- function( tryCatch(pr$kill(), error = function(e) NULL) signalCondition(new_process_interrupt_cond( list( - interrupt = TRUE, stderr = err, stdout = out, - command = command, args = args + interrupt = TRUE, + stderr = err, + stdout = out, + command = command, + args = args ), - runcall, echo = echo, stderr_to_stdout = stderr_to_stdout + runcall, + echo = echo, + stderr_to_stdout = stderr_to_stdout )) cat("\n") invokeRestart("abort") @@ -253,9 +291,15 @@ run <- function( if (error_on_status && (is.na(res$status) || res$status != 0)) { "!DEBUG run() error on status `res$status` for process `pr$get_pid()`" - throw(new_process_error(res, call = sys.call(), echo = echo, - stderr_to_stdout, res$status, command = command, - args = args)) + throw(new_process_error( + res, + call = sys.call(), + echo = echo, + stderr_to_stdout, + res$status, + command = command, + args = args + )) } res @@ -271,10 +315,18 @@ echo_callback <- function(user_callback, type) { } } -run_manage <- function(proc, timeout, spinner, stdout, stderr, - stdout_line_callback, stdout_callback, - stderr_line_callback, stderr_callback, resenv) { - +run_manage <- function( + proc, + timeout, + spinner, + stdout, + stderr, + stdout_line_callback, + stdout_callback, + stderr_line_callback, + stderr_callback, + resenv +) { timeout <- as.difftime(timeout, units = "secs") start_time <- proc$get_start_time() @@ -285,14 +337,16 @@ run_manage <- function(proc, timeout, spinner, stdout, stderr, pushback_err <- "" do_output <- function() { - ok <- FALSE if (has_stdout) { - newout <- tryCatch({ - ret <- proc$read_output(2000) - ok <- TRUE - ret - }, error = function(e) NULL) + newout <- tryCatch( + { + ret <- proc$read_output(2000) + ok <- TRUE + ret + }, + error = function(e) NULL + ) if (length(newout) && nzchar(newout)) { if (!is.null(stdout_callback)) stdout_callback(newout, proc) @@ -311,11 +365,14 @@ run_manage <- function(proc, timeout, spinner, stdout, stderr, } if (has_stderr) { - newerr <- tryCatch({ - ret <- proc$read_error(2000) - ok <- TRUE - ret - }, error = function(e) NULL) + newerr <- tryCatch( + { + ret <- proc$read_error(2000) + ok <- TRUE + ret + }, + error = function(e) NULL + ) if (length(newerr) && nzchar(newerr)) { resenv$errbuf$push(newerr) @@ -350,8 +407,11 @@ run_manage <- function(proc, timeout, spinner, stdout, stderr, while (proc$is_alive()) { ## Timeout? Maybe finished by now... - if (!is.null(timeout) && is.finite(timeout) && - Sys.time() - start_time > timeout) { + if ( + !is.null(timeout) && + is.finite(timeout) && + Sys.time() - start_time > timeout + ) { if (proc$kill(close_connections = FALSE)) timeout_happened <- TRUE "!DEBUG Timeout killed run() process `proc$get_pid()`" break @@ -383,8 +443,10 @@ run_manage <- function(proc, timeout, spinner, stdout, stderr, ## We might still have output "!DEBUG run() reading leftover output / error, process `proc$get_pid()`" - while ((has_stdout && proc$is_incomplete_output()) || - (proc$has_error_connection() && proc$is_incomplete_error())) { + while ( + (has_stdout && proc$is_incomplete_output()) || + (proc$has_error_connection() && proc$is_incomplete_error()) + ) { proc$poll_io(-1) if (!do_output()) break } @@ -399,21 +461,51 @@ run_manage <- function(proc, timeout, spinner, stdout, stderr, ) } -new_process_error <- function(result, call, echo, stderr_to_stdout, - status = NA_integer_, command, args) { +new_process_error <- function( + result, + call, + echo, + stderr_to_stdout, + status = NA_integer_, + command, + args +) { if (isTRUE(result$timeout)) { - new_process_timeout_error(result, call, echo, stderr_to_stdout, status, - command, args) + new_process_timeout_error( + result, + call, + echo, + stderr_to_stdout, + status, + command, + args + ) } else { - new_process_status_error(result, call, echo, stderr_to_stdout, status, - command, args) + new_process_status_error( + result, + call, + echo, + stderr_to_stdout, + status, + command, + args + ) } } -new_process_status_error <- function(result, call, echo, stderr_to_stdout, - status = NA_integer_, command, args) { +new_process_status_error <- function( + result, + call, + echo, + stderr_to_stdout, + status = NA_integer_, + command, + args +) { err <- new_error( - "System command '", basename(command), "' failed", + "System command '", + basename(command), + "' failed", call. = call ) err$stderr <- if (stderr_to_stdout) result$stdout else result$stderr @@ -424,10 +516,17 @@ new_process_status_error <- function(result, call, echo, stderr_to_stdout, add_class(err, c("system_command_status_error", "system_command_error")) } -new_process_interrupt_cond <- function(result, call, echo, stderr_to_stdout, - status = NA_integer_) { +new_process_interrupt_cond <- function( + result, + call, + echo, + stderr_to_stdout, + status = NA_integer_ +) { cond <- new_cond( - "System command '", basename(result$command), "' interrupted", + "System command '", + basename(result$command), + "' interrupted", call. = call ) cond$stderr <- if (stderr_to_stdout) result$stdout else result$stderr @@ -438,10 +537,21 @@ new_process_interrupt_cond <- function(result, call, echo, stderr_to_stdout, add_class(cond, c("system_command_interrupt", "interrupt")) } -new_process_timeout_error <- function(result, call, echo, stderr_to_stdout, - status = NA_integer_, command, args) { +new_process_timeout_error <- function( + result, + call, + echo, + stderr_to_stdout, + status = NA_integer_, + command, + args +) { err <- new_error( - "System command '", basename(command), "' timed out", call. = call) + "System command '", + basename(command), + "' timed out", + call. = call + ) err$stderr <- if (stderr_to_stdout) result$stdout else result$stderr err$echo <- echo err$stderr_to_stdout <- stderr_to_stdout @@ -452,8 +562,13 @@ new_process_timeout_error <- function(result, call, echo, stderr_to_stdout, #' @export -format.system_command_error <- function(x, trace = TRUE, class = TRUE, - advice = !trace, ...) { +format.system_command_error <- function( + x, + trace = TRUE, + class = TRUE, + advice = !trace, + ... +) { class(x) <- setdiff(class(x), "system_command_error") lines <- NextMethod( diff --git a/R/standalone-errors.R b/R/standalone-errors.R index 35d78374..28a6b3a6 100644 --- a/R/standalone-errors.R +++ b/R/standalone-errors.R @@ -168,7 +168,6 @@ # * `call.` can now be a frame environment as in `rlang::abort()` err <- local({ - # -- dependencies ----------------------------------------------------- rstudio_detect <- rstudio$detect @@ -195,7 +194,8 @@ err <- local({ message <- .makeMessage(..., domain = domain) structure( list(message = message, call = call., srcref = srcref), - class = c("condition")) + class = c("condition") + ) } #' Create a new error condition @@ -231,10 +231,12 @@ err <- local({ #' @param frame The throwing context. Can be used to hide frames from #' the backtrace. - throw <- throw_error <- function(cond, - parent = NULL, - call = parent.frame(), - frame = environment()) { + throw <- throw_error <- function( + cond, + parent = NULL, + call = parent.frame(), + frame = environment() + ) { if (!inherits(cond, "condition")) { cond <- new_error(cond) } @@ -278,9 +280,11 @@ err <- local({ # baseenv(), so it is almost as if it was in baseenv() itself, like # .Last.value. We save the print methods here as well, and then they # will be found automatically. - if (! "org:r-lib" %in% search()) { - do.call("attach", list(new.env(), pos = length(search()), - name = "org:r-lib")) + if (!"org:r-lib" %in% search()) { + do.call( + "attach", + list(new.env(), pos = length(search()), name = "org:r-lib") + ) } env <- as.environment("org:r-lib") env$.Last.error <- cond @@ -291,13 +295,15 @@ err <- local({ # If this is not an error, then we'll just return here. This allows # throwing interrupt conditions for example, with the same UI. - if (! inherits(cond, "error")) return(invisible()) + if (!inherits(cond, "error")) return(invisible()) .hide_from_trace <- NULL # Top-level handler, this is intended for testing only for now, # and its design might change. - if (!is.null(th <- getOption("rlib_error_handler")) && - is.function(th)) { + if ( + !is.null(th <- getOption("rlib_error_handler")) && + is.function(th) + ) { return(th(cond)) } @@ -345,17 +351,20 @@ err <- local({ .hide_from_trace <- 1 force(call) srcref <- srcref %||% utils::getSrcref(sys.call()) - withCallingHandlers({ - expr - }, error = function(e) { - .hide_from_trace <- 0:1 - e$srcref <- srcref - e$procsrcref <- NULL - if (!inherits(err, "condition")) { - err <- new_error(err, call. = call) + withCallingHandlers( + { + expr + }, + error = function(e) { + .hide_from_trace <- 0:1 + e$srcref <- srcref + e$procsrcref <- NULL + if (!inherits(err, "condition")) { + err <- new_error(err, call. = call) + } + throw_error(err, parent = e) } - throw_error(err, parent = e) - }) + ) } # -- rethrowing conditions from C code --------------------------------- @@ -386,7 +395,13 @@ err <- local({ name <- native_name(.NAME) err <- new_error("Native call to `", name, "` failed", call. = call1) cerror <- if (inherits(e, "simpleError")) "c_error" - class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition") + class(err) <- c( + cerror, + "rlib_error_3_0", + "rlib_error", + "error", + "condition" + ) throw_error(err, parent = e) } ) @@ -421,7 +436,13 @@ err <- local({ name <- native_name(.NAME) err <- new_error("Native call to `", name, "` failed", call. = call1) cerror <- if (inherits(e, "simpleError")) "c_error" - class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition") + class(err) <- c( + cerror, + "rlib_error_3_0", + "rlib_error", + "error", + "condition" + ) throw_error(err, parent = e) } ) @@ -440,7 +461,6 @@ err <- local({ #' @return A condition object, with the trace added. add_trace_back <- function(cond, frame = NULL) { - idx <- seq_len(sys.parent(1L)) frames <- sys.frames()[idx] @@ -505,22 +525,29 @@ err <- local({ } is_operator <- function(cl) { - is.call(cl) && length(cl) >= 1 && is.symbol(cl[[1]]) && + is.call(cl) && + length(cl) >= 1 && + is.symbol(cl[[1]]) && grepl("^[^.a-zA-Z]", as.character(cl[[1]])) } mark_invisible_frames <- function(funs, frames) { visibles <- rep(TRUE, length(frames)) hide <- lapply(frames, "[[", ".hide_from_trace") - w_hide <- unlist(mapply(seq_along(hide), hide, FUN = function(i, w) { - i + w - }, SIMPLIFY = FALSE)) + w_hide <- unlist(mapply( + seq_along(hide), + hide, + FUN = function(i, w) { + i + w + }, + SIMPLIFY = FALSE + )) w_hide <- w_hide[w_hide <= length(frames)] visibles[w_hide] <- FALSE hide_from <- which(funs %in% names(invisible_frames)) for (start in hide_from) { - hide_this <- invisible_frames[[ funs[start] ]] + hide_this <- invisible_frames[[funs[start]]] for (i in seq_along(hide_this)) { if (start + i > length(funs)) break if (funs[start + i] != hide_this[i]) break @@ -537,7 +564,8 @@ err <- local({ "cli::cli_abort" = c( "rlang::abort", "rlang:::signal_abort", - "base::signalCondition"), + "base::signalCondition" + ), "rlang::abort" = c("rlang:::signal_abort", "base::signalCondition") ) @@ -558,12 +586,15 @@ err <- local({ get_call_scope <- function(call, ns) { if (is.na(ns)) return("global") if (!is.call(call)) return("") - if (is.call(call[[1]]) && - (call[[1]][[1]] == quote(`::`) || call[[1]][[1]] == quote(`:::`))) return("") + if ( + is.call(call[[1]]) && + (call[[1]][[1]] == quote(`::`) || call[[1]][[1]] == quote(`:::`)) + ) + return("") if (ns == "base") return("::") - if (! ns %in% loadedNamespaces()) return("") + if (!ns %in% loadedNamespaces()) return("") name <- call_name(call) - if (! ns %in% loadedNamespaces()) return("::") + if (!ns %in% loadedNamespaces()) return("::") nsenv <- asNamespace(ns)$.__NAMESPACE__. if (is.null(nsenv)) return("::") if (is.null(nsenv$exports)) return(":::") @@ -580,7 +611,16 @@ err <- local({ topenv(x, matchThisEnv = err_env) } - new_trace <- function (calls, parents, visibles, namespaces, scopes, srcrefs, procsrcrefs, pids) { + new_trace <- function( + calls, + parents, + visibles, + namespaces, + scopes, + srcrefs, + procsrcrefs, + pids + ) { trace <- data.frame( stringsAsFactors = FALSE, parent = parents, @@ -633,9 +673,15 @@ err <- local({ # -- S3 methods ------------------------------------------------------- - format_error <- function(x, trace = FALSE, class = FALSE, - advice = !trace, full = trace, header = TRUE, - ...) { + format_error <- function( + x, + trace = FALSE, + class = FALSE, + advice = !trace, + full = trace, + header = TRUE, + ... + ) { if (has_cli()) { format_error_cli(x, trace, class, advice, full, header, ...) } else { @@ -643,8 +689,7 @@ err <- local({ } } - print_error <- function(x, trace = TRUE, class = TRUE, - advice = !trace, ...) { + print_error <- function(x, trace = TRUE, class = TRUE, advice = !trace, ...) { writeLines(format_error(x, trace, class, advice, ...)) } @@ -740,12 +785,13 @@ err <- local({ paste0(if (add_exp) exp, msg), if (inherits(cond$parent, "condition")) { msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) { - format(cond$parent, - trace = FALSE, - full = TRUE, - class = FALSE, - header = FALSE, - advice = FALSE + format( + cond$parent, + trace = FALSE, + full = TRUE, + class = FALSE, + header = FALSE, + advice = FALSE ) } else if (inherits(cond$parent, "interrupt")) { "interrupt" @@ -754,9 +800,7 @@ err <- local({ } add_exp <- substr(cli::ansi_strip(msg[1]), 1, 1) != "!" if (add_exp) msg[1] <- paste0(exp, msg[1]) - c(format_header_line_cli(cond$parent, prefix = "Caused by error"), - msg - ) + c(format_header_line_cli(cond$parent, prefix = "Caused by error"), msg) } ) } @@ -770,12 +814,13 @@ err <- local({ paste0(if (add_exp) exp, cnd_message_robust(cond)), if (inherits(cond$parent, "condition")) { msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) { - format(cond$parent, - trace = FALSE, - full = TRUE, - class = FALSE, - header = FALSE, - advice = FALSE + format( + cond$parent, + trace = FALSE, + full = TRUE, + class = FALSE, + header = FALSE, + advice = FALSE ) } else if (inherits(cond$parent, "interrupt")) { "interrupt" @@ -786,7 +831,8 @@ err <- local({ if (add_exp) { msg[1] <- paste0(exp, msg[1]) } - c(format_header_line_plain(cond$parent, prefix = "Caused by error"), + c( + format_header_line_plain(cond$parent, prefix = "Caused by error"), msg ) } @@ -802,9 +848,15 @@ err <- local({ # - error message, just `conditionMessage()` # - advice about .Last.error and/or .Last.error.trace - format_error_cli <- function(x, trace = TRUE, class = TRUE, - advice = !trace, full = trace, - header = TRUE, ...) { + format_error_cli <- function( + x, + trace = TRUE, + class = TRUE, + advice = !trace, + full = trace, + header = TRUE, + ... + ) { p_class <- if (class) format_class_cli(x) p_header <- if (header) format_header_line_cli(x) p_msg <- cnd_message_cli(x, full) @@ -813,11 +865,7 @@ err <- local({ c("---", "Backtrace:", format_trace_cli(x$trace)) } - c(p_class, - p_header, - p_msg, - p_advice, - p_trace) + c(p_class, p_header, p_msg, p_advice, p_trace) } format_header_line_cli <- function(x, prefix = NULL) { @@ -904,7 +952,11 @@ err <- local({ srcref <- if ("srcref" %in% names(x) || "procsrcref" %in% names(x)) { vapply( seq_len(nrow(x)), - function(i) format_srcref_cli(x[["call"]][[i]], x$procsrcref[[i]] %||% x$srcref[[i]]), + function(i) + format_srcref_cli( + x[["call"]][[i]], + x$procsrcref[[i]] %||% x$srcref[[i]] + ), character(1) ) } else { @@ -913,11 +965,15 @@ err <- local({ lines <- paste0( cli::col_silver(format(x$num), ". "), - ifelse (visible, "", "| "), + ifelse(visible, "", "| "), scope, - vapply(seq_along(x$call), function(i) { - format_trace_call_cli(x$call[[i]], x$namespace[[i]]) - }, character(1)), + vapply( + seq_along(x$call), + function(i) { + format_trace_call_cli(x$call[[i]], x$namespace[[i]]) + }, + character(1) + ), srcref ) @@ -930,12 +986,17 @@ err <- local({ } format_trace_call_cli <- function(call, ns = "") { - envir <- tryCatch({ - if (!ns %in% loadedNamespaces()) stop("no") - asNamespace(ns) - }, error = function(e) .GlobalEnv) + envir <- tryCatch( + { + if (!ns %in% loadedNamespaces()) stop("no") + asNamespace(ns) + }, + error = function(e) .GlobalEnv + ) cl <- trimws(format(call)) - if (length(cl) > 1) { cl <- paste0(cl[1], " ", cli::symbol$ellipsis) } + if (length(cl) > 1) { + cl <- paste0(cl[1], " ", cli::symbol$ellipsis) + } # Older cli does not have 'envir'. if ("envir" %in% names(formals(cli::code_highlight))) { fmc <- cli::code_highlight(cl, envir = envir)[1] @@ -947,9 +1008,15 @@ err <- local({ # ---------------------------------------------------------------------- - format_error_plain <- function(x, trace = TRUE, class = TRUE, - advice = !trace, full = trace, header = TRUE, - ...) { + format_error_plain <- function( + x, + trace = TRUE, + class = TRUE, + advice = !trace, + full = trace, + header = TRUE, + ... + ) { p_class <- if (class) format_class_plain(x) p_header <- if (header) format_header_line_plain(x) p_msg <- cnd_message_plain(x, full) @@ -958,11 +1025,7 @@ err <- local({ c("---", "Backtrace:", format_trace_plain(x$trace)) } - c(p_class, - p_header, - p_msg, - p_advice, - p_trace) + c(p_class, p_header, p_msg, p_advice, p_trace) } format_trace_plain <- function(x, ...) { @@ -983,7 +1046,11 @@ err <- local({ srcref <- if ("srcref" %in% names(x) || "procsrfref" %in% names(x)) { vapply( seq_len(nrow(x)), - function(i) format_srcref_plain(x[["call"]][[i]], x$procsrcref[[i]] %||% x$srcref[[i]]), + function(i) + format_srcref_plain( + x[["call"]][[i]], + x$procsrcref[[i]] %||% x$srcref[[i]] + ), character(1) ) } else { @@ -992,7 +1059,7 @@ err <- local({ lines <- paste0( paste0(format(x$num), ". "), - ifelse (visible, "", "| "), + ifelse(visible, "", "| "), scope, vapply(x[["call"]], format_trace_call_plain, character(1)), srcref @@ -1008,7 +1075,10 @@ err <- local({ format_header_line_plain <- function(x, prefix = NULL) { p_error <- format_error_heading_plain(x, prefix) p_call <- format_call_plain(x[["call"]]) - p_srcref <- format_srcref_plain(conditionCall(x), x$procsrcref %||% x$srcref) + p_srcref <- format_srcref_plain( + conditionCall(x), + x$procsrcref %||% x$srcref + ) paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":") } @@ -1051,7 +1121,9 @@ err <- local({ format_trace_call_plain <- function(call) { fmc <- trimws(format(call)[1]) - if (length(fmc) > 1) { fmc <- paste0(fmc[1], " ...") } + if (length(fmc) > 1) { + fmc <- paste0(fmc[1], " ...") + } strtrim(fmc, getOption("width") - 5) } @@ -1109,7 +1181,9 @@ err <- local({ FALSE } else if (tolower(getOption("knitr.in.progress", "false")) == "true") { FALSE - } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") { + } else if ( + tolower(getOption("rstudio.notebook.executing", "false")) == "true" + ) { FALSE } else if (identical(Sys.getenv("TESTTHAT"), "true")) { FALSE @@ -1124,13 +1198,14 @@ err <- local({ rstudio_stdout <- function() { rstudio <- rstudio_detect() - rstudio$type %in% c( - "rstudio_console", - "rstudio_console_starting", - "rstudio_build_pane", - "rstudio_job", - "rstudio_render_pane" - ) + rstudio$type %in% + c( + "rstudio_console", + "rstudio_console_starting", + "rstudio_build_pane", + "rstudio_job", + "rstudio_render_pane" + ) } default_output <- function() { @@ -1148,7 +1223,12 @@ err <- local({ registerS3method("format", "rlib_trace_3_0", format_trace, baseenv()) registerS3method("print", "rlib_error_3_0", print_error, baseenv()) registerS3method("print", "rlib_trace_3_0", print_trace, baseenv()) - registerS3method("conditionMessage", "rlib_error_3_0", cnd_message, baseenv()) + registerS3method( + "conditionMessage", + "rlib_error_3_0", + cnd_message, + baseenv() + ) } } @@ -1205,40 +1285,41 @@ err <- local({ structure( list( - .internal = err_env, - new_cond = new_cond, - new_error = new_error, - throw = throw, - throw_error = throw_error, - chain_error = chain_error, - chain_call = chain_call, + .internal = err_env, + new_cond = new_cond, + new_error = new_error, + throw = throw, + throw_error = throw_error, + chain_error = chain_error, + chain_call = chain_call, chain_clean_call = chain_clean_call, - add_trace_back = add_trace_back, - process_call = process_call, - onload_hook = onload_hook, - is_interactive = is_interactive, + add_trace_back = add_trace_back, + process_call = process_call, + onload_hook = onload_hook, + is_interactive = is_interactive, register_testthat_print = register_testthat_print, format = list( - advice = format_advice, - call = format_call, - class = format_class, - error = format_error, + advice = format_advice, + call = format_call, + class = format_class, + error = format_error, error_heading = format_error_heading, - header_line = format_header_line, - srcref = format_srcref, - trace = format_trace + header_line = format_header_line, + srcref = format_srcref, + trace = format_trace ) ), - class = c("standalone_errors", "standalone")) + class = c("standalone_errors", "standalone") + ) }) # These are optional, and feel free to remove them if you prefer to # call them through the `err` object. -new_cond <- err$new_cond -new_error <- err$new_error -throw <- err$throw -throw_error <- err$throw_error -chain_error <- err$chain_error -chain_call <- err$chain_call +new_cond <- err$new_cond +new_error <- err$new_error +throw <- err$throw +throw_error <- err$throw_error +chain_error <- err$chain_error +chain_call <- err$chain_call chain_clean_call <- err$chain_clean_call diff --git a/R/supervisor.R b/R/supervisor.R index 58e4893d..40efcaa1 100644 --- a/R/supervisor.R +++ b/R/supervisor.R @@ -1,13 +1,17 @@ # Stores information about the supervisor process supervisor_info <- new.env() -reg.finalizer(supervisor_info, function(s) { - # Pass s to `supervisor_kill`, in case the GC event happens _after_ a new - # `processx:::supervisor_info` has been created and the name - # `supervisor_info` is bound to the new object. This could happen if the - # package is unloaded and reloaded. - supervisor_kill2(s) -}, onexit = TRUE) +reg.finalizer( + supervisor_info, + function(s) { + # Pass s to `supervisor_kill`, in case the GC event happens _after_ a new + # `processx:::supervisor_info` has been created and the name + # `supervisor_info` is bound to the new object. This could happen if the + # package is unloaded and reloaded. + supervisor_kill2(s) + }, + onexit = TRUE +) #' Terminate all supervised processes and the supervisor process itself as #' well @@ -30,8 +34,7 @@ supervisor_kill <- function() { # This takes an object s, because a new `supervisor_info` object could have been # created. supervisor_kill2 <- function(s = supervisor_info) { - if (is.null(s$pid)) - return() + if (is.null(s$pid)) return() if (!is.null(s$stdin) && is_pipe_open(s$stdin)) { write_lines_named_pipe(s$stdin, "kill") @@ -53,17 +56,16 @@ supervisor_reset <- function() { supervisor_kill() } - supervisor_info$pid <- NULL - supervisor_info$stdin <- NULL - supervisor_info$stdout <- NULL - supervisor_info$stdin_file <- NULL + supervisor_info$pid <- NULL + supervisor_info$stdin <- NULL + supervisor_info$stdout <- NULL + supervisor_info$stdin_file <- NULL supervisor_info$stdout_file <- NULL } supervisor_ensure_running <- function() { - if (!supervisor_running()) - supervisor_start() + if (!supervisor_running()) supervisor_start() } @@ -92,11 +94,10 @@ supervisor_unwatch_pid <- function(pid) { # Start the supervisor process. Information about the process will be stored in # supervisor_info. If startup fails, this function will throw an error. supervisor_start <- function() { - - supervisor_info$stdin_file <- named_pipe_tempfile("supervisor_stdin") + supervisor_info$stdin_file <- named_pipe_tempfile("supervisor_stdin") supervisor_info$stdout_file <- named_pipe_tempfile("supervisor_stdout") - supervisor_info$stdin <- create_named_pipe(supervisor_info$stdin_file) + supervisor_info$stdin <- create_named_pipe(supervisor_info$stdin_file) supervisor_info$stdout <- create_named_pipe(supervisor_info$stdout_file) # Start the supervisor, passing the R process's PID to it. @@ -116,8 +117,7 @@ supervisor_start <- function() { while (cur_time < end_time) { p$poll_io(round(as.numeric(end_time - cur_time, units = "secs") * 1000)) - if (!p$is_alive()) - break + if (!p$is_alive()) break if (any(p$read_output_lines() == "Ready")) { ready <- TRUE @@ -127,8 +127,7 @@ supervisor_start <- function() { cur_time <- Sys.time() } - if (p$is_alive()) - close(p$get_output_connection()) + if (p$is_alive()) close(p$get_output_connection()) # Two ways of reaching this: if process has died, or if it hasn't emitted # "Ready" after 5 seconds. @@ -143,8 +142,7 @@ supervisor_start <- function() { # normal way, and when loaded with devtools::load_all(). supervisor_path <- function() { supervisor_name <- "supervisor" - if (is_windows()) - supervisor_name <- paste0(supervisor_name, ".exe") + if (is_windows()) supervisor_name <- paste0(supervisor_name, ".exe") # Detect if package was loaded via devtools::load_all() dev_meta <- parent.env(environment())$.__DEVTOOLS__ diff --git a/R/utils.R b/R/utils.R index 327e9764..9b3db5e2 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,4 +1,3 @@ - enc2path <- function(x) { if (is_windows()) { enc2utf8(x) @@ -48,27 +47,27 @@ full_path <- function(path) { if (grepl("^[a-zA-Z]:", path)) { drive <- substring(path, 1, 2) path <- substring(path, 3) - } else if (substring(path, 1, 2) == "//") { # Extract server name, like "//server", and use as drive. pos <- regexec("^(//[^/]*)(.*)", path)[[1]] - drive <- substring(path, pos[2], attr(pos, "match.length", exact = TRUE)[2]) + drive <- substring( + path, + pos[2], + attr(pos, "match.length", exact = TRUE)[2] + ) path <- substring(path, pos[3]) # Must have a name, like "//server" if (drive == "//") throw(new_error("Server name not found in network path.")) - } else { drive <- substring(getwd(), 1, 2) if (substr(path, 1, 1) != "/") path <- substring(file.path(getwd(), path), 3) } - } else { - if (substr(path, 1, 1) != "/") - path <- file.path(getwd(), path) + if (substr(path, 1, 1) != "/") path <- file.path(getwd(), path) } parts <- strsplit(path, "/")[[1]] @@ -78,30 +77,27 @@ full_path <- function(path) { while (i <= length(parts)) { if (parts[i] == "." || parts[i] == "") { parts <- parts[-i] - } else if (parts[i] == "..") { if (i == 2) { parts <- parts[-i] } else { - parts <- parts[-c(i-1, i)] - i <- i-1 + parts <- parts[-c(i - 1, i)] + i <- i - 1 } } else { - i <- i+1 + i <- i + 1 } } new_path <- paste(parts, collapse = "/") - if (new_path == "") - new_path <- "/" + if (new_path == "") new_path <- "/" - if (is_windows()) - new_path <- paste0(drive, new_path) + if (is_windows()) new_path <- paste0(drive, new_path) new_path } -vcapply <- function (X, FUN, ..., USE.NAMES = TRUE) { +vcapply <- function(X, FUN, ..., USE.NAMES = TRUE) { vapply(X, FUN, FUN.VALUE = character(1), ..., USE.NAMES = USE.NAMES) } @@ -152,12 +148,10 @@ str_wrap_words <- function(words, width, indent = 0, exdent = 2) { current_line <- paste0(current_line, words[i]) first_word <- FALSE i <- i + 1 - } else if (current_width + 1 + word_widths[i] <= width) { current_width <- current_width + word_widths[i] + 1 current_line <- paste0(current_line, " ", words[i]) i <- i + 1 - } else { out <- c(out, current_line) current_width <- exdent @@ -195,7 +189,8 @@ get_tool <- function(prog) { get_id <- function() { paste0( basename(tempfile("PS")), - "_", as.integer(asNamespace("base")$.Internal(Sys.time())) + "_", + as.integer(asNamespace("base")$.Internal(Sys.time())) ) } @@ -232,8 +227,10 @@ str_trim <- function(x) { } new_not_implemented_error <- function(message, call) { - add_class(new_error(message, call. = call), - c("not_implemented_error", "not_implemented")) + add_class( + new_error(message, call. = call), + c("not_implemented_error", "not_implemented") + ) } add_class <- function(obj, class) { @@ -249,7 +246,9 @@ is_interactive <- function() { FALSE } else if (tolower(getOption("knitr.in.progress", "false")) == "true") { FALSE - } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") { + } else if ( + tolower(getOption("rstudio.notebook.executing", "false")) == "true" + ) { FALSE } else if (identical(Sys.getenv("TESTTHAT"), "true")) { FALSE diff --git a/README.Rmd b/README.Rmd index 16f6d14f..63bc3650 100644 --- a/README.Rmd +++ b/README.Rmd @@ -20,7 +20,7 @@ knitr::opts_chunk$set( [![R-CMD-check](https://github.com/r-lib/processx/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/processx/actions/workflows/R-CMD-check.yaml) [![](https://www.r-pkg.org/badges/version/processx)](https://www.r-pkg.org/pkg/processx) [![CRAN RStudio mirror downloads](https://cranlogs.r-pkg.org/badges/processx)](https://www.r-pkg.org/pkg/processx) -[![Codecov test coverage](https://codecov.io/gh/r-lib/processx/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/processx?branch=main) +[![Codecov test coverage](https://codecov.io/gh/r-lib/processx/graph/badge.svg)](https://app.codecov.io/gh/r-lib/processx) Tools to run system processes in the background, diff --git a/README.md b/README.md index 797f27b8..9831684b 100644 --- a/README.md +++ b/README.md @@ -11,7 +11,7 @@ [![CRAN RStudio mirror downloads](https://cranlogs.r-pkg.org/badges/processx)](https://www.r-pkg.org/pkg/processx) [![Codecov test -coverage](https://codecov.io/gh/r-lib/processx/branch/main/graph/badge.svg)](https://app.codecov.io/gh/r-lib/processx?branch=main) +coverage](https://codecov.io/gh/r-lib/processx/graph/badge.svg)](https://app.codecov.io/gh/r-lib/processx) Tools to run system processes in the background, read their standard @@ -101,7 +101,7 @@ px <- paste0( px ``` - #> [1] "/Users/gaborcsardi/Library/R/arm64/4.2/library/processx/bin/px" + #> [1] "/Users/gaborcsardi/Library/R/arm64/4.5/library/processx/bin/px" ### Running an external process @@ -234,12 +234,11 @@ out1 out2 ``` - #> [1] "CODE_OF_CONDUCT.md" "DESCRIPTION" "LICENSE" - #> [4] "LICENSE.md" "Makefile" "NAMESPACE" - #> [7] "NEWS.md" "R" "README.Rmd" - #> [10] "README.md" "_pkgdown.yml" "codecov.yml" - #> [13] "inst" "man" "processx.Rproj" - #> [16] "src" "tests" + #> [1] "_pkgdown.yml" "codecov.yml" "DESCRIPTION" "inst" + #> [5] "LICENSE" "LICENSE.md" "Makefile" "man" + #> [9] "NAMESPACE" "NEWS.md" "processx.Rproj" "R" + #> [13] "README.md" "README.Rmd" "src" "tests" + #> [17] "vignettes" #### Spinner @@ -550,14 +549,14 @@ p$is_alive() Sys.time() ``` - #> [1] "2022-06-10 13:57:49 CEST" + #> [1] "2025-04-26 09:34:10 CEST" ``` r p$wait() Sys.time() ``` - #> [1] "2022-06-10 13:57:51 CEST" + #> [1] "2025-04-26 09:34:12 CEST" It is safe to call `wait()` multiple times: @@ -612,7 +611,7 @@ p <- process$new("nonexistant-command-for-sure") ``` #> Error in c("process_initialize(self, private, command, args, stdin, stdout, ", : ! Native call to `processx_exec` failed - #> Caused by error in `chain_call(c_processx_exec, command, c(command, args), pty, pty_options, …` at initialize.R:138:3: + #> Caused by error in `chain_call(c_processx_exec, command, c(command, args), pty, pty_options, …`: #> ! cannot start processx process 'nonexistant-command-for-sure' (system error 2, No such file or directory) @unix/processx.c:613 (processx_exec) ``` r diff --git a/air.toml b/air.toml new file mode 100644 index 00000000..e69de29b diff --git a/src/install.libs.R b/src/install.libs.R index 1c1a755f..59a1cd79 100644 --- a/src/install.libs.R +++ b/src/install.libs.R @@ -1,10 +1,10 @@ - progs <- if (WINDOWS) { - c(file.path("tools", c("px.exe", "interrupt.exe", "sock.exe")), - file.path("supervisor", "supervisor.exe")) + c( + file.path("tools", c("px.exe", "interrupt.exe", "sock.exe")), + file.path("supervisor", "supervisor.exe") + ) } else { - c(file.path("tools", c("px", "sock")), - file.path("supervisor", "supervisor")) + c(file.path("tools", c("px", "sock")), file.path("supervisor", "supervisor")) } dest <- file.path(R_PACKAGE_DIR, paste0("bin", R_ARCH)) diff --git a/tests/testthat.R b/tests/testthat.R index ea473876..ec759cb7 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,3 +1,11 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/testing-design.html#sec-tests-files-overview +# * https://testthat.r-lib.org/articles/special-files.html + library(testthat) library(processx) diff --git a/tests/testthat/_snaps/Darwin/process.md b/tests/testthat/_snaps/Darwin/process.md new file mode 100644 index 00000000..439c8796 --- /dev/null +++ b/tests/testthat/_snaps/Darwin/process.md @@ -0,0 +1,20 @@ +# non existing process + + Code + process$new(tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! cannot start processx process '/' (system error 2, No such file or directory) @unix/processx.c:613 (processx_exec) + +# working directory does not exist + + Code + process$new(px, wd = tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! cannot start processx process '/px' (system error 2, No such file or directory) @unix/processx.c:613 (processx_exec) + diff --git a/tests/testthat/_snaps/Darwin/run.md b/tests/testthat/_snaps/Darwin/run.md new file mode 100644 index 00000000..4f7e7747 --- /dev/null +++ b/tests/testthat/_snaps/Darwin/run.md @@ -0,0 +1,10 @@ +# working directory does not exist + + Code + run(px, wd = tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! cannot start processx process '/px' (system error 2, No such file or directory) @unix/processx.c:613 (processx_exec) + diff --git a/tests/testthat/_snaps/Darwin/unix-sockets.md b/tests/testthat/_snaps/Darwin/unix-sockets.md new file mode 100644 index 00000000..bbb8fdf2 --- /dev/null +++ b/tests/testthat/_snaps/Darwin/unix-sockets.md @@ -0,0 +1,34 @@ +# reading unaccepted server socket is error + + Code + conn_read_chars(sock1) + Condition + Error: + ! Native call to `processx_connection_read_chars` failed + Caused by error: + ! Cannot read from processx connection (system error 57, Socket is not connected) @processx-connection.c:1828 (processx__connection_read) + +# errors + + Code + conn_create_unix_socket(sock) + Condition + Error: + ! Native call to `processx_connection_create_socket` failed + Caused by error: + ! Server socket path too long: / + Code + conn_create_unix_socket("/dev/null") + Condition + Error: + ! Native call to `processx_connection_create_socket` failed + Caused by error: + ! Cannot bind to socket (system error 48, Address already in use) @processx-connection.c:442 (processx_connection_create_socket) + Code + conn_connect_unix_socket("/dev/null") + Condition + Error: + ! Native call to `processx_connection_connect_socket` failed + Caused by error: + ! Cannot connect to socket (system error 38, Socket operation on non-socket) @processx-connection.c:513 (processx_connection_connect_socket) + diff --git a/tests/testthat/_snaps/Linux/process.md b/tests/testthat/_snaps/Linux/process.md new file mode 100644 index 00000000..b8131c65 --- /dev/null +++ b/tests/testthat/_snaps/Linux/process.md @@ -0,0 +1,20 @@ +# non existing process + + Code + process$new(tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! cannot start processx process '/' (system error 2, No such file or directory) @unix/processx.c:611 (processx_exec) + +# working directory does not exist + + Code + process$new(px, wd = tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! cannot start processx process '/px' (system error 2, No such file or directory) @unix/processx.c:611 (processx_exec) + diff --git a/tests/testthat/_snaps/Linux/run.md b/tests/testthat/_snaps/Linux/run.md new file mode 100644 index 00000000..3364673f --- /dev/null +++ b/tests/testthat/_snaps/Linux/run.md @@ -0,0 +1,10 @@ +# working directory does not exist + + Code + run(px, wd = tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! cannot start processx process '/px' (system error 2, No such file or directory) @unix/processx.c:611 (processx_exec) + diff --git a/tests/testthat/_snaps/Linux/unix-sockets.md b/tests/testthat/_snaps/Linux/unix-sockets.md new file mode 100644 index 00000000..f738d39e --- /dev/null +++ b/tests/testthat/_snaps/Linux/unix-sockets.md @@ -0,0 +1,34 @@ +# reading unaccepted server socket is error + + Code + conn_read_chars(sock1) + Condition + Error: + ! Native call to `processx_connection_read_chars` failed + Caused by error: + ! Cannot read from processx connection (system error 22, Invalid argument) @processx-connection.c:1828 (processx__connection_read) + +# errors + + Code + conn_create_unix_socket(sock) + Condition + Error: + ! Native call to `processx_connection_create_socket` failed + Caused by error: + ! Server socket path too long: / + Code + conn_create_unix_socket("/dev/null") + Condition + Error: + ! Native call to `processx_connection_create_socket` failed + Caused by error: + ! Cannot bind to socket (system error 98, Address already in use) @processx-connection.c:442 (processx_connection_create_socket) + Code + conn_connect_unix_socket("/dev/null") + Condition + Error: + ! Native call to `processx_connection_connect_socket` failed + Caused by error: + ! Cannot connect to socket (system error 111, Connection refused) @processx-connection.c:513 (processx_connection_connect_socket) + diff --git a/tests/testthat/_snaps/Windows/process.md b/tests/testthat/_snaps/Windows/process.md new file mode 100644 index 00000000..3067b32c --- /dev/null +++ b/tests/testthat/_snaps/Windows/process.md @@ -0,0 +1,21 @@ +# non existing process + + Code + process$new(tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! Command '/' not found @win/processx.c:982 (processx_exec) + +# working directory does not exist + + Code + process$new(px, wd = tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! create process '/px' (system error 267, The directory name is invalid. + ) @win/processx.c:1040 (processx_exec) + diff --git a/tests/testthat/_snaps/Windows/run.md b/tests/testthat/_snaps/Windows/run.md new file mode 100644 index 00000000..baf78e96 --- /dev/null +++ b/tests/testthat/_snaps/Windows/run.md @@ -0,0 +1,11 @@ +# working directory does not exist + + Code + run(px, wd = tempfile()) + Condition + Error: + ! Native call to `processx_exec` failed + Caused by error: + ! create process '/px' (system error 267, The directory name is invalid. + ) @win/processx.c:1040 (processx_exec) + diff --git a/tests/testthat/_snaps/Windows/unix-sockets.md b/tests/testthat/_snaps/Windows/unix-sockets.md new file mode 100644 index 00000000..24243ebc --- /dev/null +++ b/tests/testthat/_snaps/Windows/unix-sockets.md @@ -0,0 +1,10 @@ +# reading unaccepted server socket is error + + Code + conn_read_chars(sock1) + Condition + Error: + ! Native call to `processx_connection_read_chars` failed + Caused by error: + ! Cannot read from an un-accepted socket connection @processx-connection.c:1731 (processx__connection_read) + diff --git a/tests/testthat/_snaps/assertions.md b/tests/testthat/_snaps/assertions.md new file mode 100644 index 00000000..7730a649 --- /dev/null +++ b/tests/testthat/_snaps/assertions.md @@ -0,0 +1,352 @@ +# is_string + + Code + assert_that(is_string(n)) + Condition + Error: + ! n is not a string (length 1 character) + +--- + + Code + assert_that(is_string(n)) + Condition + Error: + ! n is not a string (length 1 character) + +--- + + Code + assert_that(is_string(n)) + Condition + Error: + ! n is not a string (length 1 character) + +--- + + Code + assert_that(is_string(n)) + Condition + Error: + ! n is not a string (length 1 character) + +--- + + Code + assert_that(is_string(n)) + Condition + Error: + ! n is not a string (length 1 character) + +--- + + Code + assert_that(is_string(n)) + Condition + Error: + ! n is not a string (length 1 character) + +--- + + Code + assert_that(is_string(n)) + Condition + Error: + ! n is not a string (length 1 character) + +# is_string_or_null + + Code + assert_that(is_string_or_null(n)) + Condition + Error: + ! n must be a string (length 1 character) or NULL + +--- + + Code + assert_that(is_string_or_null(n)) + Condition + Error: + ! n must be a string (length 1 character) or NULL + +--- + + Code + assert_that(is_string_or_null(n)) + Condition + Error: + ! n must be a string (length 1 character) or NULL + +--- + + Code + assert_that(is_string_or_null(n)) + Condition + Error: + ! n must be a string (length 1 character) or NULL + +--- + + Code + assert_that(is_string_or_null(n)) + Condition + Error: + ! n must be a string (length 1 character) or NULL + +--- + + Code + assert_that(is_string_or_null(n)) + Condition + Error: + ! n must be a string (length 1 character) or NULL + +# is_flag + + Code + assert_that(is_flag(n)) + Condition + Error: + ! n is not a flag (length 1 logical) + +--- + + Code + assert_that(is_flag(n)) + Condition + Error: + ! n is not a flag (length 1 logical) + +--- + + Code + assert_that(is_flag(n)) + Condition + Error: + ! n is not a flag (length 1 logical) + +--- + + Code + assert_that(is_flag(n)) + Condition + Error: + ! n is not a flag (length 1 logical) + +--- + + Code + assert_that(is_flag(n)) + Condition + Error: + ! n is not a flag (length 1 logical) + +--- + + Code + assert_that(is_flag(n)) + Condition + Error: + ! n is not a flag (length 1 logical) + +--- + + Code + assert_that(is_flag(n)) + Condition + Error: + ! n is not a flag (length 1 logical) + +# is_integerish_scalar + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +--- + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +--- + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +--- + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +--- + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +--- + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +--- + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +--- + + Code + assert_that(is_integerish_scalar(n)) + Condition + Error: + ! n is not a length 1 integer + +# is_pid + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +--- + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +--- + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +--- + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +--- + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +--- + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +--- + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +--- + + Code + assert_that(is_pid(n)) + Condition + Error: + ! n is not a process id (length 1 integer) + +# is_flag_or_string + + Code + assert_that(is_flag_or_string(n)) + Condition + Error: + ! n is not a flag or a string + +--- + + Code + assert_that(is_flag_or_string(n)) + Condition + Error: + ! n is not a flag or a string + +--- + + Code + assert_that(is_flag_or_string(n)) + Condition + Error: + ! n is not a flag or a string + +--- + + Code + assert_that(is_flag_or_string(n)) + Condition + Error: + ! n is not a flag or a string + +--- + + Code + assert_that(is_flag_or_string(n)) + Condition + Error: + ! n is not a flag or a string + +--- + + Code + assert_that(is_flag_or_string(n)) + Condition + Error: + ! n is not a flag or a string + +--- + + Code + assert_that(is_flag_or_string(n)) + Condition + Error: + ! n is not a flag or a string + +# is_existing_file + + Code + assert_that(is_existing_file(tempfile())) + Condition + Error: + ! File tempfile() does not exist + diff --git a/tests/testthat/_snaps/fifo.md b/tests/testthat/_snaps/fifo.md new file mode 100644 index 00000000..35703aba --- /dev/null +++ b/tests/testthat/_snaps/fifo.md @@ -0,0 +1,16 @@ +# errors + + Code + conn_create_fifo(read = TRUE, write = TRUE) + Condition + Error: + ! Bi-directional FIFOs are not supported currently + +--- + + Code + conn_connect_fifo(read = TRUE, write = TRUE) + Condition + Error: + ! Bi-directional FIFOs are not supported currently + diff --git a/tests/testthat/_snaps/io.md b/tests/testthat/_snaps/io.md new file mode 100644 index 00000000..3449d0b5 --- /dev/null +++ b/tests/testthat/_snaps/io.md @@ -0,0 +1,73 @@ +# Output and error are discarded by default + + Code + p$read_output_lines(n = 1) + Condition + Error: + ! stdout is not a pipe. + Code + p$read_all_output_lines() + Condition + Error: + ! stdout is not a pipe. + Code + p$read_all_output() + Condition + Error: + ! stdout is not a pipe. + Code + p$read_error_lines(n = 1) + Condition + Error: + ! stderr is not a pipe. + Code + p$read_all_error_lines() + Condition + Error: + ! stderr is not a pipe. + Code + p$read_all_error() + Condition + Error: + ! stderr is not a pipe. + +# same pipe + + Code + p$read_all_error_lines() + Condition + Error: + ! stderr is not a pipe. + +# same file + + Code + p$read_all_output_lines() + Condition + Error: + ! stdout is not a pipe. + +--- + + Code + p$read_all_error_lines() + Condition + Error: + ! stderr is not a pipe. + +# same NULL, for completeness + + Code + p$read_all_output_lines() + Condition + Error: + ! stdout is not a pipe. + +--- + + Code + p$read_all_error_lines() + Condition + Error: + ! stderr is not a pipe. + diff --git a/tests/testthat/_snaps/process.md b/tests/testthat/_snaps/process.md new file mode 100644 index 00000000..b91b39ef --- /dev/null +++ b/tests/testthat/_snaps/process.md @@ -0,0 +1,8 @@ +# post processing + + Code + p$get_result() + Condition + Error: + ! Process is still alive + diff --git a/tests/testthat/_snaps/pty.md b/tests/testthat/_snaps/pty.md new file mode 100644 index 00000000..fdb74fc8 --- /dev/null +++ b/tests/testthat/_snaps/pty.md @@ -0,0 +1,8 @@ +# read_output_lines() fails for pty + + Code + p$read_output_lines() + Condition + Error: + ! Cannot read lines from a pty (see manual) + diff --git a/tests/testthat/_snaps/standalone-errors.md b/tests/testthat/_snaps/standalone-errors.md index 73d57539..eed40841 100644 --- a/tests/testthat/_snaps/standalone-errors.md +++ b/tests/testthat/_snaps/standalone-errors.md @@ -1,30 +1,26 @@ # can pass frame as error call in `new_error()` Code - (expect_error(f())) - Output - - Error in `f()`: + f() + Condition + Error: ! my message Code - (expect_error(g())) - Output - - Error in `g()`: + g() + Condition + Error: ! my message # can pass frame as error call in `throw()` Code - (expect_error(f())) - Output - - Error in `f()`: + f() + Condition + Error: ! my message Code - (expect_error(g())) - Output - - Error in `g()`: + g() + Condition + Error: ! my message diff --git a/tests/testthat/_snaps/unix-sockets.md b/tests/testthat/_snaps/unix-sockets.md new file mode 100644 index 00000000..fac92de9 --- /dev/null +++ b/tests/testthat/_snaps/unix-sockets.md @@ -0,0 +1,40 @@ +# CRUD + + Code + conn_accept_unix_socket(sock1) + Condition + Error: + ! Native call to `processx_connection_accept_socket` failed + Caused by error: + ! Socket is not listening @processx-connection.c:540 (processx_connection_accept_socket) + +# writing unaccepted server socket is error + + Code + conn_write(sock1, "Hello\n") + Condition + Error: + ! Native call to `processx_connection_write_bytes` failed + Caused by error: + ! Cannot write to an un-accepted socket connection @processx-connection.c:966 (processx_c_connection_write_bytes) + +# errors + + Code + conn_accept_unix_socket(ff) + Condition + Error: + ! Native call to `processx_connection_accept_socket` failed + Caused by error: + ! Not a socket connection @processx-connection.c:536 (processx_connection_accept_socket) + +--- + + Code + conn_unix_socket_state(ff) + Condition + Error: + ! Native call to `processx_connection_socket_state` failed + Caused by error: + ! Not a socket connection @processx-connection.c:585 (processx_connection_socket_state) + diff --git a/tests/testthat/_snaps/utils.md b/tests/testthat/_snaps/utils.md new file mode 100644 index 00000000..660b9426 --- /dev/null +++ b/tests/testthat/_snaps/utils.md @@ -0,0 +1,18 @@ +# full_path gives correct values, windows + + Code + full_path("//") + Condition + Error: + ! Server name not found in network path. + Code + full_path("///") + Condition + Error: + ! Server name not found in network path. + Code + full_path("///a") + Condition + Error: + ! Server name not found in network path. + diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 93caae0f..3aaff633 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -1,4 +1,3 @@ - skip_other_platforms <- function(platform) { if (os_type() != platform) skip(paste("only run it on", platform)) } @@ -8,7 +7,7 @@ skip_if_no_tool <- function(tool) { } skip_extra_tests <- function() { - if (Sys.getenv("PROCESSX_EXTRA_TESTS") == "") skip("no extra tests") + if (Sys.getenv("PROCESSX_EXTRA_TESTS") == "") skip("no extra tests") } skip_if_no_ps <- function() { @@ -66,22 +65,32 @@ httpbin <- webfakes::new_app_process( ) interrupt_me <- function(expr, after = 1) { - tryCatch({ - p <- callr::r_bg(function(pid, after) { - Sys.sleep(after) - ps::ps_interrupt(ps::ps_handle(pid)) - }, list(pid = Sys.getpid(), after = after)) - expr - p$kill() - }, interrupt = function(e) e) + tryCatch( + { + p <- callr::r_bg( + function(pid, after) { + Sys.sleep(after) + ps::ps_interrupt(ps::ps_handle(pid)) + }, + list(pid = Sys.getpid(), after = after) + ) + expr + p$kill() + }, + interrupt = function(e) e + ) } expect_error <- function(..., class = "error") { testthat::expect_error(..., class = class) } -local_temp_dir <- function(pattern = "file", tmpdir = tempdir(), - fileext = "", envir = parent.frame()) { +local_temp_dir <- function( + pattern = "file", + tmpdir = tempdir(), + fileext = "", + envir = parent.frame() +) { path <- tempfile(pattern = pattern, tmpdir = tmpdir, fileext = fileext) dir.create(path) withr::local_dir(path, .local_envir = envir) @@ -111,10 +120,13 @@ run_script <- function(expr, ..., quoted = NULL, encoding = "") { writeLines(deparse(quoted), con = sf) writeLines( - deparse(substitute({ - options(keep.source = TRUE) - source(sf) - }, list(sf = basename(sf)))), + deparse(substitute( + { + options(keep.source = TRUE) + source(sf) + }, + list(sf = basename(sf)) + )), con = sf2 ) @@ -128,7 +140,7 @@ run_script <- function(expr, ..., quoted = NULL, encoding = "") { ) enc <- function(x) iconv(list(x), encoding, "UTF-8") - + list( script = readLines(sf), stdout = enc(readBin(so, "raw", file.size(so))), @@ -149,4 +161,27 @@ scrub_srcref <- function(x) { x } +transform_tempdir <- function(x) { + x <- sub(tempdir(), "", x, fixed = TRUE) + x <- sub(normalizePath(tempdir()), "", x, fixed = TRUE) + x <- sub( + normalizePath(tempdir(), winslash = "/"), + "", + x, + fixed = TRUE + ) + x <- sub("\\R\\", "/R/", x, fixed = TRUE) + x <- sub("[\\\\/]file[a-zA-Z0-9]+", "/", x) + x <- sub("[A-Z]:.*Rtmp[a-zA-Z0-9]+[\\\\/]", "/", x) + x +} + +transform_px <- function(x) { + sub("'.*/px([.]exe)?'", "'/px'", x) +} + +sysname <- function() { + Sys.info()[["sysname"]] +} + err$register_testthat_print() diff --git a/tests/testthat/test-assertions.R b/tests/testthat/test-assertions.R index fc4a5349..87987423 100644 --- a/tests/testthat/test-assertions.R +++ b/tests/testthat/test-assertions.R @@ -1,7 +1,13 @@ - strings <- list("foo", "", "111", "1", "-", "NA") -not_strings <- list(1, character(), NA_character_, NA, - c("foo", NA), c("1", "2"), NULL) +not_strings <- list( + 1, + character(), + NA_character_, + NA, + c("foo", NA), + c("1", "2"), + NULL +) test_that("is_string", { for (p in strings) { @@ -11,7 +17,7 @@ test_that("is_string", { for (n in not_strings) { expect_false(is_string(n)) - expect_error(assert_that(is_string(n)), "is not a string") + expect_snapshot(error = TRUE, assert_that(is_string(n))) } }) @@ -26,17 +32,21 @@ test_that("is_string_or_null", { for (n in not_strings) { if (!is.null(n)) { expect_false(is_string_or_null(n)) - expect_error( - assert_that(is_string_or_null(n)), - "must be a string .* NULL" - ) + expect_snapshot(error = TRUE, assert_that(is_string_or_null(n))) } } }) flags <- list(TRUE, FALSE) -not_flags <- list(1, character(), NA_character_, NA, - c("foo", NA), c("1", "2"), NULL) +not_flags <- list( + 1, + character(), + NA_character_, + NA, + c("foo", NA), + c("1", "2"), + NULL +) test_that("is_flag", { for (p in flags) { @@ -46,13 +56,21 @@ test_that("is_flag", { for (n in not_flags) { expect_false(is_flag(n)) - expect_error(assert_that(is_flag(n)), "is not a flag") + expect_snapshot(error = TRUE, assert_that(is_flag(n))) } }) ints <- list(1, 0, -1, 1L, 0L, -1L, 1.0, 42.0) -not_ints <- list(1.2, 0.1, "foo", numeric(), integer(), NULL, - NA_integer_, NA_real_) +not_ints <- list( + 1.2, + 0.1, + "foo", + numeric(), + integer(), + NULL, + NA_integer_, + NA_real_ +) test_that("is_integerish_scalar", { for (p in ints) { @@ -62,10 +80,7 @@ test_that("is_integerish_scalar", { for (n in not_ints) { expect_false(is_integerish_scalar(n)) - expect_error( - assert_that(is_integerish_scalar(n)), - "is not a length 1 integer" - ) + expect_snapshot(error = TRUE, assert_that(is_integerish_scalar(n))) } }) @@ -77,7 +92,7 @@ test_that("is_pid", { for (n in not_ints) { expect_false(is_pid(n)) - expect_error(assert_that(is_pid(n)), "is not a process id") + expect_snapshot(error = TRUE, assert_that(is_pid(n))) } }) @@ -89,20 +104,13 @@ test_that("is_flag_or_string", { for (n in intersect(not_flags, not_strings)) { expect_false(is_flag_or_string(n)) - expect_error( - assert_that(is_flag_or_string(n)), - "is not a flag or a string" - ) + expect_snapshot(error = TRUE, assert_that(is_flag_or_string(n))) } - }) test_that("is_existing_file", { expect_false(is_existing_file(tempfile())) - expect_error( - assert_that(is_existing_file(tempfile())), - "File .* does not exist" - ) + expect_snapshot(error = TRUE, assert_that(is_existing_file(tempfile()))) cat("foo\n", file = tmp <- tempfile()) on.exit(unlink(tmp), add = TRUE) diff --git a/tests/testthat/test-chr-io.R b/tests/testthat/test-chr-io.R index 324d6ec2..94869369 100644 --- a/tests/testthat/test-chr-io.R +++ b/tests/testthat/test-chr-io.R @@ -1,6 +1,4 @@ - test_that("Can read last line without trailing newline", { - px <- get_tool("px") p <- process$new(px, c("out", "foobar"), stdout = "|") @@ -10,7 +8,6 @@ test_that("Can read last line without trailing newline", { }) test_that("Can read single characters", { - px <- get_tool("px") p <- process$new(px, c("out", "123"), stdout = "|") @@ -26,7 +23,6 @@ test_that("Can read single characters", { }) test_that("Can read multiple characters", { - px <- get_tool("px") p <- process$new(px, c("out", "123456789"), stdout = "|") diff --git a/tests/testthat/test-cleanup.R b/tests/testthat/test-cleanup.R index c42c38b5..59682ffb 100644 --- a/tests/testthat/test-cleanup.R +++ b/tests/testthat/test-cleanup.R @@ -1,6 +1,4 @@ - test_that("process is cleaned up", { - px <- get_tool("px") p <- process$new(px, c("sleep", "1"), cleanup = TRUE) pid <- p$get_pid() @@ -12,7 +10,6 @@ test_that("process is cleaned up", { }) test_that("process can stay alive", { - px <- get_tool("px") on.exit(tools::pskill(pid, 9), add = TRUE) diff --git a/tests/testthat/test-client-lib.R b/tests/testthat/test-client-lib.R index 943cdc90..b1944523 100644 --- a/tests/testthat/test-client-lib.R +++ b/tests/testthat/test-client-lib.R @@ -1,4 +1,3 @@ - test_that("client lib is standalone", { lib <- load_client_lib(client) on.exit(try(lib$.finalize()), add = TRUE) @@ -9,9 +8,14 @@ test_that("client lib is standalone", { for (f in funobjs) expect_identical(environmentName(topenv(f)), "base") expect_message( - mapply(codetools::checkUsage, funobjs, funs, - MoreArgs = list(report = message)), - NA) + mapply( + codetools::checkUsage, + funobjs, + funs, + MoreArgs = list(report = message) + ), + NA + ) }) test_that("base64", { @@ -27,8 +31,9 @@ test_that("base64", { for (i in 5:32) { mtcars2 <- unserialize(lib$base64_decode(lib$base64_encode( - serialize(mtcars[1:i, ], NULL)))) - expect_identical(mtcars[1:i,], mtcars2) + serialize(mtcars[1:i, ], NULL) + ))) + expect_identical(mtcars[1:i, ], mtcars2) } }) @@ -68,7 +73,8 @@ test_that("processx_connection_set_stdout", { on.exit(unlink(tmp), add = TRUE) opt <- callr::r_process_options( func = stdout_to_file, - args = list(filename = tmp)) + args = list(filename = tmp) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) @@ -94,7 +100,8 @@ test_that("processx_connection_set_stdout", { on.exit(unlink(tmp), add = TRUE) opt <- callr::r_process_options( func = stderr_to_file, - args = list(filename = tmp)) + args = list(filename = tmp) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) @@ -126,7 +133,8 @@ test_that("setting stdout multiple times", { on.exit(unlink(c(tmp1, tmp2)), add = TRUE) opt <- callr::r_process_options( func = stdout_to_file, - args = list(file1 = tmp1, file2 = tmp2)) + args = list(file1 = tmp1, file2 = tmp2) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) diff --git a/tests/testthat/test-connections.R b/tests/testthat/test-connections.R index d7387797..efe31265 100644 --- a/tests/testthat/test-connections.R +++ b/tests/testthat/test-connections.R @@ -1,10 +1,8 @@ - if (!is.null(packageDescription("stats")[["ExperimentalWindowsRuntime"]])) { if (!identical(Sys.getenv("NOT_CRAN"), "true")) return() } test_that("lot of text", { - px <- get_tool("px") txt <- strrep("x", 100000) cat(txt, file = tmp <- tempfile()) @@ -17,7 +15,6 @@ test_that("lot of text", { }) test_that("UTF-8", { - px <- get_tool("px") txt <- charToRaw(strrep("\xc2\xa0\xe2\x86\x92\xf0\x90\x84\x82", 20000)) writeBin(txt, con = tmp <- tempfile()) @@ -30,7 +27,6 @@ test_that("UTF-8", { }) test_that("UTF-8 multibyte character cut in half", { - px <- get_tool("px") rtxt <- charToRaw("a\xc2\xa0a") @@ -38,22 +34,30 @@ test_that("UTF-8 multibyte character cut in half", { writeBin(rtxt[1:2], tmp1 <- tempfile()) writeBin(rtxt[3:4], tmp2 <- tempfile()) - p1 <- process$new(px, c("cat", tmp1, "cat", tmp2), stdout = "|", - encoding = "UTF-8") + p1 <- process$new( + px, + c("cat", tmp1, "cat", tmp2), + stdout = "|", + encoding = "UTF-8" + ) on.exit(p1$kill(), add = TRUE) out <- p1$read_all_output_lines() expect_equal(rtxt, charToRaw(out)) cmd <- paste("(cat", shQuote(tmp1), ";sleep 1;cat", shQuote(tmp2), ")") - p2 <- process$new(px, c("cat", tmp1, "sleep", "1", "cat", tmp2), - stdout = "|", stderr = "|", encoding = "UTF-8") + p2 <- process$new( + px, + c("cat", tmp1, "sleep", "1", "cat", tmp2), + stdout = "|", + stderr = "|", + encoding = "UTF-8" + ) on.exit(p2$kill(), add = TRUE) out <- p2$read_all_output_lines() expect_equal(rtxt, charToRaw(out)) }) test_that("UTF-8 multibyte character cut in half at the end of the file", { - px <- get_tool("px") rtxt <- charToRaw("a\xc2\xa0a") writeBin(c(rtxt, rtxt[1:2]), tmp1 <- tempfile()) @@ -68,7 +72,6 @@ test_that("UTF-8 multibyte character cut in half at the end of the file", { }) test_that("Invalid UTF-8 characters in the middle of the string", { - px <- get_tool("px") half <- charToRaw("\xc2\xa0")[1] rtxt <- sample(rep(c(half, charToRaw("a")), 100)) @@ -82,10 +85,9 @@ test_that("Invalid UTF-8 characters in the middle of the string", { }) test_that("Convert from another encoding to UTF-8", { - px <- get_tool("px") - latin1 <- "\xe1\xe9\xed"; + latin1 <- "\xe1\xe9\xed" writeBin(charToRaw(latin1), tmp1 <- tempfile()) p <- process$new(px, c("cat", tmp1), stdout = "|", encoding = "latin1") @@ -96,7 +98,6 @@ test_that("Convert from another encoding to UTF-8", { }) test_that("Passing connection to stdout", { - # file first tmp <- tempfile() con <- conn_create_file(tmp, write = TRUE) diff --git a/tests/testthat/test-env.R b/tests/testthat/test-env.R index 4b4f049b..fe85e9d2 100644 --- a/tests/testthat/test-env.R +++ b/tests/testthat/test-env.R @@ -1,11 +1,9 @@ - test_that("inherit by default", { - v <- basename(tempfile()) if (os_type() == "unix") { cmd <- c("bash", "-c", paste0("echo $", v)) } else { - cmd <- c("cmd", "/c", paste0("echo %", v, "%")) + cmd <- c("cmd", "/c", paste0("echo %", v, "%")) } skip_if_no_tool(cmd[1]) @@ -16,12 +14,11 @@ test_that("inherit by default", { }) test_that("specify custom env", { - v <- c(basename(tempfile()), basename(tempfile())) if (os_type() == "unix") { cmd <- c("bash", "-c", paste0("echo ", paste0("$", v, collapse = " "))) } else { - cmd <- c("cmd", "/c", paste0("echo ", paste0("%", v, "%", collapse = " "))) + cmd <- c("cmd", "/c", paste0("echo ", paste0("%", v, "%", collapse = " "))) } skip_if_no_tool(cmd[1]) diff --git a/tests/testthat/test-err-output.R b/tests/testthat/test-err-output.R index ad18e369..789ce848 100644 --- a/tests/testthat/test-err-output.R +++ b/tests/testthat/test-err-output.R @@ -1,6 +1,4 @@ - test_that("simple error", { - out <- run_script({ f <- function() processx:::throw("This failed") f() @@ -16,7 +14,6 @@ test_that("simple error", { }) test_that("simple error with cli", { - out <- run_script({ library(cli) f <- function() processx:::throw("This failed") @@ -34,7 +31,6 @@ test_that("simple error with cli", { }) test_that("simple error with cli and colors", { - cli <- if (packageVersion("cli") >= "3.6.3") "newcli" else "oldcli" out <- run_script({ library(cli) @@ -79,30 +75,44 @@ test_that("chain_error", { expect_snapshot(cat(out$stderr), transform = scrub_srcref) expr2 <- substitute( - {o; c }, + { + o + c + }, list(o = quote(options(rlib_interactive = TRUE)), c = expr) ) out <- run_script(quoted = expr2) expect_snapshot(cat(out$stdout)) expr2 <- substitute( - {o; c }, + { + o + c + }, list(o = quote(library(cli)), c = expr) ) out <- run_script(quoted = expr2) expect_snapshot(cat(out$stderr), transform = scrub_srcref) expr2 <- substitute( - {o; c }, - list(o = quote({library(cli); options(cli.num_colors = 256)}), c = expr) + { + o + c + }, + list( + o = quote({ + library(cli) + options(cli.num_colors = 256) + }), + c = expr + ) ) out <- run_script(quoted = expr2) - cli <- if (packageVersion("cli") >= "3.6.3") "newcli" else "oldcli" + cli <- if (packageVersion("cli") >= "3.6.3") "newcli" else "oldcli" expect_snapshot(cat(out$stderr), transform = scrub_srcref, variant = cli) }) test_that("chain_error with stop()", { - expr <- quote({ do3 <- function() { stop("because of this") @@ -126,7 +136,10 @@ test_that("chain_error with stop()", { expect_snapshot(cat(out$stderr), transform = scrub_srcref) expr2 <- substitute( - {o; c }, + { + o + c + }, list(o = quote(options(rlib_interactive = TRUE)), c = expr) ) out <- run_script(quoted = expr2) @@ -134,7 +147,6 @@ test_that("chain_error with stop()", { }) test_that("chain_error with rlang::abort()", { - expr <- quote({ options(cli.unicode = FALSE) do3 <- function() { @@ -159,7 +171,10 @@ test_that("chain_error with rlang::abort()", { expect_snapshot(cat(out$stderr), transform = scrub_srcref) expr2 <- substitute( - {o; c }, + { + o + c + }, list(o = quote(options(rlib_interactive = TRUE)), c = expr) ) out <- run_script(quoted = expr2) @@ -183,7 +198,10 @@ test_that("full parent error is printed in non-interactive mode", { ) expr2 <- substitute( - {o; c }, + { + o + c + }, list(o = quote(options(rlib_interactive = TRUE)), c = expr) ) out <- run_script(quoted = expr2) @@ -193,7 +211,10 @@ test_that("full parent error is printed in non-interactive mode", { ) expr2 <- substitute( - {o; c }, + { + o + c + }, list(o = quote(library(cli)), c = expr) ) out <- run_script(quoted = expr2) @@ -203,11 +224,20 @@ test_that("full parent error is printed in non-interactive mode", { ) expr2 <- substitute( - {o; c }, - list(o = quote({library(cli); options(cli.num_colors = 256)}), c = expr) + { + o + c + }, + list( + o = quote({ + library(cli) + options(cli.num_colors = 256) + }), + c = expr + ) ) out <- run_script(quoted = expr2) - cli <- if (packageVersion("cli") >= "3.6.3") "newcli" else "oldcli" + cli <- if (packageVersion("cli") >= "3.6.3") "newcli" else "oldcli" expect_snapshot( cat(out$stderr), transform = function(x) scrub_px(scrub_srcref(x)), diff --git a/tests/testthat/test-errors.R b/tests/testthat/test-errors.R index d6ecf656..edbebe8e 100644 --- a/tests/testthat/test-errors.R +++ b/tests/testthat/test-errors.R @@ -1,10 +1,12 @@ - test_that("run() prints stderr if echo = FALSE", { px <- get_tool("px") err <- tryCatch( - run(px, c("outln", "nopppp", "errln", "bad", "errln", "foobar", - "return", "2")), - error = function(e) e) + run( + px, + c("outln", "nopppp", "errln", "bad", "errln", "foobar", "return", "2") + ), + error = function(e) e + ) expect_true(any(grepl("foobar", format(err)))) expect_false(any(grepl("nopppp", conditionMessage(err)))) }) @@ -13,18 +15,23 @@ test_that("run() omits stderr if echo = TRUE", { px <- get_tool("px") err <- tryCatch( capture.output( - run(px, c("errln", "bad", "errln", "foobar", "return", "2"), - echo = TRUE)), - error = function(e) e) + run(px, c("errln", "bad", "errln", "foobar", "return", "2"), echo = TRUE) + ), + error = function(e) e + ) expect_false(any(grepl("foobar", conditionMessage(err)))) }) test_that("run() handles stderr_to_stdout = TRUE properly", { px <- get_tool("px") err <- tryCatch( - run(px, c("outln", "nopppp", "errln", "bad", "errln", "foobar", - "return", "2"), stderr_to_stdout = TRUE), - error = function(e) e) + run( + px, + c("outln", "nopppp", "errln", "bad", "errln", "foobar", "return", "2"), + stderr_to_stdout = TRUE + ), + error = function(e) e + ) expect_true(any(grepl("foobar", format(err)))) expect_true(any(grepl("nopppp", format(err)))) }) @@ -36,7 +43,8 @@ test_that("run() only prints the last 10 lines of stderr", { list(rlib_interactive = TRUE), ferr <- format(tryCatch( run(px, c(args, "return", "2")), - error = function(e) e)) + error = function(e) e + )) ) expect_false(any(grepl("foobar1--", ferr))) expect_true(any(grepl("foobar2--", ferr))) @@ -60,7 +68,6 @@ test_that("prints full stderr in non-interactive mode", { }) test_that("output from error", { - out <- run_script({ processx::run( processx:::get_tool("px"), diff --git a/tests/testthat/test-extra-connections.R b/tests/testthat/test-extra-connections.R index 500cfc26..7f5122b6 100644 --- a/tests/testthat/test-extra-connections.R +++ b/tests/testthat/test-extra-connections.R @@ -1,6 +1,4 @@ - test_that("writing to extra connection", { - skip_on_cran() msg <- "foobar" @@ -9,8 +7,12 @@ test_that("writing to extra connection", { pipe <- conn_create_pipepair(nonblocking = c(FALSE, FALSE)) expect_silent( - p <- process$new(cmd[1], cmd[-1], - stdout = "|", stderr = "|", connections = list(pipe[[1]]) + p <- process$new( + cmd[1], + cmd[-1], + stdout = "|", + stderr = "|", + connections = list(pipe[[1]]) ) ) close(pipe[[1]]) @@ -24,16 +26,27 @@ test_that("writing to extra connection", { }) test_that("reading from extra connection", { - skip_on_cran() cmd <- c( - get_tool("px"), "sleep", "0.5", "write", "3", "foobar\r\n", "out", "ok") + get_tool("px"), + "sleep", + "0.5", + "write", + "3", + "foobar\r\n", + "out", + "ok" + ) pipe <- conn_create_pipepair() expect_silent( - p <- process$new(cmd[1], cmd[-1], stdout = "|", stderr = "|", + p <- process$new( + cmd[1], + cmd[-1], + stdout = "|", + stderr = "|", connections = list(pipe[[2]]) ) ) @@ -53,7 +66,6 @@ test_that("reading from extra connection", { }) test_that("reading and writing to extra connection", { - skip_on_cran() msg <- "foobar\n" @@ -63,7 +75,11 @@ test_that("reading and writing to extra connection", { pipe2 <- conn_create_pipepair() expect_silent( - p <- process$new(cmd[1], cmd[-1], stdout = "|", stderr = "|", + p <- process$new( + cmd[1], + cmd[-1], + stdout = "|", + stderr = "|", connections = list(pipe1[[1]], pipe2[[2]]) ) ) diff --git a/tests/testthat/test-fifo.R b/tests/testthat/test-fifo.R index ad881331..bf028ccc 100644 --- a/tests/testthat/test-fifo.R +++ b/tests/testthat/test-fifo.R @@ -1,4 +1,3 @@ - test_that("read end first", { skip_on_cran() @@ -129,14 +128,13 @@ test_that("write end first 2", { test_that("errors", { skip_on_cran() - expect_error( - conn_create_fifo(read = TRUE, write= TRUE) - ) + expect_snapshot(error = TRUE, conn_create_fifo(read = TRUE, write = TRUE)) reader <- conn_create_fifo(read = TRUE) on.exit(close(reader), add = TRUE) - expect_error( + expect_snapshot( + error = TRUE, conn_connect_fifo(read = TRUE, write = TRUE) ) diff --git a/tests/testthat/test-io.R b/tests/testthat/test-io.R index f3a0ce0d..e0578c32 100644 --- a/tests/testthat/test-io.R +++ b/tests/testthat/test-io.R @@ -1,24 +1,27 @@ - test_that("Output and error are discarded by default", { - px <- get_tool("px") p <- process$new(px, c("outln", "foobar")) on.exit(try_silently(p$kill(grace = 0)), add = TRUE) - expect_error(p$read_output_lines(n=1), "not a pipe") - expect_error(p$read_all_output_lines(), "not a pipe") - expect_error(p$read_all_output(), "not a pipe") - expect_error(p$read_error_lines(n=1), "not a pipe") - expect_error(p$read_all_error_lines(), "not a pipe") - expect_error(p$read_all_error(), "not a pipe") + expect_snapshot(error = TRUE, { + p$read_output_lines(n = 1) + p$read_all_output_lines() + p$read_all_output() + p$read_error_lines(n = 1) + p$read_all_error_lines() + p$read_all_error() + }) }) test_that("We can get the output", { - px <- get_tool("px") - p <- process$new(px, c("out", "foo\nbar\nfoobar\n"), - stdout = "|", stderr = "|") + p <- process$new( + px, + c("out", "foo\nbar\nfoobar\n"), + stdout = "|", + stderr = "|" + ) on.exit(try_silently(p$kill(grace = 0)), add = TRUE) out <- p$read_all_output_lines() @@ -26,7 +29,6 @@ test_that("We can get the output", { }) test_that("We can get the error stream", { - tmp <- tempfile(fileext = ".bat") on.exit(unlink(tmp), add = TRUE) @@ -41,7 +43,6 @@ test_that("We can get the error stream", { }) test_that("Output & error at the same time", { - tmp <- tempfile(fileext = ".bat") on.exit(unlink(tmp), add = TRUE) @@ -51,7 +52,8 @@ test_that("Output & error at the same time", { "echo wow", ">&2 echo world", "echo wooow", - sep = "\n", file = tmp + sep = "\n", + file = tmp ) Sys.chmod(tmp, "700") @@ -66,7 +68,6 @@ test_that("Output & error at the same time", { }) test_that("Output and error to specific files", { - tmp <- tempfile(fileext = ".bat") on.exit(unlink(tmp), add = TRUE) @@ -76,7 +77,8 @@ test_that("Output and error to specific files", { "echo wow", ">&2 echo world", "echo wooow", - sep = "\n", file = tmp + sep = "\n", + file = tmp ) Sys.chmod(tmp, "700") @@ -96,7 +98,6 @@ test_that("Output and error to specific files", { }) test_that("is_incomplete", { - px <- get_tool("px") p <- process$new(px, c("out", "foo\nbar\nfoobar\n"), stdout = "|") on.exit(p$kill(), add = TRUE) @@ -111,7 +112,6 @@ test_that("is_incomplete", { }) test_that("readChar on IO, unix", { - ## Need to skip, because of the different EOL character skip_other_platforms("unix") @@ -128,7 +128,6 @@ test_that("readChar on IO, unix", { }) test_that("readChar on IO, windows", { - ## Need to skip, because of the different EOL character skip_other_platforms("windows") @@ -155,7 +154,7 @@ test_that("same pipe", { out <- p$read_all_output() expect_equal(out, "o1e1o2e2") - expect_error(p$read_all_error_lines(), "not a pipe") + expect_snapshot(error = TRUE, p$read_all_error_lines()) }) test_that("same file", { @@ -169,8 +168,8 @@ test_that("same file", { expect_equal(p$get_exit_status(), 0L) expect_equal(readLines(tmp), "o1e1o2e2") - expect_error(p$read_all_output_lines(), "not a pipe") - expect_error(p$read_all_error_lines(), "not a pipe") + expect_snapshot(error = TRUE, p$read_all_output_lines()) + expect_snapshot(error = TRUE, p$read_all_error_lines()) }) test_that("same NULL, for completeness", { @@ -180,6 +179,6 @@ test_that("same NULL, for completeness", { p$wait(2000) p$kill() expect_equal(p$get_exit_status(), 0L) - expect_error(p$read_all_output_lines(), "not a pipe") - expect_error(p$read_all_error_lines(), "not a pipe") + expect_snapshot(error = TRUE, p$read_all_output_lines()) + expect_snapshot(error = TRUE, p$read_all_error_lines()) }) diff --git a/tests/testthat/test-kill-tree.R b/tests/testthat/test-kill-tree.R index 4dee9500..6eecae8b 100644 --- a/tests/testthat/test-kill-tree.R +++ b/tests/testthat/test-kill-tree.R @@ -1,4 +1,3 @@ - test_that("tree ids are inherited", { skip_on_cran() skip_if_no_ps() @@ -18,10 +17,13 @@ test_that("tree ids are inherited", { deadline <- Sys.time() + 3 while (TRUE) { if (Sys.time() >= deadline) break - tryCatch({ - env <- ps::ps_environ(ep)[[ev]] - break }, - error = function(e) e) + tryCatch( + { + env <- ps::ps_environ(ep)[[ev]] + break + }, + error = function(e) e + ) Sys.sleep(0.05) } @@ -38,7 +40,7 @@ test_that("tree ids are inherited if env is specified", { p <- process$new(px, c("sleep", "10"), env = c(FOO = "bar")) on.exit(p$kill(), add = TRUE) - ep <- ps::ps_handle(p$get_pid()) + ep <- ps::ps_handle(p$get_pid()) ev <- paste0("PROCESSX_", get_private(p)$tree_id) @@ -49,10 +51,13 @@ test_that("tree ids are inherited if env is specified", { deadline <- Sys.time() + 3 while (TRUE) { if (Sys.time() >= deadline) break - tryCatch({ - env <- ps::ps_environ(ep)[[ev]] - break }, - error = function(e) e) + tryCatch( + { + env <- ps::ps_environ(ep)[[ev]] + break + }, + error = function(e) e + ) Sys.sleep(0.05) } @@ -91,8 +96,11 @@ test_that("kill_tree with children", { on.exit(unlink(tmp), add = TRUE) p <- callr::r_bg( function(px, tmp) { - processx::run(px, c("outln", "ok", "sleep", "100"), - stdout_callback = function(x, p) cat(x, file = tmp, append = TRUE)) + processx::run( + px, + c("outln", "ok", "sleep", "100"), + stdout_callback = function(x, p) cat(x, file = tmp, append = TRUE) + ) }, args = list(px = get_tool("px"), tmp = tmp) ) @@ -120,10 +128,17 @@ test_that("kill_tree and orphaned children", { on.exit(unlink(tmp), add = TRUE) p1 <- callr::r_bg( function(px, tmp) { - p <- processx::process$new(px, c("outln", "ok", "sleep", "100"), - stdout = tmp, cleanup = FALSE) - list(pid = p$get_pid(), create_time = p$get_start_time(), - id = p$.__enclos_env__$private$tree_id) + p <- processx::process$new( + px, + c("outln", "ok", "sleep", "100"), + stdout = tmp, + cleanup = FALSE + ) + list( + pid = p$get_pid(), + create_time = p$get_start_time(), + id = p$.__enclos_env__$private$tree_id + ) }, args = list(px = get_tool("px"), tmp = tmp) ) @@ -135,8 +150,11 @@ test_that("kill_tree and orphaned children", { expect_true(ps::ps_is_running(ps)) deadline <- Sys.time() + 2 - while ((!file.exists(tmp) || file_size(tmp) == 0) && - Sys.time() < deadline) Sys.sleep(0.05) + while ( + (!file.exists(tmp) || file_size(tmp) == 0) && + Sys.time() < deadline + ) + Sys.sleep(0.05) expect_true(Sys.time() < deadline) res <- p1$kill_tree(pres$id) diff --git a/tests/testthat/test-poll-connections.R b/tests/testthat/test-poll-connections.R index 406b317c..d8b40e31 100644 --- a/tests/testthat/test-poll-connections.R +++ b/tests/testthat/test-poll-connections.R @@ -1,6 +1,4 @@ - test_that("poll a connection", { - px <- get_tool("px") p <- process$new(px, c("sleep", ".5", "outln", "foobar"), stdout = "|") on.exit(p$kill()) @@ -19,7 +17,6 @@ test_that("poll a connection", { }) test_that("poll a connection and a process", { - px <- get_tool("px") p1 <- process$new(px, c("sleep", ".5", "outln", "foobar"), stdout = "|") p2 <- process$new(px, c("sleep", ".5", "outln", "foobar"), stdout = "|") @@ -32,25 +29,26 @@ test_that("poll a connection and a process", { poll(list(out, p2), 0), list( "timeout", - c(output = "timeout", error = "nopipe", process = "nopipe")) + c(output = "timeout", error = "nopipe", process = "nopipe") + ) ) ## At least one of them is ready. Usually both on Unix, but on Windows ## it is different because the IOCP is a queue pr <- poll(list(out, p2), 2000) - expect_true(pr[[1]] == "ready" || pr[[2]][["output"]] == "ready") + expect_true(pr[[1]] == "ready" || pr[[2]][["output"]] == "ready") p1$poll_io(2000) p2$poll_io(2000) p1$read_output_lines() p2$read_output_lines() pr <- poll(list(out, p2), 2000) - expect_true(pr[[1]] == "ready" || pr[[2]][["output"]] == "ready") + expect_true(pr[[1]] == "ready" || pr[[2]][["output"]] == "ready") p1$kill(close_connections = FALSE) p2$kill(close_connections = FALSE) pr <- poll(list(out, p2), 2000) - expect_true(pr[[1]] == "ready" || pr[[2]][["output"]] == "ready") + expect_true(pr[[1]] == "ready" || pr[[2]][["output"]] == "ready") close(out) close(p2$get_output_connection()) diff --git a/tests/testthat/test-poll-curl.R b/tests/testthat/test-poll-curl.R index ff4a5003..3f786cda 100644 --- a/tests/testthat/test-poll-curl.R +++ b/tests/testthat/test-poll-curl.R @@ -1,4 +1,3 @@ - test_that("curl fds", { skip_on_cran() @@ -10,16 +9,36 @@ test_that("curl fds", { pool <- curl::new_pool() url1 <- httpbin$url("/status/200") url2 <- httpbin$url("/delay/1") - curl::multi_add(pool = pool, curl::new_handle(url = url1, http_version = 2), - done = done, fail = fail) - curl::multi_add(pool = pool, curl::new_handle(url = url1, http_version = 2), - done = done, fail = fail) - curl::multi_add(pool = pool, curl::new_handle(url = url2, http_version = 2), - done = done, fail = fail) - curl::multi_add(pool = pool, curl::new_handle(url = url1, http_version = 2), - done = done, fail = fail) - curl::multi_add(pool = pool, curl::new_handle(url = url1, http_version = 2), - done = done, fail = fail) + curl::multi_add( + pool = pool, + curl::new_handle(url = url1, http_version = 2), + done = done, + fail = fail + ) + curl::multi_add( + pool = pool, + curl::new_handle(url = url1, http_version = 2), + done = done, + fail = fail + ) + curl::multi_add( + pool = pool, + curl::new_handle(url = url2, http_version = 2), + done = done, + fail = fail + ) + curl::multi_add( + pool = pool, + curl::new_handle(url = url1, http_version = 2), + done = done, + fail = fail + ) + curl::multi_add( + pool = pool, + curl::new_handle(url = url1, http_version = 2), + done = done, + fail = fail + ) # This does not do much, but at least it tests that we can poll() # libcurl's file descriptors @@ -31,7 +50,7 @@ test_that("curl fds", { pr <- poll(list(curl_fds(fds)), 1000) } state <- curl::multi_run(timeout = 0.1, pool = pool, poll = TRUE) - if (state$pending == 0 || Sys.time() >= timeout) break; + if (state$pending == 0 || Sys.time() >= timeout) break } expect_true(Sys.time() < timeout) @@ -47,10 +66,10 @@ test_that("curl fds before others", { timeout <- Sys.time() + 5 repeat { - state <- curl::multi_run(timeout = 1/10000, pool = pool, poll = TRUE) + state <- curl::multi_run(timeout = 1 / 10000, pool = pool, poll = TRUE) fds <- curl::multi_fdset(pool = pool) - if (length(fds$reads) > 0) break; - if (Sys.time() >= timeout) break; + if (length(fds$reads) > 0) break + if (Sys.time() >= timeout) break } expect_true(Sys.time() < timeout) @@ -62,8 +81,7 @@ test_that("curl fds before others", { pr <- poll(list(pp, curl_fds(fds)), 10000) expect_equal( pr, - list(c(output = "nopipe", error = "nopipe", process = "silent"), - "event") + list(c(output = "nopipe", error = "nopipe", process = "silent"), "event") ) pp$kill() @@ -78,10 +96,10 @@ test_that("process fd before curl fd", { timeout <- Sys.time() + 5 repeat { - state <- curl::multi_run(timeout = 1/10000, pool = pool, poll = TRUE) + state <- curl::multi_run(timeout = 1 / 10000, pool = pool, poll = TRUE) fds <- curl::multi_fdset(pool = pool) - if (length(fds$reads) > 0) break; - if (Sys.time() >= timeout) break; + if (length(fds$reads) > 0) break + if (Sys.time() >= timeout) break } expect_true(Sys.time() < timeout) @@ -93,8 +111,7 @@ test_that("process fd before curl fd", { pr <- poll(list(pp, curl_fds(fds)), 10000) expect_equal( pr, - list(c(output = "nopipe", error = "nopipe", process = "ready"), - "silent") + list(c(output = "nopipe", error = "nopipe", process = "ready"), "silent") ) pp$kill() diff --git a/tests/testthat/test-poll-stress.R b/tests/testthat/test-poll-stress.R index bac2cae9..56065759 100644 --- a/tests/testthat/test-poll-stress.R +++ b/tests/testthat/test-poll-stress.R @@ -1,4 +1,3 @@ - test_that("many processes", { skip_on_cran() @@ -7,9 +6,8 @@ test_that("many processes", { px <- get_tool("px") on.exit(try(lapply(pp, function(x) x$kill()), silent = TRUE), add = TRUE) pp <- lapply(1:num, function(i) { - cmd <- c("sleep", "1", "outln", paste("out", i), - "errln", paste("err", i)) - process$new(px, cmd, stdout = "|", stderr = "|") + cmd <- c("sleep", "1", "outln", paste("out", i), "errln", paste("err", i)) + process$new(px, cmd, stdout = "|", stderr = "|") }) ## poll them @@ -24,7 +22,10 @@ test_that("many processes", { results[[i]][[2]] <<- c(results[[i]][[2]], pp[[i]]$read_error_lines()) } }) - inc <- sapply(pp, function(x) x$is_incomplete_output() || x$is_incomplete_error()) + inc <- sapply( + pp, + function(x) x$is_incomplete_output() || x$is_incomplete_error() + ) if (!any(inc)) break } diff --git a/tests/testthat/test-poll.R b/tests/testthat/test-poll.R index d8f16de3..6ea067e6 100644 --- a/tests/testthat/test-poll.R +++ b/tests/testthat/test-poll.R @@ -1,65 +1,87 @@ - test_that("polling for output available", { - px <- get_tool("px") p <- process$new(px, c("sleep", "1", "outln", "foobar"), stdout = "|") ## Timeout - expect_equal(p$poll_io(0), c(output = "timeout", error = "nopipe", - process = "nopipe")) + expect_equal( + p$poll_io(0), + c(output = "timeout", error = "nopipe", process = "nopipe") + ) p$wait() - expect_equal(p$poll_io(-1), c(output = "ready", error = "nopipe", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "ready", error = "nopipe", process = "nopipe") + ) p$read_output_lines() - expect_equal(p$poll_io(-1), c(output = "ready", error = "nopipe", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "ready", error = "nopipe", process = "nopipe") + ) p$kill(close_connections = FALSE) - expect_equal(p$poll_io(-1), c(output = "ready", error = "nopipe", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "ready", error = "nopipe", process = "nopipe") + ) close(p$get_output_connection()) - expect_equal(p$poll_io(-1), c(output = "closed", error = "nopipe", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "closed", error = "nopipe", process = "nopipe") + ) }) test_that("polling for stderr", { - px <- get_tool("px") p <- process$new(px, c("sleep", "1", "errln", "foobar"), stderr = "|") ## Timeout - expect_equal(p$poll_io(0), c(output = "nopipe", error = "timeout", - process = "nopipe")) + expect_equal( + p$poll_io(0), + c(output = "nopipe", error = "timeout", process = "nopipe") + ) p$wait() - expect_equal(p$poll_io(-1), c(output = "nopipe", error = "ready", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "nopipe", error = "ready", process = "nopipe") + ) p$read_error_lines() - expect_equal(p$poll_io(-1), c(output = "nopipe", error = "ready", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "nopipe", error = "ready", process = "nopipe") + ) p$kill(close_connections = FALSE) - expect_equal(p$poll_io(-1), c(output = "nopipe", error = "ready", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "nopipe", error = "ready", process = "nopipe") + ) close(p$get_error_connection()) - expect_equal(p$poll_io(-1), c(output = "nopipe", error = "closed", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "nopipe", error = "closed", process = "nopipe") + ) }) test_that("polling for both stdout and stderr", { - px <- get_tool("px") - p <- process$new(px, c("sleep", "1", "errln", "foo", "outln", "bar"), - stdout = "|", stderr = "|") + p <- process$new( + px, + c("sleep", "1", "errln", "foo", "outln", "bar"), + stdout = "|", + stderr = "|" + ) ## Timeout - expect_equal(p$poll_io(0), c(output = "timeout", error = "timeout", - process = "nopipe")) + expect_equal( + p$poll_io(0), + c(output = "timeout", error = "timeout", process = "nopipe") + ) p$wait() expect_true("ready" %in% p$poll_io(-1)) @@ -72,16 +94,20 @@ test_that("polling for both stdout and stderr", { close(p$get_output_connection()) close(p$get_error_connection()) - expect_equal(p$poll_io(-1), c(output = "closed", error = "closed", - process = "nopipe")) + expect_equal( + p$poll_io(-1), + c(output = "closed", error = "closed", process = "nopipe") + ) }) test_that("multiple polls", { - px <- get_tool("px") p <- process$new( - px, c("sleep", "1", "outln", "foo", "sleep", "1", "outln", "bar"), - stdout = "|", stderr = "|") + px, + c("sleep", "1", "outln", "foo", "sleep", "1", "outln", "bar"), + stdout = "|", + stderr = "|" + ) on.exit(p$kill(), add = TRUE) out <- character() diff --git a/tests/testthat/test-poll2.R b/tests/testthat/test-poll2.R index 15c36839..1aa122bc 100644 --- a/tests/testthat/test-poll2.R +++ b/tests/testthat/test-poll2.R @@ -1,9 +1,10 @@ - test_that("single process", { - px <- get_tool("px") - p <- process$new(px, c("sleep", "1", "outln", "foo", "outln", "bar"), - stdout = "|") + p <- process$new( + px, + c("sleep", "1", "outln", "foo", "outln", "bar"), + stdout = "|" + ) on.exit(p$kill(), add = TRUE) ## Timeout @@ -38,7 +39,6 @@ test_that("single process", { }) test_that("multiple processes", { - px <- get_tool("px") cmd1 <- c("sleep", "1", "outln", "foo", "outln", "bar") cmd2 <- c("sleep", "2", "errln", "foo", "errln", "bar") @@ -58,7 +58,10 @@ test_that("multiple processes", { p1$wait() res <- poll(list(p1 = p1, p2 = p2), -1) - expect_equal(res$p1, c(output = "ready", error = "nopipe", process = "nopipe")) + expect_equal( + res$p1, + c(output = "ready", error = "nopipe", process = "nopipe") + ) expect_equal(res$p2[["output"]], "nopipe") expect_true(res$p2[["error"]] %in% c("silent", "ready")) @@ -82,11 +85,9 @@ test_that("multiple processes", { p2 = c(output = "nopipe", error = "closed", process = "nopipe") ) ) - }) test_that("multiple polls", { - px <- get_tool("px") cmd <- c("sleep", "1", "outln", "foo", "sleep", "1", "outln", "bar") p <- process$new(px, cmd, stdout = "|", stderr = "|") @@ -107,10 +108,14 @@ test_that("polling and buffering", { px <- get_tool("px") for (i in 1:10) { - ## We set up two processes, one produces a output, that we do not ## read out from the cache. The other one does not produce output. - p1 <- process$new(px, c(rbind("outln", 1:20), "sleep", "3"), stdout = "|", stderr = "|") + p1 <- process$new( + px, + c(rbind("outln", 1:20), "sleep", "3"), + stdout = "|", + stderr = "|" + ) p2 <- process$new(px, c("sleep", "3"), stdout = "|", stderr = "|") ## We poll until p1 has output. We read out some of the output, @@ -136,18 +141,16 @@ test_that("polling and buffering", { p1$kill() p2$kill() - if (s[[2]][1] != "silent") break; + if (s[[2]][1] != "silent") break } }) test_that("polling and buffering #2", { - px <- get_tool("px") ## We run this a bunch of times, because it used to fail ## non-deterministically on the CI for (i in 1:10) { - ## Two processes, they both produce output. For the first process, ## we make sure that there is something in the buffer. ## For the second process we need to poll, but data should be diff --git a/tests/testthat/test-poll3.R b/tests/testthat/test-poll3.R index 4ded0f5d..8ea92aa4 100644 --- a/tests/testthat/test-poll3.R +++ b/tests/testthat/test-poll3.R @@ -1,58 +1,74 @@ - test_that("poll connection", { px <- get_tool("px") p <- process$new(px, c("sleep", ".5", "outln", "foobar")) on.exit(p$kill()) ## Timeout - expect_equal(p$poll_io(0), c(output = "nopipe", error = "nopipe", - process = "timeout")) + expect_equal( + p$poll_io(0), + c(output = "nopipe", error = "nopipe", process = "timeout") + ) p$wait() - expect_equal(p$poll_io(-1), c(output = "nopipe", error = "nopipe", - process = "ready")) + expect_equal( + p$poll_io(-1), + c(output = "nopipe", error = "nopipe", process = "ready") + ) p$kill(close_connections = FALSE) - expect_equal(p$poll_io(-1), c(output = "nopipe", error = "nopipe", - process = "ready")) + expect_equal( + p$poll_io(-1), + c(output = "nopipe", error = "nopipe", process = "ready") + ) close(p$get_poll_connection()) - expect_equal(p$poll_io(-1), c(output = "nopipe", error = "nopipe", - process = "closed")) + expect_equal( + p$poll_io(-1), + c(output = "nopipe", error = "nopipe", process = "closed") + ) }) test_that("poll connection + stdout", { - px <- get_tool("px") p1 <- process$new(px, c("outln", "foobar"), stdout = "|") on.exit(p1$kill(), add = TRUE) expect_false(p1$has_poll_connection()) - p2 <- process$new(px, c("sleep", "0.5", "outln", "foobar"), stdout = "|", - poll_connection = TRUE) + p2 <- process$new( + px, + c("sleep", "0.5", "outln", "foobar"), + stdout = "|", + poll_connection = TRUE + ) on.exit(p2$kill(), add = TRUE) - expect_equal(p2$poll_io(0), c(output = "timeout", error = "nopipe", - process = "timeout")) + expect_equal( + p2$poll_io(0), + c(output = "timeout", error = "nopipe", process = "timeout") + ) pr <- p2$poll_io(-1) expect_true("ready" %in% pr) }) test_that("poll connection + stderr", { - px <- get_tool("px") p1 <- process$new(px, c("errln", "foobar"), stderr = "|") on.exit(p1$kill(), add = TRUE) expect_false(p1$has_poll_connection()) - p2 <- process$new(px, c("sleep", "0.5", "errln", "foobar"), stderr = "|", - poll_connection = TRUE) + p2 <- process$new( + px, + c("sleep", "0.5", "errln", "foobar"), + stderr = "|", + poll_connection = TRUE + ) on.exit(p2$kill(), add = TRUE) - expect_equal(p2$poll_io(0), c(output = "nopipe", error = "timeout", - process = "timeout")) - + expect_equal( + p2$poll_io(0), + c(output = "nopipe", error = "timeout", process = "timeout") + ) }) diff --git a/tests/testthat/test-print.R b/tests/testthat/test-print.R index b031cff0..72001ba1 100644 --- a/tests/testthat/test-print.R +++ b/tests/testthat/test-print.R @@ -1,6 +1,4 @@ - test_that("print", { - px <- get_tool("px") p <- process$new(px, c("sleep", "5")) on.exit(try_silently(p$kill(grace = 0)), add = TRUE) diff --git a/tests/testthat/test-process.R b/tests/testthat/test-process.R index ead69473..fef1688d 100644 --- a/tests/testthat/test-process.R +++ b/tests/testthat/test-process.R @@ -1,6 +1,4 @@ - test_that("process works", { - px <- get_tool("px") p <- process$new(px, c("sleep", "5")) on.exit(try_silently(p$kill(grace = 0)), add = TRUE) @@ -8,7 +6,6 @@ test_that("process works", { }) test_that("get_exit_status", { - px <- get_tool("px") p <- process$new(px, c("return", "1")) on.exit(p$kill(), add = TRUE) @@ -17,30 +14,43 @@ test_that("get_exit_status", { }) test_that("non existing process", { - expect_error(process$new(tempfile())) + expect_snapshot( + error = TRUE, + process$new(tempfile()), + transform = transform_tempdir, + variant = sysname() + ) ## This closes connections in finalizers gc() }) test_that("post processing", { - px <- get_tool("px") p <- process$new( - px, c("return", "0"), post_process = function() "foobar") + px, + c("return", "0"), + post_process = function() "foobar" + ) p$wait(5000) p$kill() expect_equal(p$get_result(), "foobar") p <- process$new( - px, c("sleep", "5"), post_process = function() "yep") - expect_error(p$get_result(), "alive") + px, + c("sleep", "5"), + post_process = function() "yep" + ) + expect_snapshot(error = TRUE, p$get_result()) p$kill() expect_equal(p$get_result(), "yep") ## Only runs once xx <- 0 p <- process$new( - px, c("return", "0"), post_process = function() xx <<- xx + 1) + px, + c("return", "0"), + post_process = function() xx <<- xx + 1 + ) p$wait(5000) p$kill() p$get_result() @@ -50,7 +60,7 @@ test_that("post processing", { }) test_that("working directory", { - px <- get_tool("px") + px <- get_tool("px") dir.create(tmp <- tempfile()) on.exit(unlink(tmp, recursive = TRUE), add = TRUE) cat("foo\nbar\n", file = file.path(tmp, "file")) @@ -63,7 +73,12 @@ test_that("working directory", { test_that("working directory does not exist", { px <- get_tool("px") - expect_error(process$new(px, wd = tempfile())) + expect_snapshot( + error = TRUE, + process$new(px, wd = tempfile()), + transform = transform_px, + variant = sysname() + ) ## This closes connections in finalizers gc() }) diff --git a/tests/testthat/test-ps-methods.R b/tests/testthat/test-ps-methods.R index cb9e3529..27481e4a 100644 --- a/tests/testthat/test-ps-methods.R +++ b/tests/testthat/test-ps-methods.R @@ -1,4 +1,3 @@ - test_that("ps methods", { skip_if_no_ps() diff --git a/tests/testthat/test-pty.R b/tests/testthat/test-pty.R index 6a243852..c5a01e5e 100644 --- a/tests/testthat/test-pty.R +++ b/tests/testthat/test-pty.R @@ -1,8 +1,10 @@ - test_that("fails in windows", { skip_other_platforms("windows") - expect_error(process$new("R", pty = TRUE), "only implemented on Unix", - class = "error") + expect_error( + process$new("R", pty = TRUE), + "only implemented on Unix", + class = "error" + ) }) test_that("pty works", { @@ -58,7 +60,7 @@ test_that("read_output_lines() fails for pty", { p <- process$new("cat", pty = TRUE) p$write_input("foobar\n") - expect_error(p$read_output_lines(), "Cannot read lines from a pty") + expect_snapshot(error = TRUE, p$read_output_lines()) pr <- p$poll_io(300) expect_equal(pr[["output"]], "ready") diff --git a/tests/testthat/test-run.R b/tests/testthat/test-run.R index 604a2414..4ac9dfb7 100644 --- a/tests/testthat/test-run.R +++ b/tests/testthat/test-run.R @@ -1,15 +1,15 @@ - test_that("run can run", { - px <- get_tool("px") - expect_error({ - run(px, c("sleep", "0")) - }, NA) + expect_error( + { + run(px, c("sleep", "0")) + }, + NA + ) gc() }) test_that("timeout works", { - px <- get_tool("px") tic <- Sys.time() x <- run(px, c("sleep", "5"), timeout = 0.00001, error_on_status = FALSE) @@ -21,7 +21,6 @@ test_that("timeout works", { }) test_that("timeout throws right error", { - px <- get_tool("px") e <- tryCatch( run(px, c("sleep", "5"), timeout = 0.00001, error_on_status = TRUE), @@ -33,14 +32,14 @@ test_that("timeout throws right error", { }) test_that("callbacks work", { - px <- get_tool("px") ## This typically freezes on Unix, if there is a malloc/free race ## condition in the SIGCHLD handler. for (i in 1:30) { out <- NULL run( - px, rbind("outln", 1:20), + px, + rbind("outln", 1:20), stdout_line_callback = function(x, ...) out <<- c(out, x) ) expect_equal(out, as.character(1:20)) @@ -50,7 +49,8 @@ test_that("callbacks work", { for (i in 1:30) { out <- NULL run( - px, rbind("errln", 1:20), + px, + rbind("errln", 1:20), stderr_line_callback = function(x, ...) out <<- c(out, x), error_on_status = FALSE ) @@ -66,7 +66,7 @@ test_that("working directory", { cat("foo\nbar\n", file = file.path(tmp, "file")) x <- run(px, c("cat", "file"), wd = tmp) - if (is_windows()) { + if (is_windows()) { expect_equal(x$stdout, "foo\r\nbar\r\n") } else { expect_equal(x$stdout, "foo\nbar\n") @@ -76,7 +76,12 @@ test_that("working directory", { test_that("working directory does not exist", { px <- get_tool("px") - expect_error(run(px, wd = tempfile())) + expect_snapshot( + error = TRUE, + run(px, wd = tempfile()), + transform = transform_px, + variant = sysname() + ) gc() }) @@ -84,12 +89,16 @@ test_that("stderr_to_stdout", { px <- get_tool("px") out <- run( - px, c("out", "o1", "err", "e1", "out", "o2", "err", "e2", "outln", ""), - stderr_to_stdout = TRUE) + px, + c("out", "o1", "err", "e1", "out", "o2", "err", "e2", "outln", ""), + stderr_to_stdout = TRUE + ) expect_equal(out$status, 0L) expect_equal( - out$stdout, paste0("o1e1o2e2", if (is_windows()) "\r", "\n")) + out$stdout, + paste0("o1e1o2e2", if (is_windows()) "\r", "\n") + ) expect_equal(out$stderr, NULL) expect_false(out$timeout) }) @@ -105,7 +114,8 @@ test_that("condition on interrupt", { cnd <- tryCatch( interrupt_me(run(px, c("errln", "oops", "errflush", "sleep", 3)), 0.5), error = function(c) c, - interrupt = function(c) c) + interrupt = function(c) c + ) expect_s3_class(cnd, "system_command_interrupt") expect_equal(str_trim(cnd$stderr), "oops") @@ -122,7 +132,8 @@ test_that("stdin", { expect_equal( strsplit(res$stdout, "\r?\n")[[1]], - c("foobar", "this is the input")) + c("foobar", "this is the input") + ) }) test_that("drop stdout", { @@ -152,7 +163,12 @@ test_that("redirect stout", { on.exit(unlink(c(tmp1, tmp2)), add = TRUE) px <- get_tool("px") - res <- run(px, c("outln", "boo", "errln", "bah"), stdout = tmp1, stderr = tmp2) + res <- run( + px, + c("outln", "boo", "errln", "bah"), + stdout = tmp1, + stderr = tmp2 + ) expect_null(res$stdout) expect_null(res$stderr) expect_equal(readLines(tmp1), "boo") diff --git a/tests/testthat/test-set-std.R b/tests/testthat/test-set-std.R index fe9b5ad8..32fcee62 100644 --- a/tests/testthat/test-set-std.R +++ b/tests/testthat/test-set-std.R @@ -1,4 +1,3 @@ - test_that("setting stdout to a file", { stdout_to_file <- function(filename) { con <- processx::conn_create_file(filename, write = TRUE) @@ -13,7 +12,8 @@ test_that("setting stdout to a file", { on.exit(unlink(tmp), add = TRUE) opt <- callr::r_process_options( func = stdout_to_file, - args = list(filename = tmp)) + args = list(filename = tmp) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) @@ -40,7 +40,8 @@ test_that("setting stderr to a file", { on.exit(unlink(tmp), add = TRUE) opt <- callr::r_process_options( func = stderr_to_file, - args = list(filename = tmp)) + args = list(filename = tmp) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) @@ -75,7 +76,8 @@ test_that("setting stdout multiple times", { on.exit(unlink(c(tmp1, tmp2)), add = TRUE) opt <- callr::r_process_options( func = stdout_to_file, - args = list(file1 = tmp1, file2 = tmp2)) + args = list(file1 = tmp1, file2 = tmp2) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) @@ -143,7 +145,8 @@ test_that("set stdout and save the old fd", { on.exit(unlink(c(tmp1, tmp2)), add = TRUE) opt <- callr::r_process_options( func = stdout, - args = list(file1 = tmp1, file2 = tmp2)) + args = list(file1 = tmp1, file2 = tmp2) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) @@ -172,7 +175,8 @@ test_that("set stderr and save the old fd", { on.exit(unlink(c(tmp1, tmp2)), add = TRUE) opt <- callr::r_process_options( func = stderr, - args = list(file1 = tmp1, file2 = tmp2)) + args = list(file1 = tmp1, file2 = tmp2) + ) on.exit(p$kill(), add = TRUE) p <- callr::r_process$new(opt) diff --git a/tests/testthat/test-sigchld.R b/tests/testthat/test-sigchld.R index 156ad93c..a1c648b4 100644 --- a/tests/testthat/test-sigchld.R +++ b/tests/testthat/test-sigchld.R @@ -1,4 +1,3 @@ - test_that("is_alive()", { skip_other_platforms("unix") skip_on_cran() @@ -47,7 +46,14 @@ test_that("finalizer", { p <- mcparallel(Sys.sleep(1)) q <- mcparallel(Sys.sleep(1)) res <- mccollect(list(p, q)) - tryCatch({ rm(px); gc(); "OK" }, error = function(x) x) + tryCatch( + { + rm(px) + gc() + "OK" + }, + error = function(x) x + ) }) expect_identical(res$result, "OK") @@ -100,7 +106,7 @@ test_that("signal", { q <- mcparallel(Sys.sleep(1)) res <- mccollect(list(p, q)) - signal <- px$signal(2) # SIGINT + signal <- px$signal(2) # SIGINT status <- px$get_exit_status() list(signal = signal, status = status) }) @@ -163,11 +169,14 @@ test_that("SIGCHLD handler", { q <- mcparallel(Sys.sleep(1)) res <- mccollect(list(p, q)) - out <- tryCatch({ - px2 <- process$new("true") - px2$wait(1) - "OK" - }, error = function(e) e) + out <- tryCatch( + { + px2 <- process$new("true") + px2$wait(1) + "OK" + }, + error = function(e) e + ) list(out = out, status = px$get_exit_status()) }) diff --git a/tests/testthat/test-standalone-errors.R b/tests/testthat/test-standalone-errors.R index eeec174b..05bfca5e 100644 --- a/tests/testthat/test-standalone-errors.R +++ b/tests/testthat/test-standalone-errors.R @@ -1,4 +1,3 @@ - test_that("throw() is standalone", { stenv <- environment(throw) objs <- ls(stenv, all.names = TRUE) @@ -8,8 +7,12 @@ test_that("throw() is standalone", { expect_message( withCallingHandlers( - res <- mapply(codetools::checkUsage, funobjs, funs, - MoreArgs = list(report = message)), + res <- mapply( + codetools::checkUsage, + funobjs, + funs, + MoreArgs = list(report = message) + ), message = function(c) { if (grepl(".hide_from_trace", c$message)) { invokeRestart("muffleMessage") @@ -37,18 +40,23 @@ test_that("new_error", { test_that("throw() works with condition objects or strings", { expect_error( - throw("foobar"), "foobar", - class = "rlib_error") + throw("foobar"), + "foobar", + class = "rlib_error" + ) expect_error( - throw(new_error("foobar")), "foobar", - class = "rlib_error") + throw(new_error("foobar")), + "foobar", + class = "rlib_error" + ) }) test_that("parent must be an error object", { expect_error( throw(new_error("foobar"), parent = "nope"), "Parent condition must be a condition object", - class = "rlib_error") + class = "rlib_error" + ) }) test_that("throw() adds the proper call, if requested", { @@ -77,7 +85,6 @@ test_that("caught conditions have no trace", { }) test_that("un-caught condition has trace", { - skip_on_cran() # We need to run this in a separate script, because @@ -90,14 +97,17 @@ test_that("un-caught condition has trace", { se <- paste0(sf, "err") on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE) - expr <- substitute({ - f <- function() g() - g <- function() processx:::throw(processx:::new_error("oooops")) - options(rlib_error_handler = function(c) { - saveRDS(c, file = `__op__`) - }) - f() - }, list("__op__" = op)) + expr <- substitute( + { + f <- function() g() + g <- function() processx:::throw(processx:::new_error("oooops")) + options(rlib_error_handler = function(c) { + saveRDS(c, file = `__op__`) + }) + f() + }, + list("__op__" = op) + ) cat(deparse(expr), file = sf, sep = "\n") @@ -109,13 +119,12 @@ test_that("un-caught condition has trace", { }) test_that("chain_call", { - do <- function() { chain_call(c_processx_base64_encode, "foobar") } cond <- tryCatch( - do(), - error = function(e) e + do(), + error = function(e) e ) expect_equal(cond$call, "do()") @@ -128,7 +137,8 @@ test_that("errors from subprocess", { if (packageVersion("callr") != "3.7.0") skip("only with callr 3.7.0") err <- tryCatch( callr::r(function() 1 + "a"), - error = function(e) e) + error = function(e) e + ) expect_s3_class(err, "rlib_error") expect_s3_class(err$parent, "error") expect_false(is.null(err$parent$trace)) @@ -138,7 +148,8 @@ test_that("errors from subprocess", { skip_if_not_installed("callr", minimum_version = "3.7.0.9000") err <- tryCatch( callr::r(function() 1 + "a"), - error = function(e) e) + error = function(e) e + ) expect_s3_class(err, "rlib_error") expect_s3_class(err$parent, "error") expect_false(is.null(err$parent_trace)) @@ -155,15 +166,18 @@ test_that("error trace from subprocess", { se <- paste0(sf, "err") on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE) - expr <- substitute({ - h <- function() callr::r(function() 1 + "a") - options(rlib_error_handler = function(c) { - saveRDS(c, file = `__op__`) - # quit after the first, because the other one is caught here as well - q() - }) - h() - }, list("__op__" = op)) + expr <- substitute( + { + h <- function() callr::r(function() 1 + "a") + options(rlib_error_handler = function(c) { + saveRDS(c, file = `__op__`) + # quit after the first, because the other one is caught here as well + q() + }) + h() + }, + list("__op__" = op) + ) cat(deparse(expr), file = sf, sep = "\n") @@ -191,15 +205,18 @@ test_that("error trace from subprocess", { se <- paste0(sf, "err") on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE) - expr <- substitute({ - h <- function() callr::r(function() 1 + "a") - options(rlib_error_handler = function(c) { - saveRDS(c, file = `__op__`) - # quit after the first, because the other one is caught here as well - q() - }) - h() - }, list("__op__" = op)) + expr <- substitute( + { + h <- function() callr::r(function() 1 + "a") + options(rlib_error_handler = function(c) { + saveRDS(c, file = `__op__`) + # quit after the first, because the other one is caught here as well + q() + }) + h() + }, + list("__op__" = op) + ) cat(deparse(expr), file = sf, sep = "\n") @@ -223,15 +240,18 @@ test_that("error trace from throw() in subprocess", { se <- paste0(sf, "err") on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE) - expr <- substitute({ - h <- function() callr::r(function() processx::run("does-not-exist---")) - options(rlib_error_handler = function(c) { - saveRDS(c, file = `__op__`) - # quit after the first, because the other one is caught here as well - q() - }) - h() - }, list("__op__" = op)) + expr <- substitute( + { + h <- function() callr::r(function() processx::run("does-not-exist---")) + options(rlib_error_handler = function(c) { + saveRDS(c, file = `__op__`) + # quit after the first, because the other one is caught here as well + q() + }) + h() + }, + list("__op__" = op) + ) cat(deparse(expr), file = sf, sep = "\n") @@ -259,15 +279,18 @@ test_that("error trace from throw() in subprocess", { se <- paste0(sf, "err") on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE) - expr <- substitute({ - h <- function() callr::r(function() processx::run("does-not-exist---")) - options(rlib_error_handler = function(c) { - saveRDS(c, file = `__op__`) - # quit after the first, because the other one is caught here as well - q() - }) - h() - }, list("__op__" = op)) + expr <- substitute( + { + h <- function() callr::r(function() processx::run("does-not-exist---")) + options(rlib_error_handler = function(c) { + saveRDS(c, file = `__op__`) + # quit after the first, because the other one is caught here as well + q() + }) + h() + }, + list("__op__" = op) + ) cat(deparse(expr), file = sf, sep = "\n") @@ -317,13 +340,12 @@ test_that("error is printed on error", { selines <- readLines(so) expect_true( any(grepl("No such file or directory", selines)) || - any(grepl("Command .* not found", selines)) + any(grepl("Command .* not found", selines)) ) expect_false(any(grepl("Stack trace", selines))) }) test_that("trace is printed on error in non-interactive sessions", { - sf <- tempfile(fileext = ".R") so <- paste0(sf, "out") se <- paste0(sf, "err") @@ -361,9 +383,9 @@ test_that("can pass frame as error call in `new_error()`", { f <- function() check_bar() g <- function() check_foo() - expect_snapshot({ - (expect_error(f())) - (expect_error(g())) + expect_snapshot(error = TRUE, { + f() + g() }) }) @@ -377,8 +399,8 @@ test_that("can pass frame as error call in `throw()`", { f <- function() check_bar() g <- function() check_foo() - expect_snapshot({ - (expect_error(f())) - (expect_error(g())) + expect_snapshot(error = TRUE, { + f() + g() }) }) diff --git a/tests/testthat/test-stdin.R b/tests/testthat/test-stdin.R index 95da613e..1c7b2c70 100644 --- a/tests/testthat/test-stdin.R +++ b/tests/testthat/test-stdin.R @@ -1,6 +1,4 @@ - test_that("stdin", { - skip_on_cran() skip_if_no_tool("cat") @@ -22,7 +20,6 @@ test_that("stdin", { }) test_that("stdin & stdout", { - skip_on_cran() skip_if_no_tool("cat") @@ -44,7 +41,6 @@ test_that("stdin & stdout", { }) test_that("stdin buffer full", { - skip_on_cran() skip_other_platforms("unix") @@ -60,7 +56,6 @@ test_that("stdin buffer full", { }) test_that("file as stdin", { - skip_on_cran() skip_if_no_tool("cat") @@ -79,7 +74,6 @@ test_that("file as stdin", { }) test_that("large file as stdin", { - skip_on_cran() skip_if_no_tool("cat") diff --git a/tests/testthat/test-stress.R b/tests/testthat/test-stress.R index 6109d49d..448dcecb 100644 --- a/tests/testthat/test-stress.R +++ b/tests/testthat/test-stress.R @@ -1,4 +1,3 @@ - test_that("can start 100 processes quickly", { skip_on_cran() px <- get_tool("px") @@ -12,7 +11,7 @@ test_that("run() a lot of times, with small timeouts", { for (i in 1:100) { tic <- Sys.time() err <- tryCatch( - run(px, c("sleep", "5"), timeout = 1/1000), + run(px, c("sleep", "5"), timeout = 1 / 1000), error = identity ) expect_s3_class(err, "system_command_timeout_error") @@ -27,7 +26,7 @@ test_that("run() and kill while polling", { for (i in 1:10) { tic <- Sys.time() err <- tryCatch( - run(px, c("sleep", "5"), timeout = 1/2), + run(px, c("sleep", "5"), timeout = 1 / 2), error = identity ) expect_s3_class(err, "system_command_timeout_error") diff --git a/tests/testthat/test-unix-sockets.R b/tests/testthat/test-unix-sockets.R index ac34cfc5..b84d8603 100644 --- a/tests/testthat/test-unix-sockets.R +++ b/tests/testthat/test-unix-sockets.R @@ -1,4 +1,3 @@ - test_that("CRUD", { skip_on_cran() @@ -32,7 +31,7 @@ test_that("CRUD", { conn_accept_unix_socket(sock1) expect_equal(conn_unix_socket_state(sock1), "connected_server") - expect_error(conn_accept_unix_socket(sock1), "Socket is not listening") + expect_snapshot(error = TRUE, conn_accept_unix_socket(sock1)) pr <- poll(list(sock1, sock2), 1) expect_equal(pr, list("timeout", "timeout")) @@ -126,7 +125,7 @@ test_that("reading unaccepted server socket is error", { list("connect") ) - expect_error(conn_read_chars(sock1)) + expect_snapshot(error = TRUE, conn_read_chars(sock1), variant = sysname()) close(sock1) close(sock2) @@ -147,7 +146,7 @@ test_that("writing unaccepted server socket is error", { list("connect") ) - expect_error(conn_write(sock1, "Hello\n")) + expect_snapshot(error = TRUE, conn_write(sock1, "Hello\n")) close(sock1) close(sock2) @@ -227,15 +226,21 @@ test_that("errors", { if (!is_windows()) { sock <- file.path(tempdir(), strrep(basename(tempfile()), 1000)) - expect_error(conn_create_unix_socket(sock)) - expect_error(conn_create_unix_socket("/dev/null")) - expect_error(conn_connect_unix_socket("/dev/null")) + expect_snapshot( + error = TRUE, + { + conn_create_unix_socket(sock) + conn_create_unix_socket("/dev/null") + conn_connect_unix_socket("/dev/null") + }, + transform = transform_tempdir, + variant = sysname() + ) } ff <- conn_create_fifo() - expect_error(conn_accept_unix_socket(ff)) - - expect_error(conn_unix_socket_state(ff)) + expect_snapshot(error = TRUE, conn_accept_unix_socket(ff)) + expect_snapshot(error = TRUE, conn_unix_socket_state(ff)) }) test_that("unix-sockets.h", { diff --git a/tests/testthat/test-utf8.R b/tests/testthat/test-utf8.R index c3458cd9..0814fda0 100644 --- a/tests/testthat/test-utf8.R +++ b/tests/testthat/test-utf8.R @@ -1,4 +1,3 @@ - test_that("UTF-8 executable name", { skip_on_cran() local_temp_dir() diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R index 0f2b8a00..9c1e0764 100644 --- a/tests/testthat/test-utils.R +++ b/tests/testthat/test-utils.R @@ -1,6 +1,4 @@ - test_that("full_path gives correct values", { - skip_on_cran() if (is_windows()) { @@ -20,12 +18,17 @@ test_that("full_path gives correct values", { expect_identical(full_path("a/../b/c"), file.path(getwd(), "b/c")) expect_identical( full_path( - "../../../../../../../../../../../../../../../../../../../../../../../a"), - file.path(drive, "a")) + "../../../../../../../../../../../../../../../../../../../../../../../a" + ), + file.path(drive, "a") + ) expect_identical(full_path("/../.././a"), file.path(drive, "a")) expect_identical(full_path("/a/./b/../c"), file.path(drive, "a/c")) - expect_identical(full_path("~nonexistent_user"), file.path(getwd(), "~nonexistent_user")) + expect_identical( + full_path("~nonexistent_user"), + file.path(getwd(), "~nonexistent_user") + ) expect_identical( full_path("~/a/../b"), # On Windows, path.expand() can return a path with backslashes @@ -62,9 +65,11 @@ test_that("full_path gives correct values, windows", { # Can't go .. to remove the server name expect_identical(full_path("//a/b/../.."), "//a/") expect_identical(full_path("//a/../b"), "//a/b") - expect_error(full_path("//")) - expect_error(full_path("///")) - expect_error(full_path("///a")) + expect_snapshot(error = TRUE, { + full_path("//") + full_path("///") + full_path("///a") + }) }) test_that("full_path gives correct values, unix", { @@ -89,7 +94,6 @@ test_that("do_echo_cmd", { }) test_that("sh_quote_smart", { - cases <- list( list(c("foo", "bar")), list(character()), @@ -114,7 +118,8 @@ test_that("base64", { for (i in 5:32) { mtcars2 <- unserialize(base64_decode(base64_encode( - serialize(mtcars[1:i, ], NULL)))) - expect_identical(mtcars[1:i,], mtcars2) + serialize(mtcars[1:i, ], NULL) + ))) + expect_identical(mtcars[1:i, ], mtcars2) } }) diff --git a/tests/testthat/test-wait.R b/tests/testthat/test-wait.R index 17adb652..84c1dc1e 100644 --- a/tests/testthat/test-wait.R +++ b/tests/testthat/test-wait.R @@ -1,6 +1,4 @@ - test_that("no deadlock when no stdout + wait", { - skip("failure would freeze") p <- process$new("seq", c("1", "100000")) @@ -8,7 +6,6 @@ test_that("no deadlock when no stdout + wait", { }) test_that("wait with timeout", { - px <- get_tool("px") p <- process$new(px, c("sleep", "3")) expect_true(p$is_alive()) @@ -18,22 +15,23 @@ test_that("wait with timeout", { t2 <- proc.time() expect_true(p$is_alive()) - expect_true((t2 - t1)["elapsed"] > 50/1000) - expect_true((t2 - t1)["elapsed"] < 3000/1000) + expect_true((t2 - t1)["elapsed"] > 50 / 1000) + expect_true((t2 - t1)["elapsed"] < 3000 / 1000) p$kill() expect_false(p$is_alive()) }) test_that("wait after process already exited", { - px <- get_tool("px") - pxs <- replicate(20, process$new(px, c("outln", "foo", "outln", "bar"))) + pxs <- replicate(20, process$new(px, c("outln", "foo", "outln", "bar"))) rm(pxs) p <- process$new( - px, c("outln", "foo", "outln", "bar", "outln", "foobar")) + px, + c("outln", "foo", "outln", "bar", "outln", "foobar") + ) on.exit(p$kill(), add = TRUE) ## Make sure it is done diff --git a/tools/valgrind.supp b/tools/valgrind.supp new file mode 100644 index 00000000..c043248c --- /dev/null +++ b/tools/valgrind.supp @@ -0,0 +1,540 @@ +{ + Suppression 1 for setenv in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:forcePromise.part.0 +} +{ + Suppressions 2 for setenv in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:Putenv + fun:process_Renviron + fun:process_system_Renviron + fun:Rf_initialize_R + fun:main +} +{ + Suppression 3 for calloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:calloc + fun:UnknownInlinedFun + fun:allocate_dtv + fun:_dl_allocate_tls + fun:pthread_create@@GLIBC_2.34 + fun:cli__start_thread + fun:clic_start_thread + fun:R_doDotCall + fun:do_dotcall + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure +} +{ + Suppression 4 for calloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:calloc + fun:UnknownInlinedFun + fun:allocate_dtv + fun:_dl_allocate_tls + fun:pthread_create@@GLIBC_2.34 + fun:blas_thread_init + fun:gotoblas_init + fun:call_init + fun:call_init + fun:_dl_init + obj:/usr/lib64/ld-linux-x86-64.so.2 + obj:* + obj:* + obj:* +} +{ + Suppression 5 for setenv in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:do_docall +} +{ + Suppression 6 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:do_docall + fun:bcEval_loop +} +{ + Suppression 7 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:UnknownInlinedFun + fun:_dlfo_mappings_segment_allocate + fun:_dl_find_object_update_1 + fun:_dl_find_object_update + fun:dl_open_worker_begin + fun:_dl_catch_exception + fun:dl_open_worker + fun:_dl_catch_exception + fun:_dl_open + fun:dlopen_doit + fun:_dl_catch_exception + fun:_dl_catch_error + fun:_dlerror_run + fun:dlopen@@GLIBC_2.34 +} +{ + Suppression 8 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:forcePromise.part.0 +} +{ + Suppression 9 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:Putenv + fun:process_Renviron + fun:process_system_Renviron + fun:Rf_initialize_R + fun:main +} +{ + Suppression 10 in calloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:calloc + fun:UnknownInlinedFun + fun:allocate_dtv + fun:_dl_allocate_tls + fun:pthread_create@@GLIBC_2.34 + fun:cli__start_thread + fun:clic_start_thread + fun:R_doDotCall + fun:do_dotcall + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure +} +{ + Suppression 11 in calloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:calloc + fun:UnknownInlinedFun + fun:allocate_dtv + fun:_dl_allocate_tls + fun:pthread_create@@GLIBC_2.34 + fun:blas_thread_init + fun:gotoblas_init + fun:call_init + fun:call_init + fun:_dl_init + obj:/usr/lib64/ld-linux-x86-64.so.2 + obj:* + obj:* + obj:* +} +{ + Suppression 12 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:do_docall +} +{ + Suppression 13 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:do_docall + fun:bcEval_loop +} +{ + Suppression 14 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:UnknownInlinedFun + fun:_dlfo_mappings_segment_allocate + fun:_dl_find_object_update_1 + fun:_dl_find_object_update + fun:dl_open_worker_begin + fun:_dl_catch_exception + fun:dl_open_worker + fun:_dl_catch_exception + fun:_dl_open + fun:dlopen_doit + fun:_dl_catch_exception + fun:_dl_catch_error + fun:_dlerror_run + fun:dlopen@@GLIBC_2.34 +} +{ + Suppression 15 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:Putenv + fun:process_Renviron + fun:process_system_Renviron + fun:Rf_initialize_R + fun:main +} +{ + Suppression 16 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:forcePromise.part.0 +} +{ + Suppression 17 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:Putenv + fun:process_Renviron + fun:process_system_Renviron + fun:Rf_initialize_R + fun:main +} +{ + Suppression 18 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:calloc + fun:UnknownInlinedFun + fun:allocate_dtv + fun:_dl_allocate_tls + fun:pthread_create@@GLIBC_2.34 + fun:cli__start_thread + fun:clic_start_thread + fun:R_doDotCall + fun:do_dotcall + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure +} +{ + Suppression 19 in calloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:calloc + fun:UnknownInlinedFun + fun:allocate_dtv + fun:_dl_allocate_tls + fun:pthread_create@@GLIBC_2.34 + fun:blas_thread_init + fun:gotoblas_init + fun:call_init + fun:call_init + fun:_dl_init + obj:/usr/lib64/ld-linux-x86-64.so.2 + obj:* + obj:* + obj:* +} +{ + Suppression 20 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:do_docall +} +{ + Suppression 21 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure + fun:applyClosure_core + fun:Rf_applyClosure + fun:Rf_eval + fun:do_docall + fun:bcEval_loop +} +{ + Suppression 22 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:UnknownInlinedFun + fun:_dlfo_mappings_segment_allocate + fun:_dl_find_object_update_1 + fun:_dl_find_object_update + fun:dl_open_worker_begin + fun:_dl_catch_exception + fun:dl_open_worker + fun:_dl_catch_exception + fun:_dl_open + fun:dlopen_doit + fun:_dl_catch_exception + fun:_dl_catch_error + fun:_dlerror_run + fun:dlopen@@GLIBC_2.34 +} +{ + Suppression 23 in calloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:calloc + fun:UnknownInlinedFun + fun:allocate_dtv + fun:_dl_allocate_tls + fun:pthread_create@@GLIBC_2.34 + fun:cli__start_thread + fun:clic_start_thread + fun:R_doDotCall + fun:do_dotcall + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:R_execClosure +} +{ + Suppression 24 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:forcePromise.part.0 + fun:forcePromise + fun:Rf_eval + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval +} +{ + Suppression 25 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:forcePromise.part.0 + fun:forcePromise + fun:Rf_eval + fun:bcEval_loop + fun:bcEval + fun:bcEval +} +{ + Suppression 26 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:forcePromise.part.0 + fun:forcePromise + fun:Rf_eval + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval +} +{ + Suppression 27 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:forcePromise.part.0 + fun:forcePromise + fun:Rf_eval + fun:bcEval_loop + fun:bcEval + fun:bcEval +} +{ + Suppression 28 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:forcePromise.part.0 + fun:forcePromise + fun:Rf_eval + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval +} +{ + Suppression 29 in malloc in processx + Memcheck:Leak + match-leak-kinds: possible + fun:malloc + fun:tsearch + fun:__add_to_environ + fun:setenv + fun:do_setenv + fun:bcEval_loop + fun:bcEval + fun:bcEval + fun:Rf_eval + fun:forcePromise.part.0 + fun:forcePromise + fun:Rf_eval + fun:bcEval_loop + fun:bcEval + fun:bcEval +}