Allow killing processes with SIGTERM

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: processx
 Title: Execute and Control System Processes
-Version: 3.8.0.9000
+Version: 3.8.0.9002
 Authors@R: c(
     person("Gábor", "Csárdi", , "[email protected]", role = c("aut", "cre", "cph"),
            comment = c(ORCID = "0000-0001-7098-9676")),
@@ -24,18 +24,21 @@ Imports:
     R6,
     utils
 Suggests:
-    callr (>= 3.7.0),
+    callr (>= 3.7.3),
     cli (>= 3.3.0),
     codetools,
     covr,
     curl,
     debugme,
     parallel,
+    pkgload,
     rlang (>= 1.0.2),
     testthat (>= 3.0.0),
     withr
+Remotes:
+    r-lib/callr@fix-client-so-name
 Encoding: UTF-8
-RoxygenNote: 7.2.0
+RoxygenNote: 7.2.3
 Roxygen: list(markdown = TRUE)
 Config/testthat/edition: 3
 Config/Needs/website: tidyverse/tidytemplate

NEWS.md

@@ -1,5 +1,14 @@
 # processx (development version)
 
+* The `kill()` and `kill_tree()` methods gain a `signal` argument.
+  This is useful to gracefully terminate processes, e.g. with
+  `SIGTERM`.
+
+* On Unixes, R processes created by callr now feature a `SIGTERM`
+  cleanup handler that cleans up the temporary directory before
+  shutting down. To disable it, set the
+  `PROCESSX_NO_R_SIGTERM_CLEANUP` envvar to a non-empty value.
+
 # processx 3.8.0
 
 * processx error stacks are better now. They have ANSI hyperlinks for

R/assertions.R

@@ -27,12 +27,20 @@ on_failure(is_flag) <- function(call, env) {
   paste0(deparse(call$x), " is not a flag (length 1 logical)")
 }
 
+is_integer_scalar <- function(x) {
+  is.integer(x) && length(x) == 1 && !is.na(x) && round(x) == x
+}
+
+on_failure(is_integer_scalar) <- function(call, env) {
+  paste0(deparse(call$x), " is not a length 1 integer")
+}
+
 is_integerish_scalar <- function(x) {
   is.numeric(x) && length(x) == 1 && !is.na(x) && round(x) == x
 }
 
 on_failure(is_integerish_scalar) <- function(call, env) {
-  paste0(deparse(call$x), " is not a length 1 integer")
+  paste0(deparse(call$x), " is not a length 1 round number")
 }
 
 is_pid <- function(x) {

R/initialize.R

@@ -25,10 +25,10 @@
 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) {
+                               cleanup_tree, cleanup_signal, wd, echo_cmd,
+                               supervise, windows_verbatim_args,
+                               windows_hide_window, windows_detached_process,
+                               encoding, post_process) {
 
   "!DEBUG process_initialize `command`"
 
@@ -45,6 +45,7 @@ process_initialize <- function(self, private, command, args,
     is.null(env) || is_env_vector(env),
     is_flag(cleanup),
     is_flag(cleanup_tree),
+    is_integer_scalar(cleanup_signal),
     is_string_or_null(wd),
     is_flag(echo_cmd),
     is_flag(windows_verbatim_args),
@@ -99,6 +100,7 @@ process_initialize <- function(self, private, command, args,
   private$args <- args
   private$cleanup <- cleanup
   private$cleanup_tree <- cleanup_tree
+  private$cleanup_signal <- cleanup_signal
   private$wd <- wd
   private$pstdin <- stdin
   private$pstdout <- stdout
@@ -139,8 +141,8 @@ process_initialize <- function(self, private, command, args,
     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,
-    paste0("PROCESSX_", private$tree_id, "=YES")
+    windows_detached_process, private, cleanup, cleanup_signal,
+    wd, encoding, paste0("PROCESSX_", private$tree_id, "=YES")
   )
 
   ## We try the query the start time according to the OS, because we can

R/process.R

@@ -184,6 +184,9 @@ process <- R6::R6Class(
     #'   object is garbage collected.
     #' @param cleanup_tree Whether to kill the process and its child
     #'   process tree when the `process` object is garbage collected.
+    #' @param cleanup_signal Which signal to use in case of cleanup.
+    #'   Defaults to `SIGKILL` but can be set to `tools::SIGTERM`.
+    #'   Has no effect on Windows.
     #' @param wd Working directory of the process. It must exist.
     #'   If `NULL`, then the current working directory is used.
     #' @param echo_cmd Whether to print the command to the screen before
@@ -210,19 +213,20 @@ process <- R6::R6Class(
     #'   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)
+                          stdin = NULL, stdout = NULL, stderr = NULL, pty = FALSE,
+                          pty_options = list(), connections = list(), poll_connection = NULL,
+                          env = NULL, cleanup = TRUE, cleanup_tree = FALSE,
+                          cleanup_signal = ps::signals()$SIGKILL, 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),
+        stdout, stderr, pty, pty_options, connections,
+        poll_connection, env, cleanup, cleanup_tree,
+        cleanup_signal, wd, echo_cmd, supervise,
+        windows_verbatim_args, windows_hide_window,
+        windows_detached_process, encoding, post_process),
 
     #' @description
     #' Cleanup method that is called when the `process` object is garbage
@@ -231,7 +235,7 @@ process <- R6::R6Class(
 
     finalize = function() {
       if (!is.null(private$tree_id) && private$cleanup_tree &&
-          ps::ps_is_supported()) self$kill_tree()
+            ps::ps_is_supported()) self$kill_tree(signal = private$cleanup_signal)
     },
 
     #' @description
@@ -240,9 +244,11 @@ process <- R6::R6Class(
     #' or job object (on Windows). It returns `TRUE` if the process
     #' was terminated, and `FALSE` if it was not (because it was
     #' already finished/dead when `processx` tried to terminate it).
+    #' @param signal An integer scalar, the id of the signal to send to
+    #'   the process. See [tools::pskill()] for the list of signals.
 
-    kill = function(grace = 0.1, close_connections = TRUE)
-      process_kill(self, private, grace, close_connections),
+    kill = function(grace = 0.1, close_connections = TRUE, signal = ps::signals()$SIGKILL)
+      process_kill(self, private, grace, close_connections, signal),
 
     #' @description
     #' Process tree cleanup. It terminates the process
@@ -256,9 +262,11 @@ process <- R6::R6Class(
     #' `$kill_tree()` returns a named integer vector of the process ids that
     #' were killed, the names are the names of the processes (e.g. `"sleep"`,
     #' `"notepad.exe"`, `"Rterm.exe"`, etc.).
+    #' @param signal An integer scalar, the id of the signal to send to
+    #'   the process. See [tools::pskill()] for the list of signals.
 
-    kill_tree = function(grace = 0.1, close_connections = TRUE)
-      process_kill_tree(self, private, grace, close_connections),
+    kill_tree = function(grace = 0.1, close_connections = TRUE, signal = ps::signals()$SIGKILL)
+      process_kill_tree(self, private, grace, close_connections, signal),
 
     #' @description
     #' Send a signal to the process. On Windows only the
@@ -650,6 +658,7 @@ process <- R6::R6Class(
     args = NULL,          # Save 'args' argument here
     cleanup = NULL,       # cleanup argument
     cleanup_tree = NULL,  # cleanup_tree argument
+    cleanup_signal = NULL,# cleanup_signal argument
     stdin = NULL,         # stdin argument or stream
     stdout = NULL,        # stdout argument or stream
     stderr = NULL,        # stderr argument or stream
@@ -735,22 +744,25 @@ process_interrupt <- function(self, private) {
   }
 }
 
-process_kill <- function(self, private, grace, close_connections) {
+process_kill <- function(self, private, grace, close_connections, signal) {
   "!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())
+  assert_that(is_integer_scalar(signal))
+
+  ret <- chain_clean_call(c_processx_kill, private$status, as.numeric(grace),
+                      private$get_short_name(), signal)
   if (close_connections) private$close_connections()
   ret
 }
 
-process_kill_tree <- function(self, private, grace, close_connections) {
-  "!DEBUG process_kill_tree '`private$get_short_name()`', pid `self$get_pid()`"
+process_kill_tree <- function(self, private, grace, close_connections, signal) {
+  "!DEBUG process_kill_tree '`private$get_short_name()`', pid `self$get_pid()`, signal `signal`"
   if (!ps::ps_is_supported()) {
     throw(new_not_implemented_error(
       "kill_tree is not supported on this platform"))
   }
+  assert_that(is_integer_scalar(signal))
 
-  ret <- get("ps_kill_tree", asNamespace("ps"))(private$tree_id)
+  ret <- get("ps_kill_tree", asNamespace("ps"))(private$tree_id, sig = signal)
   if (close_connections) private$close_connections()
   ret
 }

R/run.R

@@ -123,6 +123,9 @@
 #'   both streams in UTF-8 currently.
 #' @param cleanup_tree Whether to clean up the child process tree after
 #'   the process has finished.
+#' @param cleanup_signal Signal to cleanup the process (and its
+#'   children if `cleanup_tree` is `TRUE`). Defaults to `SIGKILL`. On
+#'   Windows, only `SIGTERM` and `SIGKILL` are supported.
 #' @param ... Extra arguments are passed to `process$new()`, see
 #'   [process]. Note that you cannot pass `stout` or `stderr` here,
 #'   because they are used internally by `run()`. You can use the
@@ -162,7 +165,8 @@ run <- function(
   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, ...) {
+  encoding = "", cleanup_tree = FALSE,
+  cleanup_signal = ps::signals()$SIGKILL, ...) {
 
   assert_that(is_flag(error_on_status))
   assert_that(is_time_interval(timeout))
@@ -176,6 +180,7 @@ run <- function(
   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))
+  assert_that(is_integer_scalar(cleanup_signal))
   assert_that(is_flag(stderr_to_stdout))
   ## The rest is checked by process$new()
   "!DEBUG run() Checked arguments"
@@ -195,9 +200,9 @@ run <- function(
 
   ## We make sure that the process is eliminated
   if (cleanup_tree) {
-    on.exit(pr$kill_tree(), add = TRUE)
+    defer(pr$kill_tree(signal = cleanup_signal))
   } else {
-    on.exit(pr$kill(), add = TRUE)
+    defer(pr$kill(signal = cleanup_signal))
   }
 
   ## If echo, then we need to create our own callbacks.

R/utils.R

@@ -295,3 +295,29 @@ ends_with <- function(x, post) {
   l <- nchar(post)
   substr(x, nchar(x) - l + 1, nchar(x)) == post
 }
+
+defer <- function(expr, frame = parent.frame(), after = FALSE) {
+  thunk <- as.call(list(function() expr))
+  do.call(on.exit, list(thunk, add = TRUE, after = after), envir = frame)
+}
+
+rimraf <- function(...) {
+  x <- file.path(...)
+  if ("~" %in% x) stop("Cowardly refusing to delete `~`")
+  unlink(x, recursive = TRUE, force = TRUE)
+}
+
+get_test_lib <- function(lib) {
+  if (pkgload::is_dev_package("processx")) {
+    path <- "src"
+  } else {
+    path <- paste0('libs', .Platform$r_arch)
+  }
+
+  system.file(
+    package = "processx",
+    path,
+    "test",
+    paste0(lib, .Platform$dynlib.ext)
+  )
+}