1
2#' Mark a process and its (future) child tree
3#'
4#' `ps_mark_tree()` generates a random environment variable name and sets
5#' it in the  current R process. This environment variable will be (by
6#' default) inherited by all child (and grandchild, etc.) processes, and
7#' will help finding these processes, even if and when they are (no longer)
8#' related to the current R process. (I.e. they are not connected in the
9#' process tree.)
10#'
11#' `ps_find_tree()` finds the processes that set the supplied environment
12#' variable and returns them in a list.
13#'
14#' `ps_kill_tree()` finds the processes that set the supplied environment
15#' variable, and kills them (or sends them the specified signal on Unix).
16#'
17#' `with_process_cleanup()` evaluates an R expression, and cleans up all
18#' external processes that were started by the R process while evaluating
19#' the expression. This includes child processes of child processes, etc.,
20#' recursively. It returns a list with entries: `result` is the result of
21#' the expression, `visible` is TRUE if the expression should be printed
22#' to the screen, and `process_cleanup` is a named integer vector of the
23#' cleaned pids, names are the process names.
24#'
25#' If `expr` throws an error, then so does `with_process_cleanup()`, the
26#' same error. Nevertheless processes are still cleaned up.
27#'
28#' @section Note:
29#' Note that `with_process_cleanup()` is problematic if the R process is
30#' multi-threaded and the other threads start subprocesses.
31#' `with_process_cleanup()` cleans up those processes as well, which is
32#' probably not what you want. This is an issue for example in RStudio.
33#' Do not use `with_process_cleanup()`, unless you are sure that the
34#' R process is single-threaded, or the other threads do not start
35#' subprocesses. E.g. using it in package test cases is usually fine,
36#' because RStudio runs these in a separate single-threaded process.
37#'
38#' The same holds for manually running `ps_mark_tree()` and then
39#' `ps_find_tree()` or `ps_kill_tree()`.
40#'
41#' A safe way to use process cleanup is to use the processx package to
42#' start subprocesses, and set the `cleanup_tree = TRUE` in
43#' [processx::run()] or the [processx::process] constructor.
44#'
45#' @return `ps_mark_tree()` returns the name of the environment variable,
46#' which can be used as the `marker` in `ps_kill_tree()`.
47#'
48#' `ps_find_tree()` returns a list of `ps_handle` objects.
49#'
50#' `ps_kill_tree()` returns the pids of the killed processes, in a named
51#' integer vector. The names are the file names of the executables, when
52#' available.
53#'
54#' `with_process_cleanup()` returns the value of the evaluated expression.
55#'
56#' @rdname ps_kill_tree
57#' @export
58
59ps_mark_tree <- function() {
60  id <- get_id()
61  do.call(Sys.setenv, structure(list("YES"), names = id))
62  id
63}
64
65get_id <- function() {
66  paste0(
67    "PS",
68    paste(
69      sample(c(LETTERS, 0:9), 10, replace = TRUE),
70      collapse = ""
71    ),
72    "_",
73    as.integer(Internal(Sys.time()))
74  )
75}
76
77#' @param expr R expression to evaluate in the new context.
78#'
79#' @rdname ps_kill_tree
80#' @export
81
82with_process_cleanup <- function(expr) {
83  id <- ps_mark_tree()
84  stat <- NULL
85  do <- function() {
86    on.exit(stat <<- ps_kill_tree(id), add = TRUE)
87    withVisible(expr)
88  }
89
90  res <- do()
91
92  ret <- list(
93    result = res$value,
94    visible = res$visible,
95    process_cleanup = stat)
96  class(ret) <- "with_process_cleanup"
97  ret
98}
99
100#' @export
101
102print.with_process_cleanup <- function(x, ...) {
103  if (x$visible) print(x$result)
104  if (length(x$process_cleanup)) {
105    cat("!! Cleaned up the following processes:\n")
106    print(x$process_cleanup)
107  } else {
108    cat("-- No leftover processes to clean up.\n")
109  }
110  invisible(x)
111}
112
113
114#' @rdname ps_kill_tree
115#' @export
116
117ps_find_tree <- function(marker) {
118  assert_string(marker)
119  after <- as.numeric(strsplit(marker, "_", fixed = TRUE)[[1]][2])
120
121  pids <- setdiff(ps_pids(), Sys.getpid())
122
123  not_null(lapply(pids, function(p) {
124    tryCatch(
125      .Call(ps__find_if_env, marker, after, p),
126      error = function(e) NULL
127    )
128  }))
129}
130
131#' @param marker String scalar, the name of the environment variable to
132#' use to find the marked processes.
133#' @param sig The signal to send to the marked processes on Unix. On
134#' Windows this argument is ignored currently.
135#'
136#' @rdname ps_kill_tree
137#' @export
138
139ps_kill_tree <- function(marker, sig = signals()$SIGKILL) {
140
141  assert_string(marker)
142
143  after <- as.numeric(strsplit(marker, "_", fixed = TRUE)[[1]][2])
144
145  pids <- setdiff(ps_pids(), Sys.getpid())
146
147  ret <- lapply(pids, function(p) {
148    tryCatch(
149      .Call(ps__kill_if_env, marker, after, p, sig),
150      error = function(e) e
151    )
152  })
153
154  gone <- map_lgl(ret, function(x) is.character(x))
155  structure(pids[gone], names = unlist(ret[gone]))
156}
157