test-kill-tree.R
In ps: List, Query, Manipulate System Processes

test_that("ps_mark_tree", {
  id <- ps_mark_tree()
  on.exit(Sys.unsetenv(id), add = TRUE)
  expect_true(is.character(id))
  expect_true(length(id) == 1)
  expect_false(is.na(id))
  expect_false(Sys.getenv(id) == "")
})

test_that("kill_tree",  {
  skip_on_cran()
  skip_in_rstudio()

  res <- ps_kill_tree(get_id())
  expect_equal(length(res), 0)
  expect_true(is.integer(res))

  ## Child processes
  id <- ps_mark_tree()
  on.exit(Sys.unsetenv(id), add = TRUE)
  dir.create(tmp <- tempfile())
  on.exit(unlink(tmp, recursive = TRUE), add = TRUE)
  p <- lapply(1:5, function(x) {
    out <- file.path(tmp, basename(tempfile()))
    processx::process$new(
      px(),
      c("outln", "ready", "sleep", "10"),
      stdout = out
    )
  })
  on.exit(lapply(p, function(x) x$kill()), add = TRUE)

  timeout <- Sys.time() + 5
  while (sum(file_size(dir(tmp, full.names = TRUE)) > 0) < 5 &&
         Sys.time() < timeout) Sys.sleep(0.1)

  expect_true(Sys.time() < timeout)

  res <- ps_kill_tree(id)
  res <- res[names(res) %in% c("px", "px.exe")]
  expect_equal(length(res), 5)
  expect_equal(
    sort(as.integer(res)),
    sort(map_int(p, function(x) x$get_pid())))

  ## We need to wait a bit here, potentially, because the process
  ## might be a zombie, which is technically alive.
  now <- Sys.time()
  timeout <- now + 5
  while (any(map_lgl(p, function(pp) pp$is_alive())) &&
         Sys.time() < timeout) Sys.sleep(0.1)

  expect_true(Sys.time() < timeout)
  lapply(p, function(pp) expect_false(pp$is_alive()))
})

test_that("kill_tree, grandchild", {
  skip_on_cran()
  skip_in_rstudio()

  id <- ps_mark_tree()
  on.exit(Sys.unsetenv(id), add = TRUE)

  dir.create(tmp <- tempfile())
  on.exit(unlink(tmp, recursive = TRUE), add = TRUE)

  N <- 3
  p <- lapply(1:N, function(x) {
    callr::r_bg(
      function(d) {
        cat("OK\n", file = file.path(d, Sys.getpid()))
        # We ignore error from the grandchild, in case it gets
        # killed first. The child still runs on, because of the sleep.
        try(callr::r(
          function(d) {
            cat("OK\n", file = file.path(d, Sys.getpid()))
            Sys.sleep(5)
          },
          args = list(d = d)))
        Sys.sleep(5)
      },
      args = list(d = tmp),
      cleanup = FALSE
    )
  })
  on.exit(lapply(p, function(x) x$kill()), add = TRUE)

  timeout <- Sys.time() + 10
  while (length(dir(tmp)) < 2*N && Sys.time() < timeout) Sys.sleep(0.1)

  expect_true(Sys.time() < timeout)

  res <- ps_kill_tree(id)

  ## Older processx versions do not close the connections on kill,
  ## so the cleanup reporter picks them up
  lapply(p, function(pp) {
    close(pp$get_output_connection())
    close(pp$get_error_connection())
  })

  res <- res[names(res) %in% c("R", "Rterm.exe")]

  ## We might miss some processes, because grandchildren can be
  ## are in the same job object and they are cleaned up automatically.
  ## To fix the, processx would need an option _not_ to create a job
  ## object.
  expect_true(length(res) <= N * 2)
  expect_true(all(names(res) %in% c("R", "Rterm.exe")))
  cpids <- map_int(p, function(x) x$get_pid())
  expect_true(all(cpids %in% res))
  ccpids <- as.integer(dir(tmp))

  ## Again, the opposite might not be true, because we might miss some
  ## grandchildren.
  expect_true(all(res %in% ccpids))

  ## Nevertheless none of them should be alive.
  ## (Taking the risk of pid reuse here...)
  timeout <- Sys.time() + 5
  while (any(ccpids %in% ps_pids()) && Sys.time() < timeout) Sys.sleep(0.1)
  expect_true(Sys.time() < timeout)
})

test_that("kill_tree, orphaned grandchild", {
  skip_on_cran()
  skip_in_rstudio()

  id <- ps_mark_tree()
  on.exit(Sys.unsetenv(id), add = TRUE)

  dir.create(tmp <- tempfile())
  on.exit(unlink(tmp, recursive = TRUE), add = TRUE)

  cmdline <- paste(px(), "sleep 5")

  N <- 3
  lapply(1:N, function(x) {
    system2(px(), c("outln", "ok","sleep", "5"),
            stdout = file.path(tmp, x), wait = FALSE)
  })

  timeout <- Sys.time() + 10
  while (sum(file_size(dir(tmp, full.names = TRUE)) > 0) < N &&
         Sys.time() < timeout) Sys.sleep(0.1)

  res <- ps_kill_tree(id)
  res <- res[names(res) %in% c("px", "px.exe")]
  expect_equal(length(res), N)
  expect_true(all(names(res) %in% c("px", "px.exe")))
})

test_that("with_process_cleanup", {
  skip_on_cran()
  skip_in_rstudio()

  p <- NULL
  with_process_cleanup({
    p <- lapply(1:3, function(x) {
      processx::process$new(px(), c("sleep", "10"))
    })
    expect_equal(length(p), 3)
    lapply(p, function(pp) expect_true(pp$is_alive()))
  })

  expect_equal(length(p), 3)

  ## We need to wait a bit here, potentially, because the process
  ## might be a zombie, which is technically alive.
  now <- Sys.time()
  timeout <- now + 5
  while (any(map_lgl(p, function(pp) pp$is_alive())) &&
         Sys.time() < timeout) Sys.sleep(0.05)

  lapply(p, function(pp) expect_false(pp$is_alive()))
  rm(p)
  gc()
})

test_that("find_tree",  {
  skip_on_cran()
  skip_in_rstudio()
  skip_if_no_processx()

  res <- ps_find_tree(get_id())
  expect_equal(length(res), 0)
  expect_true(is.list(res))

  ## Child processes
  id <- ps_mark_tree()
  on.exit(Sys.unsetenv(id), add = TRUE)
  p <- lapply(1:5, function(x) processx::process$new(px(), c("sleep", "10")))
  on.exit(lapply(p, function(x) x$kill()), add = TRUE)
  res <- ps_find_tree(id)
  names <- not_null(lapply(res, function(p) fallback(ps_name(p), NULL)))
  res <- res[names %in% c("px", "px.exe")]
  expect_equal(length(res), 5)
  expect_equal(
    sort(map_int(res, ps_pid)),
    sort(map_int(p, function(x) x$get_pid())))

  lapply(p, function(x) x$kill())
})

test_that("find_tree, grandchild", {
  skip_on_cran()
  skip_in_rstudio()

  id <- ps_mark_tree()
  on.exit(Sys.unsetenv(id), add = TRUE)

  dir.create(tmp <- tempfile())
  on.exit(unlink(tmp, recursive = TRUE), add = TRUE)

  N <- 3
  p <- lapply(1:N, function(x) {
    callr::r_bg(
      function(d) {
        callr::r(
          function(d) {
            cat("OK\n", file = file.path(d, Sys.getpid()))
            Sys.sleep(5)
          },
          args = list(d = d))
      },
      args = list(d = tmp))
  })
  on.exit(lapply(p, function(x) x$kill()), add = TRUE)
  on.exit(ps_kill_tree(id), add = TRUE)

  timeout <- Sys.time() + 10
  while (length(dir(tmp)) < N && Sys.time() < timeout) Sys.sleep(0.1)

  res <- ps_find_tree(id)
  names <- not_null(lapply(res, function(p) fallback(ps_name(p), NULL)))
  res <- res[names %in% c("R", "Rterm.exe")]
  expect_equal(length(res), N * 2)
  cpids <- map_int(p, function(x) x$get_pid())
  res_pids <- map_int(res, ps_pid)
  expect_true(all(cpids %in% res_pids))
  ccpids <- as.integer(dir(tmp))
  expect_true(all(ccpids %in% res_pids))

  ## Older processx versions do not close the connections on kill,
  ## so the cleanup reporter picks them up
  lapply(p, function(pp) {
    pp$kill()
    close(pp$get_output_connection())
    close(pp$get_error_connection())
  })
})

test_that("find_tree, orphaned grandchild", {
  skip_on_cran()
  skip_in_rstudio()

  id <- ps_mark_tree()
  on.exit(Sys.unsetenv(id), add = TRUE)

  dir.create(tmp <- tempfile())
  on.exit(unlink(tmp, recursive = TRUE), add = TRUE)

  cmdline <- paste(px(), "sleep 5")

  N <- 3
  lapply(1:N, function(x) {
    system2(px(), c("outln", "ok","sleep", "5"),
            stdout = file.path(tmp, x), wait = FALSE)
  })
  on.exit(ps_kill_tree(id), add = TRUE)

  timeout <- Sys.time() + 10
  while (sum(file_size(dir(tmp, full.names = TRUE)) > 0) < N &&
         Sys.time() < timeout) Sys.sleep(0.1)

  res <- ps_find_tree(id)
  names <- not_null(lapply(res, function(p) fallback(ps_name(p), NULL)))
  res <- res[names %in% c("px", "px.exe")]
  expect_equal(length(res), N)
})