ps/0000755000176200001440000000000014755211512010677 5ustar liggesusersps/tests/0000755000176200001440000000000014670523103012037 5ustar liggesusersps/tests/testthat/0000755000176200001440000000000014755211512013701 5ustar liggesusersps/tests/testthat/test-finished.R0000644000176200001440000000274714665030515016606 0ustar liggesusers test_that("process already finished", { skip_on_cran() px <- processx::process$new(px(), c("sleep", "5")) on.exit(px$kill(), add = TRUE) pid <- px$get_pid() p <- ps_handle(pid) ct <- ps_create_time(p) px$kill() expect_false(px$is_alive()) if (ps_os_type()[["POSIX"]]) { expect_equal(px$get_exit_status(), -9) } expect_match(format(p), format_regexp()) expect_output(print(p), format_regexp()) expect_equal(ps_pid(p), pid) if (has_processx()) expect_equal(ps_create_time(p), ct) expect_false(ps_is_running(p)) chk <- function(expr) { err <- tryCatch(expr, error = function(e) e) expect_s3_class(err, "no_such_process") expect_s3_class(err, "ps_error") expect_equal(err$pid, pid) } ## All these error out with "no_such_process" chk(ps_status(p)) chk(ps_ppid(p)) chk(ps_parent(p)) chk(ps_name(p)) if (ps_os_type()[["POSIX"]]) chk(ps_uids(p)) chk(ps_username(p)) if (ps_os_type()[["POSIX"]]) chk(ps_gids(p)) chk(ps_terminal(p)) if (ps_os_type()[["POSIX"]]) chk(ps_send_signal(p, signals()$SIGINT)) chk(ps_suspend(p)) chk(ps_resume(p)) if (ps_os_type()[["POSIX"]]) chk(ps_terminate(p)) ## kill will just work if the process has finished already expect_equal(ps_kill(p), "dead") chk(ps_exe(p)) chk(ps_cmdline(p)) chk(ps_environ(p)) chk(ps_cwd(p)) chk(ps_memory_info(p)) chk(ps_cpu_times(p)) chk(ps_num_threads(p)) chk(ps_children(p)) chk(ps_num_fds(p)) chk(ps_open_files(p)) chk(ps_connections(p)) }) ps/tests/testthat/test-utils.R0000644000176200001440000000144714663700234016151 0ustar liggesusers test_that("errno", { err <- errno() expect_true(is.data.frame(err)) expect_true("EINVAL" %in% err$name) expect_true("EBADF" %in% err$name) }) test_that("str_strip", { tcs <- list( list("", ""), list(" ", ""), list("a ", "a"), list(" a", "a"), list(" a ", "a"), list(" a ", "a"), list(character(), character()), list(c("", NA, "a "), c("", NA, "a")), list("\ta\n", "a") ) for (tc in tcs) { expect_identical(str_strip(tc[[1]]), tc[[2]]) } }) test_that("NA_time", { nat <- NA_time() expect_s3_class(nat, "POSIXct") expect_true(length(nat) == 1 && is.na(nat)) }) test_that("read_lines", { tmp <- tempfile() cat("foo\nbar\nfoobar", file = tmp) expect_silent(l <- read_lines(tmp)) expect_equal(l, c("foo", "bar", "foobar")) }) ps/tests/testthat/test-cleanup-reporter.R0000644000176200001440000002644714665030515020307 0ustar liggesusers test_that("unit: test, mode: cleanup-fail", { out <- list() on.exit(if (!is.null(out$p)) out$p$kill(), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new(proc_unit = "test"), { test_that("foobar", { out$p <<- processx::process$new(px(), c("sleep", "5")) out$running <<- out$p$is_alive() }) } ), "did not clean up processes" ) expect_true(out$running) deadline <- Sys.time() + 2 while (out$p$is_alive() && Sys.time() < deadline) Sys.sleep(0.05) expect_true(Sys.time() < deadline) expect_false(out$p$is_alive()) }) test_that("unit: test, multiple processes", { out <- list() on.exit(if (!is.null(out$p1)) out$p1$kill(), add = TRUE) on.exit(if (!is.null(out$p2)) out$p2$kill(), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new(proc_unit = "test"), { test_that("foobar", { out$p1 <<- processx::process$new(px(), c("sleep", "5")) out$p2 <<- processx::process$new(px(), c("sleep", "5")) out$running <<- out$p1$is_alive() && out$p2$is_alive() }) } ), "px.*px" ) expect_true(out$running) expect_false(out$p1$is_alive()) expect_false(out$p2$is_alive()) }) test_that("on.exit() works", { out <- list() on.exit(if (!is.null(out$p)) out$p$kill(), add = TRUE) expect_success( with_reporter( CleanupReporter(testthat::SilentReporter)$new(proc_unit = "test"), { test_that("foobar", { out$p <<- processx::process$new(px(), c("sleep", "5")) on.exit(out$p$kill(), add = TRUE) out$running <<- out$p$is_alive() }) } ) ) expect_true(out$running) expect_false(out$p$is_alive()) }) test_that("only report", { out <- list() on.exit(if (!is.null(out$p)) out$p$kill(), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_unit = "test", proc_cleanup = FALSE, proc_fail = TRUE), { test_that("foobar", { out$p <<- processx::process$new(px(), c("sleep", "5")) out$running <<- out$p$is_alive() }) } ), "did not clean up processes" ) expect_true(out$running) expect_true(out$p$is_alive()) out$p$kill() }) test_that("only kill", { out <- list() on.exit(if (!is.null(out$p)) out$p$kill(), add = TRUE) with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_unit = "test", proc_cleanup = TRUE, proc_fail = FALSE, conn_fail = FALSE), { test_that("foobar", { out$p <<- processx::process$new(px(), c("sleep", "5")) out$running <<- out$p$is_alive() }) ## It must be killed by now test_that("foobar2", { deadline <- Sys.time() + 3 while (out$p$is_alive() && Sys.time() < deadline) Sys.sleep(0.05) out$running2 <<- out$p$is_alive() }) } ) expect_true(out$running) expect_false(out$running2) expect_false(out$p$is_alive()) }) test_that("unit: testsuite", { out <- list() on.exit(if (!is.null(out$p)) out$p$kill(), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_unit = "testsuite", rconn_fail = FALSE, file_fail = FALSE, conn_fail = FALSE), { test_that("foobar", { out$p <<- processx::process$new(px(), c("sleep", "5")) out$running <<- out$p$is_alive() }) test_that("foobar2", { ## Still alive out$running2 <<- out$p$is_alive() }) } ), "did not clean up processes" ) expect_true(out$running) expect_true(out$running2) deadline <- Sys.time() + 3 while (out$p$is_alive() && Sys.time() < deadline) Sys.sleep(0.05) expect_false(out$p$is_alive()) }) test_that("R connection cleanup, test, close, fail", { out <- list() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new(proc_fail = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "w") out$open <<- isOpen(out$conn) }) } ), "did not close R connections" ) expect_true(out$open) expect_error(isOpen(out$conn)) }) test_that("R connection cleanup, test, do not close, fail", { out <- list() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_fail = FALSE, rconn_cleanup = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "w") out$open <<- isOpen(out$conn) }) } ), "did not close R connections" ) expect_true(out$open) expect_true(isOpen(out$conn)) expect_silent(close(out$conn)) }) test_that("R connection cleanup, test, close, do not fail", { out <- list() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_fail = FALSE, rconn_fail = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "w") out$open <<- isOpen(out$conn) }) } ) expect_true(out$open) expect_error(isOpen(out$conn)) }) test_that("R connections, unit: testsuite", { out <- list() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( rconn_unit = "testsuite", proc_fail = FALSE, file_fail = FALSE, conn_fail = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "w") out$open <<- isOpen(out$conn) }) test_that("foobar2", { ## Still alive out$open2 <<- isOpen(out$conn) }) } ), "did not close R connections" ) expect_true(out$open) expect_true(out$open2) expect_error(isOpen(out$conn)) }) test_that("connections already open are ignored", { tmp2 <- tempfile() on.exit(unlink(tmp2), add = TRUE) conn <- file(tmp2, open = "w") on.exit(try(close(conn), silent = TRUE), add = TRUE) out <- list() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_success( with_reporter( CleanupReporter(testthat::SilentReporter)$new(proc_fail = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "w") out$open <<- isOpen(out$conn) close(out$conn) }) } ) ) expect_error(isOpen(out$conn)) expect_true(isOpen(conn)) expect_silent(close(conn)) }) test_that("File cleanup, test, fail", { out <- list() tmp <- tempfile() cat("data\ndata2\n", file = tmp) on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_fail = FALSE, rconn_cleanup = FALSE, rconn_fail = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "r") out$open <<- isOpen(out$conn) }) } ), "did not close open files" ) expect_true(out$open) expect_true(isOpen(out$conn)) close(out$conn) }) test_that("File cleanup, unit: testsuite", { out <- list() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( file_unit = "testsuite", proc_fail = FALSE, rconn_fail = FALSE, rconn_cleanup = FALSE, conn_fail = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "w") out$open <<- isOpen(out$conn) }) test_that("foobar2", { ## Still alive out$open2 <<- isOpen(out$conn) }) } ), "did not close open files" ) expect_true(out$open) expect_true(out$open2) expect_true(isOpen(out$conn)) close(out$conn) }) test_that("files already open are ignored", { tmp2 <- tempfile() on.exit(unlink(tmp2), add = TRUE) conn <- file(tmp2, open = "w") on.exit(try(close(conn), silent = TRUE), add = TRUE) out <- list() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_success( with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_fail = FALSE, rconn_fail = FALSE, rconn_cleanup = FALSE), { test_that("foobar", { out$conn <<- file(tmp, open = "w") out$open <<- isOpen(out$conn) close(out$conn) }) } ) ) expect_error(isOpen(out$conn)) expect_true(isOpen(conn)) expect_silent(close(conn)) }) conn <- curl::curl(httpbin$url(), open = "r") close(conn) test_that("Network cleanup, test, fail", { skip_on_cran() out <- list() on.exit({ try(close(out$conn), silent = TRUE) }, add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_fail = FALSE, rconn_cleanup = FALSE, rconn_fail = FALSE, file_fail = FALSE), { test_that("foobar", { out$conn <<- curl::curl(httpbin$url("/drip"), open = "r") out$open <<- isOpen(out$conn) }) } ), "did not close network" ) expect_true(out$open) expect_true(isOpen(out$conn)) close(out$conn) }) test_that("Network cleanup, unit: testsuite", { skip_on_cran() out <- list() on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_failure( with_reporter( CleanupReporter(testthat::SilentReporter)$new( conn_unit = "testsuite", proc_fail = FALSE, rconn_fail = FALSE, rconn_cleanup = FALSE, file_fail = FALSE), { test_that("foobar", { out$conn <<- curl::curl(httpbin$url("/drip"), open = "r") out$open <<- isOpen(out$conn) }) test_that("foobar2", { ## Still alive out$open2 <<- isOpen(out$conn) }) } ), "did not close network connections" ) expect_true(out$open) expect_true(out$open2) expect_true(isOpen(out$conn)) close(out$conn) }) test_that("Network connections already open are ignored", { skip_on_cran() conn <- curl::curl(httpbin$url(), open = "r") on.exit(try(close(conn), silent = TRUE), add = TRUE) out <- list() on.exit(try(close(out$conn), silent = TRUE), add = TRUE) expect_success( with_reporter( CleanupReporter(testthat::SilentReporter)$new( proc_fail = FALSE, rconn_fail = FALSE, rconn_cleanup = FALSE), { test_that("foobar", { out$conn <<- curl::curl(httpbin$url(), open = "r") out$open <<- isOpen(out$conn) close(out$conn) }) } ) ) expect_error(isOpen(out$conn)) expect_true(isOpen(conn)) expect_silent(close(conn)) }) # https://github.com/r-lib/ps/issues/163 test_that("errors still cause a failure", { rep <- CleanupReporter(testthat::SilentReporter)$new() expect_error( test_dir( reporter = rep, test_path("fixtures/cleanup-error"), stop_on_failure = TRUE ) ) }) ps/tests/testthat/test-kill-tree.R0000644000176200001440000001707314675261573016716 0ustar liggesusers 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) }) 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) }) ps/tests/testthat/fixtures/0000755000176200001440000000000014665030515015554 5ustar liggesusersps/tests/testthat/fixtures/cleanup-error/0000755000176200001440000000000014755124736020343 5ustar liggesusersps/tests/testthat/fixtures/cleanup-error/test-cleanup-error.R0000644000176200001440000000014714665030515024212 0ustar liggesusers# https://github.com/r-lib/ps/issues/163 test_that("errors still cause a failure", { stop("oops") }) ps/tests/testthat/helpers.R0000644000176200001440000000572214755124671015505 0ustar liggesusers format_regexp <- function() { " PID=[0-9]+, NAME=.*, AT=" } parse_ps <- function(args) { out <- processx::run("ps", args)$stdout sub(" *$", "", strsplit(out, "\n")[[1]][[2]]) } parse_time <- function(x) { x <- utils::tail(c(0, 0, 0, as.numeric(strsplit(x, ":")[[1]])), 3) x[1] * 60 * 60 + x[2] * 60 + x[3] } wait_for_status <- function(ps, status, timeout = 5) { limit <- Sys.time() + timeout while (ps_status(ps) != status && Sys.time() < limit) Sys.sleep(0.05) } px <- function() get_tool("px") skip_in_rstudio <- function() { if (Sys.getenv("RSTUDIO") != "") skip("Cannot test in RStudio") } has_processx <- function() { requireNamespace("processx", quietly = TRUE) && package_version(getNamespaceVersion("processx")) >= "3.1.0.9005" } skip_if_no_processx <- function() { if (!has_processx()) skip("Needs processx >= 3.1.0.9005 to run") } skip_without_program <- function(prog) { if (Sys.which(prog) == "") skip(paste(prog, "is not available")) } have_ipv6_support <- function() { ps_os_type()[["WINDOWS"]] || !is.null(ps_env$constants$address_families$AF_INET6) } skip_without_ipv6 <- function() { if (!have_ipv6_support()) skip("Needs IPv6") } ipv6_url <- function() { paste0("https://", ipv6_host()) } ipv6_host <- function() { "ipv6.test-ipv6.com" } have_ipv6_connection <- local({ ok <- NULL myurl <- NULL function(url = ipv6_url()) { if (is.null(ok) || myurl != url) { myurl <<- url opt <- options(warn = 2) on.exit(options(opt), add = TRUE) tryCatch({ cx <- curl::curl(url) open(cx) ok <<- TRUE }, error = function(x) ok <<- FALSE, finally = close(cx)) } ok } }) skip_without_ipv6_connection <- function() { if (!have_ipv6_connection()) skip("Needs working IPv6 connection") } wait_for_string <- function(proc, string, timeout) { deadline <- Sys.time() + as.difftime(timeout / 1000, units = "secs") str <- "" repeat { left <- max(as.double(deadline - Sys.time(), units = "secs"), 0) pr <- processx::poll(list(proc), as.integer(left * 1000)) str <- paste(str, proc$read_error()) if (grepl(string, str)) return() if (proc$has_output_connection()) read_output() if (deadline < Sys.time()) stop("Cannot start proces") if (!proc$is_alive()) stop("Cannot start process") } } ## This is not perfect, e.g. we don't check that the numbers are <255, ## but will do for our purposes is_ipv4_address <- function(x) { grepl("^[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+$", x) } cleanup_process <- function(p) { tryCatch(close(p$get_input_connection()), error = function(x) x) tryCatch(close(p$get_output_connection()), error = function(x) x) tryCatch(close(p$get_error_connection()), error = function(x) x) tryCatch(close(p$get_poll_connection()), error = function(x) x) tryCatch(p$kill(), error = function(x) x) } httpbin <- webfakes::new_app_process( webfakes::httpbin_app(), opts = webfakes::server_opts(num_threads = 6) ) ps/tests/testthat/test-wait.R0000644000176200001440000000352414665030515015753 0ustar liggesuserstest_that("single process", { skip_on_cran() p <- processx::process$new(px(), c("sleep", "600")) on.exit(p$kill(), add = TRUE) ph <- ps_handle(p$get_pid()) expect_false(ps_wait(ph, 0)) expect_false(ps_wait(list(ph), 0)) tic <- Sys.time() expect_false(ps_wait(ph, 100)) toc <- Sys.time() expect_true(toc - tic >= as.difftime(0.1, units = "secs")) p$kill() tic <- Sys.time() expect_true(ps_wait(ph, 1000)) toc <- Sys.time() expect_true(toc - tic < as.difftime(1, units = "secs")) }) test_that("multiple processes", { skip_on_cran() p1 <- processx::process$new(px(), c("sleep", "600")) on.exit(p1$kill(), add = TRUE) ph1 <- ps_handle(p1$get_pid()) p2 <- processx::process$new(px(), c("sleep", "600")) on.exit(p2$kill(), add = TRUE) ph2 <- ps_handle(p2$get_pid()) p3 <- processx::process$new(px(), c("sleep", "600")) on.exit(p3$kill(), add = TRUE) ph3 <- ps_handle(p3$get_pid()) expect_equal(ps_wait(list(ph1, ph2, ph3), 0), c(FALSE, FALSE, FALSE)) expect_equal(ps_wait(list(ph1, ph2, ph3), 100), c(FALSE, FALSE, FALSE)) p1$kill() p2$kill() p3$kill() tic <- Sys.time() expect_equal(ps_wait(list(ph1, ph2, ph3), 1000), c(TRUE, TRUE, TRUE)) toc <- Sys.time() expect_true(toc - tic < as.difftime(1, units = "secs")) }) test_that("stress test", { skip_on_cran() pp <- lapply(1:100, function(i) { processx::process$new(px(), c("sleep", "2")) }) on.exit(lapply(pp, function(p) p$kill()), add = TRUE) pps <- lapply(pp, function(p) ps_handle(p$get_pid())) tic <- Sys.time() ret <- ps_wait(pps, 0) toc <- Sys.time() expect_equal(ret, rep(FALSE, length(pp))) expect_true(toc - tic < as.difftime(0.5, units = "secs")) tic <- Sys.time() ret <- ps_wait(pps, 3000) toc <- Sys.time() expect_equal(ret, rep(TRUE, length(pp))) expect_true(toc - tic < as.difftime(3, units = "secs")) }) ps/tests/testthat/test-ps.R0000644000176200001440000000055014755120440015422 0ustar liggesusers test_that("issue #129", { if (!ps_os_type()[["POSIX"]]) return() pss <- ps(user = "root", after = as.POSIXct('2022-05-15', tz = "GMT")) expect_s3_class(pss, "tbl") }) test_that("can select columns", { skip_on_cran() expect_silent(ps(user = ps_username(), columns = c("pid", "username"))) expect_silent(ps(user = ps_username(), columns = "*")) }) ps/tests/testthat/test-pid-reuse.R0000644000176200001440000000303214665030515016676 0ustar liggesusers test_that("pid reuse", { ## This is simulated, because it is quite some work to force a pid ## reuse on some systems. So we create a handle with the pid of a ## running process, but wrong (earlier) create time stamp. z <- processx::process$new(px(), c("sleep", "600")) on.exit(z$kill(), add = TRUE) zpid <- z$get_pid() ctime <- Sys.time() - 60 attr(ctime, "tzone") <- "GMT" p <- ps_handle(zpid, ctime) expect_match(format(p), format_regexp()) expect_output(print(p), format_regexp()) expect_equal(ps_pid(p), zpid) expect_equal(ps_create_time(p), ctime) expect_false(ps_is_running(p)) chk <- function(expr) { err <- tryCatch(expr, error = function(e) e) expect_s3_class(err, "no_such_process") expect_s3_class(err, "ps_error") expect_equal(err$pid, zpid) } ## All these error out with "no_such_process" chk(ps_status(p)) chk(ps_ppid(p)) chk(ps_parent(p)) chk(ps_name(p)) if (ps_os_type()[["POSIX"]]) chk(ps_uids(p)) chk(ps_username(p)) if (ps_os_type()[["POSIX"]]) chk(ps_gids(p)) chk(ps_terminal(p)) if (ps_os_type()[["POSIX"]]) chk(ps_send_signal(p, signals()$SIGINT)) chk(ps_suspend(p)) chk(ps_resume(p)) if (ps_os_type()[["POSIX"]]) chk(ps_terminate(p)) # kill will be still OK, the original process is already dead expect_equal(ps_kill(p), "dead") chk(ps_exe(p)) chk(ps_cmdline(p)) chk(ps_environ(p)) chk(ps_cwd(p)) chk(ps_memory_info(p)) chk(ps_cpu_times(p)) chk(ps_num_threads(p)) chk(ps_num_fds(p)) chk(ps_open_files(p)) chk(ps_connections(p)) }) ps/tests/testthat/test-disk.R0000644000176200001440000000106514665057424015747 0ustar liggesuserstest_that("ps_fs_info", { skip_on_os("windows") # just test that it runs expect_silent( ps_fs_info(c("/", "~", ".")) ) }) test_that("disk_io", { result <- ps_disk_io_counters() # Check structure expect_named( result, c( "read_bytes", "write_bytes", "read_count", "write_count", "read_merged_count", "read_time", "write_merged_count", "write_time", "busy_time", "name" ), ignore.order = TRUE ) expect_type(result, "list") expect_s3_class(result, "data.frame") }) ps/tests/testthat/test-posix-zombie.R0000644000176200001440000000345014664104340017427 0ustar liggesusers if (!ps_os_type()[["POSIX"]]) return() test_that("zombie api", { zpid <- zombie() on.exit(waitpid(zpid), add = TRUE) p <- ps_handle(zpid) me <- ps_handle() expect_match(format(p), format_regexp()) expect_output(print(p), format_regexp()) expect_equal(ps_pid(p), zpid) expect_true(ps_create_time(p) > ps_create_time(me)) expect_true(ps_is_running(p)) expect_equal(ps_status(p), "zombie") expect_equal(ps_ppid(p), Sys.getpid()) expect_equal(ps_pid(ps_parent(p)), Sys.getpid()) expect_equal(ps_name(p), ps_name(me)) expect_identical(ps_uids(p), ps_uids(me)) expect_identical(ps_username(p), ps_username(me)) expect_identical(ps_gids(p), ps_gids(me)) expect_identical(ps_terminal(p), ps_terminal(me)) expect_silent(ps_children(p)) ## You can still send signals if you like expect_silent(ps_send_signal(p, signals()$SIGINT)) expect_equal(ps_status(p), "zombie") expect_silent(ps_suspend(p)) expect_equal(ps_status(p), "zombie") expect_silent(ps_resume(p)) expect_equal(ps_status(p), "zombie") expect_silent(ps_terminate(p)) expect_equal(ps_status(p), "zombie") expect_silent(ps_kill(p)) expect_equal(ps_status(p), "zombie") chk <- function(expr) { err <- tryCatch(expr, error = function(e) e) expect_s3_class(err, "zombie_process") expect_s3_class(err, "ps_error") expect_equal(err$pid, zpid) } ## These raise zombie_process errors chk(ps_exe(p)) chk(ps_cmdline(p)) chk(ps_environ(p)) chk(ps_cwd(p)) chk(ps_memory_info(p)) chk(ps_cpu_times(p)) chk(ps_num_threads(p)) chk(ps_num_fds(p)) chk(ps_open_files(p)) chk(ps_connections(p)) chk(ps_get_nice(p)) chk(ps_set_nice(p, 20L)) if (ps_os_type()[["MACOS"]]) { chk(.Call(psll_memory_uss, p)) } else if (ps_os_type()[["LINUX"]]) { chk(.Call(ps__memory_maps, p)) } }) ps/tests/testthat/test-connections.R0000644000176200001440000002111214755124037017325 0ustar liggesusers test_that("empty set", { px <- processx::process$new( px(), c("sleep", "5"), poll_connection = FALSE) on.exit(cleanup_process(px), add = TRUE) pid <- px$get_pid() p <- ps_handle(pid) cl <- ps_connections(p) expect_equal(nrow(cl), 0) expect_s3_class(cl, "data.frame") expect_s3_class(cl, "tbl") expect_equal( names(cl), c("fd", "family", "type", "laddr", "lport", "raddr", "rport", "state")) }) test_that("UNIX sockets", { if (!ps_os_type()[["POSIX"]]) skip("No UNIX sockets") px <- processx::process$new(px(), c("sleep", "5"), stdout = "|") on.exit(cleanup_process(px), add = TRUE) pid <- px$get_pid() p <- ps_handle(pid) cl <- ps_connections(p) expect_equal(nrow(cl), 1) expect_s3_class(cl, "data.frame") expect_s3_class(cl, "tbl") expect_equal(cl$fd, 1) expect_equal(cl$family, "AF_UNIX") expect_equal(cl$type, "SOCK_STREAM") expect_identical(cl$laddr, NA_character_) expect_identical(cl$lport, NA_integer_) expect_identical(cl$raddr, NA_character_) expect_identical(cl$lport, NA_integer_) expect_identical(cl$state, NA_character_) }) test_that("UNIX sockets with path", { if (!ps_os_type()[["POSIX"]]) skip("No UNIX sockets") skip_without_program("socat") skip_if_no_processx() skip_on_cran() sfile <- tempfile() sfile <- file.path(normalizePath(dirname(sfile)), basename(sfile)) on.exit(unlink(sfile, recursive = TRUE), add = TRUE) nc <- processx::process$new( "socat", c("-", paste0("UNIX-LISTEN:", sfile)), stdin = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() ## Might need to wait for socat to start listening on the socket deadline <- Sys.time() + as.difftime(5, units = "secs") while (nc$is_alive() && !file.exists(sfile) && Sys.time() < deadline) { Sys.sleep(0.1) } cl <- ps_connections(p) cl <- cl[!is.na(cl$laddr) & cl$laddr == sfile, ] expect_equal(nrow(cl), 1) }) test_that("TCP", { skip_on_cran() # need to connect now, otherwise the connections needed for webfakes # show up in the list httpbin$url() before <- ps_connections(ps_handle()) cx <- curl::curl(httpbin$url("/drip"), open = "r") on.exit({ close(cx); rm(cx) }, add = TRUE) after <- ps_connections(ps_handle()) new <- after[! after$lport %in% before$lport, ] expect_equal(new$family, "AF_INET") expect_equal(new$type, "SOCK_STREAM") expect_true(is_ipv4_address(new$laddr)) expect_true(is.integer(new$lport)) expect_equal(new$rport, httpbin$get_port()) expect_equal(new$state, "CONN_ESTABLISHED") }) test_that("TCP on loopback", { skip_without_program("socat") skip_if_no_processx() nc <- processx::process$new( "socat", c("-d", "-d", "-ls", "-", "TCP4-LISTEN:0"), stdin = "|", stderr = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() wait_for_string(nc, "listening on", timeout = 2000) cl <- ps_connections(p) cl <- cl[!is.na(cl$state) & cl$state == "CONN_LISTEN", ] expect_equal(nrow(cl), 1) expect_true(cl$state == "CONN_LISTEN") port <- cl$lport nc2 <- processx::process$new( "socat", c("-", paste0("TCP4-CONNECT:127.0.0.1:", port)), stdin = "|") on.exit(cleanup_process(nc2), add = TRUE) p2 <- nc2$as_ps_handle() deadline <- Sys.time() + as.difftime(5, units = "secs") while (Sys.time() < deadline && ! port %in% (cl2 <- ps_connections(p2))$rport) Sys.sleep(0.1) cl2 <- cl2[!is.na(cl2$rport & cl2$rport == port), ] expect_equal(cl2$family, "AF_INET") expect_equal(cl2$type, "SOCK_STREAM") expect_equal(cl2$state, "CONN_ESTABLISHED") }) test_that("UDP", { # does not work offline skip_on_cran() skip_without_program("socat") skip_if_no_processx() if (!pingr::is_online()) skip("Offline") nc <- processx::process$new( "socat", c("-", "UDP4-CONNECT:8.8.8.8:53,pf=ip4"), stdin = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() deadline <- Sys.time() + as.difftime(5, units = "secs") while (Sys.time() < deadline && ! 53 %in% (cl <- ps_connections(p))$rport) { Sys.sleep(.1) } expect_true(deadline > Sys.time()) cl <- cl[!is.na(cl$rport) & cl$rport == 53, ] expect_equal(nrow(cl), 1) expect_equal(cl$family, "AF_INET") expect_equal(cl$type, "SOCK_DGRAM") expect_equal(cl$raddr, "8.8.8.8") }) test_that("UDP on loopback", { skip_without_program("socat") skip_if_no_processx() nc <- processx::process$new( "socat", c("-d", "-d", "-ls", "-", "UDP4-LISTEN:0"), stdin = "|", stderr = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() wait_for_string(nc, "listening on", timeout = 2000) cl <- ps_connections(p) cl <- cl[!is.na(cl$lport) & cl$type == "SOCK_DGRAM", ] port <- cl$lport expect_equal(cl$family, "AF_INET") expect_equal(cl$type, "SOCK_DGRAM") nc2 <- processx::process$new( "socat", c("-", paste0("UDP4-CONNECT:127.0.0.1:", port)), stdin = "|") on.exit(cleanup_process(nc2), add = TRUE) p2 <- nc2$as_ps_handle() deadline <- Sys.time() + as.difftime(5, units = "secs") while (Sys.time() < deadline && ! port %in% (cl2 <- ps_connections(p2))$rport) Sys.sleep(0.1) cl2 <- cl2[!is.na(cl2$rport & cl2$rport == port), ] expect_equal(cl2$family, "AF_INET") expect_equal(cl2$type, "SOCK_DGRAM") }) test_that("TCP6", { skip_without_program("socat") skip_if_no_processx() skip_without_ipv6() skip_without_ipv6_connection() nc <- processx::process$new( "socat", c("-d", "-d", "-", paste0("TCP6:", ipv6_host(), ":443")), stdin = "|", stderr = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() wait_for_string(nc, "starting data transfer", timeout = 3000) cl <- ps_connections(p) cl <- cl[!is.na(cl$rport) & cl$rport == 443, ] expect_equal(nrow(cl), 1) expect_equal(cl$family, "AF_INET6") expect_equal(cl$type, "SOCK_STREAM") }) test_that("TCP6 on loopback", { skip_without_program("socat") skip_if_no_processx() skip_without_ipv6() nc <- processx::process$new( "socat", c("-d", "-d", "-", "TCP6-LISTEN:0"), stdin = "|", stderr = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() wait_for_string(nc, "listening on", timeout = 2000) cl <- ps_connections(p) cl <- cl[!is.na(cl$state) & cl$state == "CONN_LISTEN", ] expect_equal(nrow(cl), 1) expect_true(cl$state == "CONN_LISTEN") port <- cl$lport nc2 <- processx::process$new( "socat", c("-d", "-d", "-", paste0("TCP6-CONNECT:\\:\\:1:", port)), stdin = "|", stderr = "|") on.exit(cleanup_process(nc2), add = TRUE) p2 <- nc2$as_ps_handle() err <- FALSE tryCatch( wait_for_string(nc2, "starting data transfer", timeout = 2000), error = function(e) err <<- TRUE) if (err) skip("Could not bind to IPv6 address") cl2 <- ps_connections(p2) cl2 <- cl2[!is.na(cl2$rport & cl2$rport == port), ] expect_equal(cl2$family, "AF_INET6") expect_equal(cl2$type, "SOCK_STREAM") }) test_that("UDP6", { skip_without_ipv6() skip_without_ipv6_connection() skip_without_program("socat") skip_if_no_processx() nc <- processx::process$new( "socat", c("-", "UDP6:2001\\:4860\\:4860\\:8888:53"), stdin = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() deadline <- Sys.time() + as.difftime(5, units = "secs") while (Sys.time() < deadline && ! 53 %in% (cl <- ps_connections(p))$rport) { Sys.sleep(.1) } expect_true(deadline > Sys.time()) cl <- cl[!is.na(cl$rport) & cl$rport == 53, ] expect_equal(nrow(cl), 1) expect_equal(cl$family, "AF_INET6") expect_equal(cl$type, "SOCK_DGRAM") expect_match(cl$raddr, "2001:4860:4860:8888", fixed = TRUE) }) test_that("UDP6 on loopback", { skip_without_program("socat") skip_if_no_processx() skip_without_ipv6() nc <- processx::process$new( "socat", c("-d", "-d", "-ls", "-", "UDP6-LISTEN:0"), stdin = "|", stderr = "|") on.exit(cleanup_process(nc), add = TRUE) p <- nc$as_ps_handle() wait_for_string(nc, "listening on", timeout = 2000) cl <- ps_connections(p) cl <- cl[!is.na(cl$lport) & cl$type == "SOCK_DGRAM", ] port <- cl$lport expect_equal(cl$family, "AF_INET6") expect_equal(cl$type, "SOCK_DGRAM") nc2 <- processx::process$new( "socat", c("-d", "-d", "-", paste0("UDP6-CONNECT:\\:\\:1:", port)), stdin = "|", stderr = "|") on.exit(cleanup_process(nc2), add = TRUE) p2 <- nc2$as_ps_handle() err <- FALSE tryCatch( wait_for_string(nc2, "starting data transfer", timeout = 2000), error = function(e) err <<- TRUE) if (err) skip("Could not bind to IPv6 address") cl2 <- ps_connections(p2) cl2 <- cl2[!is.na(cl2$rport & cl2$rport == port), ] expect_equal(cl2$family, "AF_INET6") expect_equal(cl2$type, "SOCK_DGRAM") }) ps/tests/testthat/test-linux.R0000644000176200001440000000230414665044746016154 0ustar liggesusers if (!ps_os_type()[["LINUX"]]) return() test_that("status", { ## Argument check expect_error(ps_status(123), class = "invalid_argument") p1 <- processx::process$new("sleep", "10") on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) wait_for_status(ps, "sleeping") expect_equal(ps_status(ps), "sleeping") ps_suspend(ps) wait_for_status(ps, "stopped") expect_equal(ps_status(ps), "stopped") ps_resume(ps) wait_for_status(ps, "sleeping") expect_equal(ps_status(ps), "sleeping") ## TODO: rest? }) ## TODO: cpu_times ??? We apparently cannot get them from ps test_that("memory_info", { ## Argument check expect_error(ps_memory_info(123), class = "invalid_argument") skip_on_cran() p1 <- processx::process$new("ls", c("-lR", "/")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) Sys.sleep(0.2) ps_suspend(ps) mem <- ps_memory_info(ps) mem2 <- scan(sprintf("/proc/%d/statm", ps_pid(ps)), what = integer(), quiet = TRUE) page_size <- as.integer(system2("getconf", "PAGESIZE", stdout = TRUE)) expect_equal(mem[["vms"]], mem2[[1]] * page_size) expect_equal(mem[["rss"]], mem2[[2]] * page_size) }) ps/tests/testthat/test-macos.R0000644000176200001440000000330114665556377016125 0ustar liggesusers if (!ps_os_type()[["MACOS"]]) return() test_that("status", { ## Argument check skip_on_cran() expect_error(ps_status(123), class = "invalid_argument") p1 <- processx::process$new("sleep", "10") on.exit(cleanup_process(p1), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) expect_equal(ps_status(), "running") expect_equal(ps_status(ps), "sleeping") ps_suspend(ps) expect_equal(ps_status(ps), "stopped") ps_resume(ps) expect_equal(ps_status(ps), "sleeping") ## TODO: can't easily test 'idle' }) test_that("cpu_times", { skip_on_cran() ## Argument check expect_error(ps_cpu_times(123), class = "invalid_argument") p1 <- processx::process$new("ls", c("-lR", "/")) on.exit(cleanup_process(p1), add = TRUE) ps <- ps_handle(p1$get_pid()) Sys.sleep(0.2) ps_suspend(ps) ct <- ps_cpu_times(ps) ps2_user <- parse_time(parse_ps(c("-o", "utime", "-p", ps_pid(ps)))) ps2_total <- parse_time(parse_ps(c("-o", "time", "-p", ps_pid(ps)))) expect_true(abs(round(ct[["user"]], 2) - ps2_user) < 0.2) expect_true(abs(round(ct[["system"]], 2) - (ps2_total - ps2_user)) < 0.2) }) test_that("memory_info", { skip_on_cran() ## Argument check expect_error(ps_memory_info(123), class = "invalid_argument") p1 <- processx::process$new("ls", c("-lR", "/")) on.exit(cleanup_process(p1), add = TRUE) ps <- ps_handle(p1$get_pid()) Sys.sleep(0.2) ps_suspend(ps) mem <- ps_memory_info(ps) ps2_rss <- as.numeric(parse_ps(c("-o", "rss", "-p", ps_pid(ps)))) ps2_vms <- as.numeric(parse_ps(c("-o", "vsize", "-p", ps_pid(ps)))) expect_equal(mem[["rss"]] / 1024, ps2_rss, tolerance = 10) expect_equal(mem[["vms"]] / 1024, ps2_vms, tolerance = 10) }) ps/tests/testthat/test-common.R0000644000176200001440000002467614665030515016312 0ustar liggesusers test_that("create self process", { expect_error(ps_handle("foobar"), class = "invalid_argument") expect_error(ps_handle(time = 123), class = "invalid_argument") ps <- ps_handle() expect_identical(ps_pid(ps), Sys.getpid()) }) test_that("format", { ps <- ps_handle() expect_match(format(ps), format_regexp()) }) test_that("print", { ps <- ps_handle() expect_output(print(ps), format_regexp()) }) test_that("pid", { ## Argument check expect_error(ps_pid(123), class = "invalid_argument") ## Self ps <- ps_handle() expect_identical(ps_pid(ps), Sys.getpid()) ## Child p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_identical(ps_pid(ps), p1$get_pid()) skip_if_no_processx() ## Even if it has quit already p2 <- processx::process$new(px(), c("sleep", "10")) on.exit(p2$kill(), add = TRUE) pid2 <- p2$get_pid() ps <- ps_handle(pid2) p2$kill() expect_false(p2$is_alive()) expect_identical(ps_pid(ps), pid2) }) test_that("create_time", { ## Argument check expect_error(ps_create_time(123), class = "invalid_argument") skip_if_no_processx() p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_identical(p1$get_start_time(), ps_create_time(ps)) }) test_that("is_running", { ## Argument check expect_error(ps_is_running(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) p1$kill() timeout <- Sys.time() + 5 while (ps_is_running(ps) && Sys.time() < timeout) Sys.sleep(0.05) expect_false(ps_is_running(ps)) }) test_that("parent", { ## Argument check expect_error(ps_parent(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) pp <- ps_parent(ps) expect_equal(ps_pid(pp), Sys.getpid()) }) test_that("ppid", { ## Argument check expect_error(ps_ppid(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) expect_equal(ps_ppid(ps), Sys.getpid()) }) test_that("name", { ## Argument check expect_error(ps_name(123), class = "invalid_argument") skip_if_no_processx() p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) expect_true(ps_name(ps) %in% c("px", "px.exe")) ## Long names are not truncated file.copy( px(), tmp <- paste0(tempfile(pattern = "file1234567890123456"), ".bat")) on.exit(unlink(tmp), add = TRUE) Sys.chmod(tmp, "0755") p2 <- processx::process$new(tmp, c("sleep", "10")) on.exit(p2$kill(), add = TRUE) ps <- ps_handle(p2$get_pid()) expect_true(ps_is_running(ps)) expect_equal(ps_name(ps), basename(tmp)) }) test_that("exe", { ## Argument check expect_error(ps_exe(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) exe <- ps_exe(ps) # In qemu the first entry is qemu, the second entry is the exe if (!grepl("qemu", exe)) { expect_equal(ps_exe(ps), realpath(px())) } }) test_that("cmdline", { ## Argument check expect_error(ps_cmdline(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) cmd <- ps_cmdline(ps) # in qemu, need to drop the first two if (grepl("qemu", cmd[1])) { cmd <- cmd[-(1:2)] } expect_equal(cmd, c(px(), "sleep", "10")) }) test_that("cwd", { ## Argument check expect_error(ps_cwd(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10"), wd = tempdir()) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) expect_equal(normalizePath(ps_cwd(ps)), normalizePath(tempdir())) }) test_that("environ, environ_raw", { ## Argument check expect_error(ps_environ(123), class = "invalid_argument") skip_if_no_processx() rnd <- basename(tempfile()) p1 <- processx::process$new(px(), c("sleep", "10"), env = c(FOO = rnd)) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) expect_equal(ps_environ(ps)[["FOO"]], rnd) expect_true(paste0("FOO=", rnd) %in% ps_environ_raw(ps)) }) test_that("num_threads", { ## Argument check expect_error(ps_num_threads(123), class = "invalid_argument") ## sleep should be single-threaded p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) # This is not reliable in qemu if (!grepl("qemu", ps_exe(ps))) { expect_equal(ps_num_threads(ps), 1) } ## TODO: more threads? }) test_that("suspend, resume", { ## Argument check expect_error(ps_suspend(123), class = "invalid_argument") expect_error(ps_resume(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) ps_suspend(ps) timeout <- Sys.time() + 60 while (Sys.time() < timeout && ps_status(ps) != "stopped") Sys.sleep(0.05) expect_equal(ps_status(ps), "stopped") expect_true(p1$is_alive()) expect_true(ps_is_running(ps)) ps_resume(ps) timeout <- Sys.time() + 60 while (Sys.time() < timeout && ps_status(ps) == "stopped") Sys.sleep(0.05) expect_true(ps_status(ps) %in% c("running", "sleeping")) expect_true(p1$is_alive()) expect_true(ps_is_running(ps)) ps_kill(ps) }) test_that("kill", { ## Argument check expect_error(ps_kill(123), class = "invalid_argument") p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) ps_kill(ps) timeout <- Sys.time() + 5 while (Sys.time() < timeout && ps_is_running(ps)) Sys.sleep(0.05) expect_false(p1$is_alive()) expect_false(ps_is_running(ps)) if (ps_os_type()[["POSIX"]]) { expect_equal(p1$get_exit_status(), - signals()$SIGTERM) } }) test_that("children", { ## Argument check expect_error(ps_children(123), class = "invalid_argument") ## This fails on CRAN, and I cannot reproduce it anywhere else skip_on_cran() skip_if_no_processx() p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) p2 <- processx::process$new(px(), c("sleep", "10")) on.exit(p2$kill(), add = TRUE) ch <- ps_children(ps_handle()) expect_true(length(ch) >= 2) pids <- map_int(ch, ps_pid) expect_true(p1$get_pid() %in% pids) expect_true(p2$get_pid() %in% pids) ## We don't do this on Windows, because the parent process might be ## gone by now, and then it fails with no_such_process if (ps_os_type()[["POSIX"]]) { ch3 <- ps_children(ps_parent(ps_handle()), recursive = TRUE) pids3 <- map_int(ch3, ps_pid) expect_true(Sys.getpid() %in% pids3) expect_true(p1$get_pid() %in% pids3) expect_true(p2$get_pid() %in% pids3) } }) test_that("num_fds", { skip_in_rstudio() skip_on_cran() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) me <- ps_handle() orig <- ps_num_fds(me) f <- file(tmp, open = "w") on.exit(close(f), add = TRUE) expect_equal(ps_num_fds(me), orig + 1) }) test_that("open_files", { skip_in_rstudio() skip_on_cran() tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) f <- file(tmp, open = "w") on.exit(try(close(f), silent = TRUE), add = TRUE) files <- ps_open_files(ps_handle()) expect_true(basename(tmp) %in% basename(files$path)) close(f) files <- ps_open_files(ps_handle()) expect_false(basename(tmp) %in% basename(files$path)) }) test_that("interrupt", { skip_on_cran() px <- processx::process$new(px(), c("sleep", "10")) on.exit(px$kill(), add = TRUE) ps <- ps_handle(px$get_pid()) expect_true(ps_is_running(ps)) ps_interrupt(ps) deadline <- Sys.time() + 3 while (ps_is_running(ps) && Sys.time() < deadline) Sys.sleep(0.05) expect_true(Sys.time() < deadline) expect_false(ps_is_running(ps)) if (ps_os_type()[["POSIX"]]) expect_equal(px$get_exit_status(), -2) }) test_that("cpu affinity", { skip_on_cran() skip_on_covr() skip_on_os("mac") orig <- ps::ps_get_cpu_affinity() expect_true(length(orig) <= ps::ps_cpu_count()) do <- function() { ps::ps_set_cpu_affinity(affinity = 0:0) ps::ps_get_cpu_affinity() } expect_equal(callr::r(do), 0:0) }) test_that("kill 2", { skip_on_cran() p <- processx::process$new(px(), c("sleep", "3")) on.exit(p$kill(), add = TRUE) ph <- p$as_ps_handle() done <- if (ps_os_type()[["WINDOWS"]]) "killed" else "terminated" expect_equal(ps_kill(ph), done) expect_equal(ps_kill(ph), "dead") # multiple processes p1 <- processx::process$new(px(), c("sleep", "3")) on.exit(p1$kill(), add = TRUE) ph1 <- p1$as_ps_handle() p2 <- processx::process$new(px(), c("sleep", "3")) on.exit(p2$kill(), add = TRUE) ph2 <- p2$as_ps_handle() expect_equal(ps_kill(list(ph1, ph2)), c(done, done)) expect_equal(ps_kill(list(ph1, ph2)), c("dead", "dead")) # some dead, some alive p3 <- processx::process$new(px(), c("sleep", "3")) on.exit(p3$kill(), add = TRUE) ph3 <- p3$as_ps_handle() p4 <- processx::process$new(px(), c("sleep", "3")) on.exit(p4$kill(), add = TRUE) ph4 <- p4$as_ps_handle() expect_equal(ps_kill(ph3), done) expect_equal(ps_kill(list(ph3, ph4)), c("dead", done)) # error up front for pid 0 if (ps_os_type()[["MACOS"]]) { p5 <- processx::process$new(px(), c("sleep", "3")) on.exit(p5$kill(), add = TRUE) ph5 <- p5$as_ps_handle() ph6 <- ps_handle(0) expect_snapshot(error = TRUE, { ps_kill(list(ph5, ph6)) }) expect_true(p5$is_alive()) p5$kill() } # access denied for some processes if (ps_os_type()[["MACOS"]]) { p7 <- processx::process$new(px(), c("sleep", "3")) on.exit(p7$kill(), add = TRUE) ph7 <- p7$as_ps_handle() ph8 <- ps_handle(1) p9 <- processx::process$new(px(), c("sleep", "3")) on.exit(p9$kill(), add = TRUE) ph9 <- p9$as_ps_handle() expect_snapshot(error = TRUE, { ps_kill(list(ph7, ph8, ph9)) }) expect_false(p7$is_alive()) expect_true(ps_is_running(ph8)) expect_false(p9$is_alive()) } }) ps/tests/testthat/_snaps/0000755000176200001440000000000014665030515015166 5ustar liggesusersps/tests/testthat/_snaps/common.md0000644000176200001440000000056714755124737017022 0ustar liggesusers# kill 2 Code ps_kill(list(ph5, ph6)) Condition Error: ! preventing sending KILL signal to process with PID 0 as it would affect every process in the process group of the calling process (Sys.getpid()) instead of PID 0 --- Code ps_kill(list(ph7, ph8, ph9)) Condition Error: ! Failed to kill some processes: 1 (launchd) ps/tests/testthat/test-system.R0000644000176200001440000000302614664104340016325 0ustar liggesusers test_that("ps_pids", { pp <- ps_pids() expect_true(is.integer(pp)) expect_true(Sys.getpid() %in% pp) }) test_that("ps", { pp <- ps() expect_true(inherits(pp, "tbl")) expect_true(Sys.getpid() %in% pp$pid) px <- processx::process$new(px(), c("sleep", "5")) x <- ps_handle(px$get_pid()) on.exit(px$kill(), add = TRUE) pp <- ps(after = Sys.time() - 60 * 60) ct <- lapply(pp$pid, function(p) { tryCatch(ps_create_time(ps_handle(p)), error = function(e) NULL) }) ct <- not_null(ct) expect_true(all(map_lgl(ct, function(x) x > Sys.time() - 60 * 60))) pp <- ps(user = ps_username(ps_handle())) expect_true(all(pp$username == ps_username(ps_handle()))) }) test_that("ps_boot_time", { bt <- ps_boot_time() expect_s3_class(bt, "POSIXct") expect_true(bt < Sys.time()) }) test_that("ps_os_type", { os <- ps_os_type() expect_true(is.logical(os)) expect_true(any(os)) expect_equal( names(os), c("POSIX", "WINDOWS", "LINUX", "MACOS")) }) test_that("ps_is_supported", { expect_equal(any(ps_os_type()), ps_is_supported()) }) test_that("supported_str", { expect_equal(supported_str(), "Windows, Linux, Macos") }) test_that("ps_os_name", { expect_true(ps_os_name() %in% names(ps_os_type())) }) test_that("ps_users runs", { expect_error(ps_users(), NA) }) test_that("ps_cpu_count", { log <- ps_cpu_count(logical = TRUE) phy <- ps_cpu_count(logical = FALSE) if (!is.na(log) && !is.na(phy)) expect_true(log >= phy) if (!is.na(log)) expect_true(log > 0) if (!is.na(phy)) expect_true(phy > 0) }) ps/tests/testthat/test-winver.R0000644000176200001440000000152514663700234016320 0ustar liggesusers test_that("winver_ver", { cases <- list( list(c("", "Microsoft Windows [Version 6.3.9600]"), "6.3.9600"), list("Microsoft Windows [version 6.1.7601]", "6.1.7601"), list("Microsoft Windows [vers\u00e3o 10.0.18362.207]", "10.0.18362.207")) source(system.file("tools", "winver.R", package = "ps"), local = TRUE) for (x in cases) expect_identical(winver_ver(x[[1]]), x[[2]]) }) test_that("winver_wmic", { cases <- list( list(c("\r", "\r", "Version=6.3.9600\r", "\r", "\r", "\r"), "6.3.9600"), list(c("\r", "\r", "version=6.3.9600\r", "\r", "\r", "\r"), "6.3.9600"), list(c("\r", "\r", "vers\u00e3o=6.3.9600\r", "\r", "\r", "\r"), "6.3.9600")) source(system.file("tools", "winver.R", package = "ps"), local = TRUE) for (x in cases) expect_identical(winver_wmic(x[[1]]), x[[2]]) }) ps/tests/testthat/test-wait-inotify.R0000644000176200001440000000036114665030515017426 0ustar liggesuserstest_that("dummy", { expect_true(TRUE) }) if (ps_os_type()[["LINUX"]]) { fun <- function() { withr::local_envvar(PS_WAIT_FORCE_INOTIFY = "true") testthat::source_file(test_path("test-wait.R"), env = environment()) } fun() } ps/tests/testthat/test-posix.R0000644000176200001440000000614214665030515016150 0ustar liggesusers if (!ps_os_type()[["POSIX"]]) return() test_that("is_running", { ## Zombie is running zpid <- zombie() on.exit(waitpid(zpid), add = TRUE) ps <- ps_handle(zpid) expect_true(ps_is_running(ps)) }) test_that("terminal", { tty <- ps_terminal(ps_handle()) if (is.na(tty)) skip("no terminal") expect_true(file.exists(tty)) ## It is a character special file out <- processx::run("ls", c("-l", tty))$stdout expect_equal(substr(out, 1, 1), "c") }) test_that("username, uids, gids", { if (Sys.which("ps") == "") skip("No ps program") ret <- system("ps -p 1 >/dev/null 2>/dev/null") if (ret != 0) skip("ps does not work properly") p1 <- processx::process$new("sleep", "10") on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) ps2_username <- parse_ps(c("-o", "user", "-p", ps_pid(ps))) expect_equal(ps_username(ps), ps2_username) ps2_uid <- parse_ps(c("-o", "uid", "-p", ps_pid(ps))) expect_equal(ps_uids(ps)[["real"]], as.numeric(ps2_uid)) ps2_gid <- parse_ps(c("-o", "rgid", "-p", ps_pid(ps))) expect_equal(ps_gids(ps)[["real"]], as.numeric(ps2_gid)) }) test_that("send_signal", { p1 <- processx::process$new("sleep", "10") on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) ps_send_signal(ps, signals()$SIGINT) timeout <- Sys.time() + 60 while (Sys.time() < timeout && p1$is_alive()) Sys.sleep(0.05) expect_false(p1$is_alive()) expect_false(ps_is_running(ps)) expect_equal(p1$get_exit_status(), - signals()$SIGINT) }) test_that("terminate", { p1 <- processx::process$new("sleep", "10") on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) ps_terminate(ps) timeout <- Sys.time() + 60 while (Sys.time() < timeout && p1$is_alive()) Sys.sleep(0.05) expect_false(p1$is_alive()) expect_false(ps_is_running(ps)) expect_equal(p1$get_exit_status(), - signals()$SIGTERM) }) test_that("kill with grace", { p1 <- processx::process$new( px(), c("sigterm", "ignore", "outln", "setup", "sleep", "3"), stdout = "|" ) on.exit(p1$kill(), add = TRUE) ph1 <- p1$as_ps_handle() # need to wait until the SIGTERM handler is set up in px expect_equal(p1$poll_io(1000)[["output"]], "ready") expect_equal(ps_kill(ph1), "killed") }) test_that("kill with grace, multiple processes", { # ignored SIGTERM completely p1 <- processx::process$new( px(), c("sigterm", "ignore", "outln", "setup", "sleep", "3"), stdout = "|" ) on.exit(p1$kill(), add = TRUE) ph1 <- p1$as_ps_handle() # exits 0.5s later after SIGTERM p2 <- processx::process$new( px(), c("sigterm", "sleep", "0.5", "outln", "setup", "sleep", "3"), stdout = "|" ) on.exit(p2$kill(), add = TRUE) ph2 <- p2$as_ps_handle() # exits on SIGTERM p3 <- processx::process$new(px(), c("sleep", "3")) on.exit(p3$kill(), add = TRUE) ph3 <- p3$as_ps_handle() # wait until signal handlers are set up expect_equal(p1$poll_io(1000)[["output"]], "ready") expect_equal(p2$poll_io(1000)[["output"]], "ready") expect_equal( ps_kill(list(ph1, ph2, ph3), grace = 1000), c("killed", "terminated", "terminated") ) }) ps/tests/testthat/test-windows.R0000644000176200001440000000171714665044746016516 0ustar liggesusers if (!ps_os_type()[["WINDOWS"]]) return() test_that("uids, gids", { p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) err <- tryCatch(ps_uids(ps), error = function(e) e) expect_s3_class(err, "not_implemented") expect_s3_class(err, "ps_error") err <- tryCatch(ps_gids(ps), error = function(e) e) expect_s3_class(err, "not_implemented") expect_s3_class(err, "ps_error") }) test_that("terminal", { p1 <- processx::process$new(px(), c("sleep", "10")) on.exit(p1$kill(), add = TRUE) ps <- ps_handle(p1$get_pid()) expect_true(ps_is_running(ps)) expect_identical(ps_terminal(ps), NA_character_) }) ## TODO: username ## TODO: cpu_times ## TODO: memory_info test_that("total and available mem", { l <- .Call(ps__system_memory)[c("total", "avail")] expect_true(is.numeric(l$total)) expect_true(is.numeric(l$avail)) expect_lte(l$avail, l$total) }) ps/tests/testthat.R0000644000176200001440000000052114670523103014020 0ustar liggesuserslibrary(testthat) library(ps) if (ps::ps_is_supported() && Sys.getenv("R_COVR", "") != "true" && Sys.getenv("NOT_CRAN") != "" ) { reporter <- ps::CleanupReporter(testthat::SummaryReporter)$new() } else { reporter <- "summary" } if (ps_is_supported() && Sys.getenv("NOT_CRAN") != "") { test_check("ps", reporter = reporter) } ps/MD50000644000176200001440000001736114755211512011217 0ustar liggesusers8ebf7bd6cf2d2863bc0d0bf6ac08967f *DESCRIPTION 41f0f80dd5efa175d8864b3e5612c5d0 *LICENSE 63e8ae8f640a1e2c28ae10746f3c09b1 *LICENSE.note 618c1ec7b36302a80533681f30e7b02d *NAMESPACE 3d7e702d1de929d6d5e0832aa4dc5949 *NEWS.md d82e6c4bbaeec46be16e08829e286ab1 *R/cleancall.R 773e4db09280c1e2b0463de9764546f6 *R/compat-vctrs.R dea19430022f2fb12ce82ebd3185a74d *R/disk.R f2b86074ffeec5a3c7c4b21bf126f448 *R/errno.R e9d5da70cc329bca4418e19af321c9b8 *R/error.R 03d55c8abff700b07215c68b8a944acf *R/glob.R 52c361a719c3e35e5ab1e56e5cd950b1 *R/iso-date.R 36d30194a58f87b36c35e61393be0a37 *R/kill-tree.R 60b44d38daad71c78f04d2a839dde310 *R/linux.R e3ff73d9b31a2c4c680ae7bd23f8f445 *R/low-level.R 92a3b0e470dbcbb6215e52d9885ad795 *R/macos.R 389340f5fee7127eb63eee1361cdd84d *R/memoize.R 1d98ec5bd95332f43611c1ca09545af6 *R/memory.R cdfd829ac1c275055e65981db923c891 *R/os.R c9251bd3db34af080f5fe5efd4a5d350 *R/package.R c65da554810268ea68e5c5047218d181 *R/posix.R 2b311826369d410a50f5d1aef83f8ba4 *R/ps-package.R d78428bd1e4b01fd8d333ac69db961d0 *R/ps.R f0ab86b857768945fa91df2c46cd423c *R/rematch2.R db75d056094c34104f0a425065f785e6 *R/system.R c91cfa06d3e6632738d2c27b40ce78fc *R/testthat-reporter.R ab76a0e1b8e6935ae80e7e1f6287ddad *R/utils.R b89b19571783e7ecaed648aa7a1e3cca *README.md 673df0aae8fd90003843cc26867ad7fd *cleanup cdce6d322c5c6d74bd997a048092f38f *configure 757ef8281ef2a1ebcbcc8235aeee2d0e *configure.win f76a886fa32868f9eeaf9b0dfa9dc7ad *inst/WORDLIST 28613e2a5a14a4fe95f362359b2af465 *inst/internals.md 5bb8cbef9142337897cc546c8551e5fd *inst/tools/error-codes.R 94d5c399a5ddddea6407eb43cb5e6ef4 *inst/tools/winver.R 39d38510be0ddddedbd841e507488aa8 *man/CleanupReporter.Rd 6bdd1f2ec6ac42218f8b5db8cac6bccb *man/errno.Rd 91121e5d0f0b3cf1d2769a44d9b089f4 *man/ps-package.Rd d6b7459e2d71e07726ae03c51b53b530 *man/ps.Rd 05b4748e838a65898bb822e212a0204e *man/ps_apps.Rd d3f65d772b6a08285e726a16890bf99a *man/ps_boot_time.Rd a8d3ea8594c147a60d861a71d8c92478 *man/ps_children.Rd 7f040cd02944e0442f7308b407be7816 *man/ps_cmdline.Rd 11ab1e403a492b33618863d0e8ed6170 *man/ps_connections.Rd c98816e750a20a8b942f063ab8dc894d *man/ps_cpu_count.Rd 5b055c0a275fcfe5fa26e1d7363533f0 *man/ps_cpu_times.Rd c8da91226f7ac08312a56fcf76bd4d9d *man/ps_create_time.Rd 103ccf825a1f7d6c86907127d08c62de *man/ps_cwd.Rd 62d4cf9824c7d89703953e429792d4fc *man/ps_descent.Rd 69e4f715ad257c95d08d0215a226fc76 *man/ps_disk_io_counters.Rd 055a7d8e5ebff62713df28bc31e441d4 *man/ps_disk_partitions.Rd 0ecc35ff26e31fea9fbdcea47925e1bd *man/ps_disk_usage.Rd 62014cbb6cbab3d14449bf2f903349fa *man/ps_environ.Rd 0b19e1b1afecbcfbeedf4ed9e0e800fc *man/ps_exe.Rd 5a47119d7c37edbdf1045ab5d3cc278a *man/ps_fs_info.Rd 67870bdbaf7a34c747f9bcd86427f3a8 *man/ps_fs_mount_point.Rd 47b30685415b59ff27442991db9f6e55 *man/ps_fs_stat.Rd be48d18e6ff7e8d8eeede69dce3fb7f8 *man/ps_get_cpu_affinity.Rd 5891e27e505e5535bbb69e888691c7cb *man/ps_get_nice.Rd 60159dcc7a1d2c34e6dcdb29a5e44794 *man/ps_handle.Rd 8ad25625d6957b2a325dfdb5bb9a5662 *man/ps_interrupt.Rd ff872e411570beb96fa31eeacc7a6d55 *man/ps_is_running.Rd 1c56be61654e5aca6a0b383729d602f6 *man/ps_kill.Rd eb8b8d3d44c19d7808df2581381c55d5 *man/ps_kill_tree.Rd 8605cbb7a0ef80fc382a435cf7a6bb0d *man/ps_loadavg.Rd 87bb86fb000acd77c256ffaa481fc034 *man/ps_memory_info.Rd b0d8acd4c9c04321eb35965104d2421a *man/ps_name.Rd a3471a66af79365819c3848d4422be65 *man/ps_num_fds.Rd 2040bca15a24a2a4008cef672618dcf6 *man/ps_num_threads.Rd 811c6e20437e277b4d44b8fabd97d067 *man/ps_open_files.Rd 3c9b99d9e87f47e1114bf901ddcfe6ed *man/ps_os_type.Rd 3e5c92b0e1df2a29f5dbb36467e6c802 *man/ps_pid.Rd f5dd035dbcc82569f667b2e252db9981 *man/ps_pids.Rd 149eb2521db62f4caf708ad893f4d5d5 *man/ps_ppid.Rd a7648f4898836117c4015dd467e2ac81 *man/ps_resume.Rd b39154a42dd34207043359f90c5d5c4a *man/ps_send_signal.Rd 6c94a5f2ec7850a8d9c600094570041f *man/ps_shared_lib_users.Rd e5d95dd765ebd7302c5d8bdf5ad7560d *man/ps_shared_libs.Rd ef302af1abc6759d42fa7933257709ad *man/ps_status.Rd 408d00c73615af03d8ecb5702d1642db *man/ps_suspend.Rd 4027e0bbd5ed0776e9c16689ba300f66 *man/ps_system_cpu_times.Rd d4bc41c560f094cc5e417854bf449a10 *man/ps_system_memory.Rd 0cd6c754ae8720e24c0a977ea8f249be *man/ps_system_swap.Rd 1f0d34f90723e7ef8532fa6f1d6a22bc *man/ps_terminal.Rd 8754ba78196a2547ed4cff957d0cd70c *man/ps_terminate.Rd bd554c0b5f1ef8391e409640a2f46607 *man/ps_tty_size.Rd ddb5d56cc23031a4faf33ed3e859587e *man/ps_uids.Rd 2ea465bbfbf5c5af18386e05a6299b4c *man/ps_username.Rd 7ac22267898d9af8fbdcc0f4693d7f69 *man/ps_users.Rd 60cf763171db5beab429a2ecf5b3b90a *man/ps_wait.Rd b90f28ca6453b80a98510a27fd9f764b *man/signals.Rd 087f1952800aa8090dd414bc2e78dcee *src/Makevars.in b5f8310122548eaa2c3eb3e695790eec *src/api-common.c 54c8977cfac9e2bc622da8596c020a42 *src/api-linux.c a1675e258f10f5cef397a726bec91fb7 *src/api-macos.c d3359291af852cd81f6ce2beb359292b *src/api-posix.c 2f66c9907cb31f96a470ddc5d9cdce0b *src/api-windows-conn.c b8f9b4468b1868443b60094657a879f1 *src/api-windows.c 59836ad0c8323e75e945ff49a68db500 *src/arch/macos/apps.m 99c220895973b6a0954634027c0dfae3 *src/arch/macos/disk.c 6580244464b2e0ad479dbdc81bceb8a6 *src/arch/macos/process_info.c 1e38474d4963d003a9404e6895c745f6 *src/arch/macos/process_info.h 148de22397f1a69087b5a0c8515bc302 *src/arch/windows/ntextapi.h 97954cb11b99affac1aa8fbebab94380 *src/arch/windows/process_handles.c c39d21cbc780797df0bccce327b78e1f *src/arch/windows/process_handles.h 2c0a5cb376ab6d0a1aac9cbdc2034607 *src/arch/windows/process_info.c 0b15bf50b4da657b87730ed80819b09c *src/arch/windows/process_info.h 707ee707cf063ee7425ffac6053aceeb *src/arch/windows/wmi.c 82b5161fea28cdd8f50f6b94451ab72d *src/cleancall.c 07a0b2f422fb87c0d5e789157fac4b31 *src/cleancall.h 283d68dbe242227537d431feaea6bb3b *src/common.c 73ab5051f40c0369b3cf2dce40d7bcf9 *src/common.h a18fee26c965952b0724b5c38002a400 *src/dummy.c dad0993904e3dbfab044e6096bc61ee7 *src/extra.c 5d7449101690034f5624b3017ec0d5c7 *src/init.c 25293087d29ce032315b03ca28b91cf7 *src/install.libs.R 3db35656c2495dee4cbe752196cb47b0 *src/interrupt.c bd7ce57920e68af62c55b5ecf198b80d *src/linux.c c78665dce54923bee1161fe21959705f *src/macos.c b9f4521bf2aa4cfa6978558cff8c00de *src/posix.c 2507b0980ff4bc172f06f04b9a37a935 *src/posix.h eab96c69af71c6fab04d1a446994f14d *src/ps-internal.h f358a6a4029a303f6de0519db5c8abf1 *src/ps.h ca083890818d5919ff47b6854dc79d83 *src/px.c b32b4fb3d1af0315cb26e5264bb58873 *src/windows.c 0897962482dbdf5c733d04218c227089 *src/windows.h 07f90e6173f567e33bb5b4f4c78c3c06 *tests/testthat.R 18841bef269204cc816fe547885a1c92 *tests/testthat/_snaps/common.md 325c0b3f4be5034402d74c46a99f86a6 *tests/testthat/fixtures/cleanup-error/test-cleanup-error.R bb32f15a4c5782e789610b83df386f5c *tests/testthat/helpers.R 206c1c7340a49f6d1156b2c9b490416d *tests/testthat/test-cleanup-reporter.R 558befa1ef7c2436358653124788e16d *tests/testthat/test-common.R cf727562e73748f80f1609e39abf3396 *tests/testthat/test-connections.R 51714cda05a69e2858f13d1edebfc68b *tests/testthat/test-disk.R a8d54ddc4da173ed9c8832043f7c74ca *tests/testthat/test-finished.R ce22062b7534767ddc8917adedd3b73d *tests/testthat/test-kill-tree.R 326970ae650ea2d2282829fc1cd92c6e *tests/testthat/test-linux.R 02b50983ed84b8494bd2f72722e2908b *tests/testthat/test-macos.R 084aa21af60560f0c272c12bc5eb8d35 *tests/testthat/test-pid-reuse.R a794b5eceac62acbcf5b2cb20cf6e5d2 *tests/testthat/test-posix-zombie.R f70c2c3441f9056b4e81e1b6778e2c39 *tests/testthat/test-posix.R 090de830d689317b9ad34e27f6630bf7 *tests/testthat/test-ps.R c02c0a77694824113a206d553b32b0d4 *tests/testthat/test-system.R 83bc467ad49d545f52dbb62f99f0ee66 *tests/testthat/test-utils.R 23c15f61aad8cf539420b1d5718b2459 *tests/testthat/test-wait-inotify.R 9c72510ef032706b98ae070a8bdeeaf8 *tests/testthat/test-wait.R 93bf625d6791c80c7d48bd3439a5bac3 *tests/testthat/test-windows.R 5481ba17549baa5661e2d7198388ef28 *tests/testthat/test-winver.R 8961ea6b8e58d8b6d46a552eb80851a9 *tools/linux-fs-types.txt ps/configure.win0000644000176200001440000000004314145146225013375 0ustar liggesusers#! /usr/bin/env sh sh ./configure ps/R/0000755000176200001440000000000014755120440011077 5ustar liggesusersps/R/errno.R0000644000176200001440000000100114664104340012337 0ustar liggesusers #' List of 'errno' error codes #' #' For the errors that are not used on the current platform, `value` is #' `NA_integer_`. #' #' A data frame with columns: `name`, `value`, `description`. #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' errno() errno <- function() { err <- as.list(ps_env$constants$errno) err <- err[order(names(err))] data_frame( name = names(err), value = vapply(err, "[[", integer(1), 1), description = vapply(err, "[[", character(1), 2) ) } ps/R/rematch2.R0000644000176200001440000000153214665545712012745 0ustar liggesusers re_match <- function(text, pattern, perl = TRUE, ...) { text <- as.character(text) match <- regexpr(pattern, text, perl = perl, ...) start <- as.vector(match) length <- attr(match, "match.length") end <- start + length - 1L matchstr <- substring(text, start, end) matchstr[ start == -1 ] <- NA_character_ res <- data_frame(.text = text, .match = matchstr) if (!is.null(attr(match, "capture.start"))) { gstart <- attr(match, "capture.start") glength <- attr(match, "capture.length") gend <- gstart + glength - 1L groupstr <- substring(text, gstart, gend) groupstr[ gstart == -1 ] <- NA_character_ dim(groupstr) <- dim(gstart) res <- cbind(groupstr, res, stringsAsFactors = FALSE) } names(res) <- c(attr(match, "capture.names"), ".text", ".match") class(res) <- c("tbl", class(res)) res } ps/R/cleancall.R0000644000176200001440000000015114665030515013140 0ustar liggesusers call_with_cleanup <- function(ptr, ...) { .Call(cleancall_call, pairlist(ptr, ...), parent.frame()) } ps/R/os.R0000644000176200001440000000206014207645620011645 0ustar liggesusers #' Query the type of the OS #' #' @return `ps_os_type` returns a named logical vector. The rest of the #' functions return a logical scalar. #' #' `ps_is_supported()` returns `TRUE` if ps supports the current platform. #' #' @export #' @examples #' ps_os_type() #' ps_is_supported() ps_os_type <- function() { if (is.null(ps_env$os_type)) ps_env$os_type <- .Call(ps__os_type) ps_env$os_type } ps_os_name <- function() { os <- ps_os_type() os <- os[setdiff(names(os), c("BSD", "POSIX"))] names(os)[which(os)] } #' @rdname ps_os_type #' @export ps_is_supported <- function() { os <- ps_os_type() if (os[["LINUX"]]) { # On Linux we need to check if /proc is readable supported <- FALSE tryCatch({ readLines("/proc/stat", warn = FALSE, n = 1) supported <- TRUE }, error = function(e) e) supported } else { os <- os[setdiff(names(os), c("BSD", "POSIX"))] any(os) } } supported_str <- function() { os <- ps_os_type() os <- os[setdiff(names(os), c("BSD", "POSIX"))] paste(caps(names(os)), collapse = ", ") } ps/R/memoize.R0000644000176200001440000000073414207645620012677 0ustar liggesusers ## nocov start memoize <- function(fun) { fun cache <- NULL if (length(formals(fun)) > 0) { stop("Only memoizing functions without arguments") } dec <- function() { if (is.null(cache)) cache <<- fun() cache } attr(dec, "clear") <- function() cache <<- TRUE class(dec) <- c("memoize", class(dec)) dec } `$.memoize` <- function(x, name) { switch( name, "clear" = attr(x, "clear"), stop("unknown memoize method") ) } ## nocov end ps/R/low-level.R0000644000176200001440000011371414755106424013145 0ustar liggesusers #' Create a process handle #' #' @param pid Process id. Integer scalar. `NULL` means the current R #' process. #' @param time Start time of the process. Usually `NULL` and ps will query #' the start time. #' @return `ps_handle()` returns a process handle (class `ps_handle`). #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p ps_handle <- function(pid = NULL, time = NULL) { if (!is.null(pid)) pid <- assert_pid(pid) if (!is.null(time)) assert_time(time) .Call(psll_handle, pid, time) } #' @rdname ps_handle #' @export as.character.ps_handle <- function(x, ...) { pieces <- .Call(psll_format, x) paste0(" PID=", pieces[[2]], ", NAME=", pieces[[1]], ", AT=", format_unix_time(pieces[[3]])) } #' @param x Process handle. #' @param ... Not used currently. #' #' @rdname ps_handle #' @export format.ps_handle <- function(x, ...) { as.character(x, ...) } #' @rdname ps_handle #' @export print.ps_handle <- function(x, ...) { cat(format(x, ...), "\n", sep = "") invisible(x) } #' Pid of a process handle #' #' This function works even if the process has already finished. #' #' @param p Process handle. #' @return Process id. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_pid(p) #' ps_pid(p) == Sys.getpid() ps_pid <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_pid, p) } #' Start time of a process #' #' The pid and the start time pair serves as the identifier of the process, #' as process ids might be reused, but the chance of starting two processes #' with identical ids within the resolution of the timer is minimal. #' #' This function works even if the process has already finished. #' #' @param p Process handle. #' @return `POSIXct` object, start time, in GMT. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_create_time(p) ps_create_time <- function(p = ps_handle()) { assert_ps_handle(p) format_unix_time(.Call(psll_create_time, p)) } #' Checks whether a process is running #' #' It returns `FALSE` if the process has already finished. #' #' It uses the start time of the process to work around pid reuse. I.e. # it returns the correct answer, even if the process has finished and # its pid was reused. #' #' @param p Process handle. #' @return Logical scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_is_running(p) ps_is_running <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_is_running, p) } #' Parent pid or parent process of a process #' #' `ps_ppid()` returns the parent pid, `ps_parent()` returns a `ps_handle` #' of the parent. #' #' On POSIX systems, if the parent process terminates, another process #' (typically the pid 1 process) is marked as parent. `ps_ppid()` and #' `ps_parent()` will return this process then. #' #' Both `ps_ppid()` and `ps_parent()` work for zombie processes. #' #' @param p Process handle. #' @return `ps_ppid()` returns and integer scalar, the pid of the parent #' of `p`. `ps_parent()` returns a `ps_handle`. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_ppid(p) #' ps_parent(p) ps_ppid <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_ppid, p) } #' @rdname ps_ppid #' @export ps_parent <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_parent, p) } #' Process name #' #' The name of the program, which is typically the name of the executable. #' #' On Unix this can change, e.g. via an exec*() system call. #' #' `ps_name()` works on zombie processes. #' #' @param p Process handle. #' @return Character scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_name(p) #' ps_exe(p) #' ps_cmdline(p) ps_name <- function(p = ps_handle()) { assert_ps_handle(p) n <- .Call(psll_name, p) if (nchar(n) >= 15) { ## On UNIX the name gets truncated to the first 15 characters. ## If it matches the first part of the cmdline we return that ## one instead because it's usually more explicative. ## Examples are "gnome-keyring-d" vs. "gnome-keyring-daemon". ## In addition, under qemu (e.g. in cross-platform Docker), the ## first entry is qemu and the second entry is the file name cmdline <- tryCatch( ps_cmdline(p), error = function(e) NULL ) if (!is.null(cmdline) && length(cmdline) > 0L) { exname <- basename(cmdline[1]) if (str_starts_with(exname, n)) { n <- exname } else if (grepl("qemu", exname) && length(cmdline) >= 2 && str_starts_with(exname2 <- basename(cmdline[2]), n)) { n <- exname2 } } } n } #' Full path of the executable of a process #' #' Path to the executable of the process. May also be an empty string or #' `NA` if it cannot be determined. #' #' For a zombie process it throws a `zombie_process` error. #' #' @param p Process handle. #' @return Character scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_name(p) #' ps_exe(p) #' ps_cmdline(p) ps_exe <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_exe, p) } #' Command line of the process #' #' Command line of the process, i.e. the executable and the command line #' arguments, in a character vector. On Unix the program might change its #' command line, and some programs actually do it. #' #' For a zombie process it throws a `zombie_process` error. #' #' @param p Process handle. #' @return Character vector. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_name(p) #' ps_exe(p) #' ps_cmdline(p) ps_cmdline <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_cmdline, p) } #' Current process status #' #' One of the following: #' * `"idle"`: Process being created by fork, or process has been sleeping #' for a long time. macOS only. #' * `"running"`: Currently runnable on macOS and Windows. Actually #' running on Linux. #' * `"sleeping"` Sleeping on a wait or poll. #' * `"disk_sleep"` Uninterruptible sleep, waiting for an I/O operation #' (Linux only). #' * `"stopped"` Stopped, either by a job control signal or because it #' is being traced. #' * `"uninterruptible"` Process is in uninterruptible wait. macOS only. #' * `"tracing_stop"` Stopped for tracing (Linux only). #' * `"zombie"` Zombie. Finished, but parent has not read out the exit #' status yet. #' * `"dead"` Should never be seen (Linux). #' * `"wake_kill"` Received fatal signal (Linux only). #' * `"waking"` Paging (Linux only, not valid since the 2.6.xx kernel). #' #' It might return `NA_character_` on macOS. #' #' Works for zombie processes. #' #' @section Note on macOS: #' On macOS `ps_status()` often falls back to calling the external `ps` #' program, because macOS does not let R access the status of most other #' processes. Notably, it is usually able to access the status of other R #' processes. #' #' The external `ps` program always runs as the root user, and #' it also has special entitlements, so it can typically access the status #' of most processes. #' #' If this behavior is problematic for you, e.g. because calling an #' external program is too slow, set the `ps.no_external_ps` option to #' `TRUE`: #' ``` #' options(ps.no_external_ps = TRUE) #' ``` #' Note that setting this option to `TRUE` will cause `ps_status()` to #' return `NA_character_` for most processes. #' #' @param p Process handle. #' @return Character scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_status(p) ps_status <- function(p = ps_handle()) { assert_ps_handle(p) ret <- .Call(psll_status, p) if (is.na(ret) && ps_os_type()[["MACOS"]] && !isTRUE(getOption("ps.no_external_ps"))) { ret <- ps_status_macos_ps(ps_pid(p)) } ret } #' Owner of the process #' #' The name of the user that owns the process. On Unix it is calculated #' from the real user id. #' #' On Unix, a numeric uid id returned if the uid is not in the user #' database, thus a username cannot be determined. #' #' Works for zombie processes. #' #' @param p Process handle. #' @return String scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_username(p) ps_username <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_username, p) } #' Process current working directory as an absolute path. #' #' For a zombie process it throws a `zombie_process` error. #' #' @param p Process handle. #' @return String scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_cwd(p) ps_cwd <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_cwd, p) } #' User ids and group ids of the process #' #' User ids and group ids of the process. Both return integer vectors with #' names: `real`, `effective` and `saved`. #' #' Both work for zombie processes. #' #' They are not implemented on Windows, they throw a `not_implemented` #' error. #' #' @param p Process handle. #' @return Named integer vector of length 3, with names: `real`, #' `effective` and `saved`. #' #' @seealso [ps_username()] returns a user _name_ and works on all #' platforms. #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ps::ps_os_type()["POSIX"] && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_uids(p) #' ps_gids(p) ps_uids <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_uids, p) } #' @rdname ps_uids #' @export ps_gids <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_gids, p) } #' Terminal device of the process #' #' Returns the terminal of the process. Not implemented on Windows, always #' returns `NA_character_`. On Unix it returns `NA_character_` if the #' process has no terminal. #' #' Works for zombie processes. #' #' @param p Process handle. #' @return Character scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_terminal(p) ps_terminal <- function(p = ps_handle()) { assert_ps_handle(p) ttynr <- .Call(psll_terminal, p) if (is.character(ttynr)) { ttynr } else if (is.na(ttynr)) { NA_character_ } else { tmap <- get_terminal_map() tmap[[as.character(ttynr)]] } } #' Environment variables of a process #' #' `ps_environ()` returns the environment variables of the process, in a #' named vector, similarly to the return value of `Sys.getenv()` #' (without arguments). #' #' Note: this usually does not reflect changes made after the process #' started. #' #' `ps_environ_raw()` is similar to `p$environ()` but returns the #' unparsed `"var=value"` strings. This is faster, and sometimes good #' enough. #' #' These functions throw a `zombie_process` error for zombie processes. #' #' @section macOS issues: #' #' `ps_environ()` usually does not work on macOS nowadays. This is because #' macOS does not allow reading the environment variables of another #' process. Accoding to the Darwin source code, `ps_environ` will work is #' one of these conditions hold: #' #' * You are running a development or debug kernel, i.e. if you are #' debugging the macOS kernel itself. #' * The target process is same as the calling process. #' * SIP if off. #' * The target process is not restricted, e.g. it is running a binary #' that was not signed. #' * The calling process has the #' `com.apple.private.read-environment-variables` entitlement. However #' adding this entitlement to the R binary makes R crash on startup. #' #' Otherwise `ps_environ` will return an empty set of environment variables #' on macOS. #' #' Issue 121 might have more information about this. #' #' @param p Process handle. #' @return `ps_environ()` returns a named character vector (that has a #' `Dlist` class, so it is printed nicely), `ps_environ_raw()` returns a #' character vector. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' env <- ps_environ(p) #' env[["R_HOME"]] ps_environ <- function(p = ps_handle()) { assert_ps_handle(p) parse_envs(.Call(psll_environ, p)) } #' @rdname ps_environ #' @export ps_environ_raw <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_environ, p) } #' Number of threads #' #' Throws a `zombie_process()` error for zombie processes. #' #' @param p Process handle. #' @return Integer scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_num_threads(p) ps_num_threads <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_num_threads, p) } #' CPU times of the process #' #' All times are measured in seconds: #' * `user`: Amount of time that this process has been scheduled in user #' mode. #' * `system`: Amount of time that this process has been scheduled in #' kernel mode #' * `children_user`: On Linux, amount of time that this process's #' waited-for children have been scheduled in user mode. #' * `children_system`: On Linux, Amount of time that this process's #' waited-for children have been scheduled in kernel mode. #' #' Throws a `zombie_process()` error for zombie processes. #' #' @param p Process handle. #' @return Named real vector or length four: `user`, `system`, #' `children_user`, `children_system`. The last two are `NA` on #' non-Linux systems. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_cpu_times(p) #' proc.time() ps_cpu_times <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_cpu_times, p) } #' Memory usage information #' #' @details #' #' `ps_memory_info()` returns information about memory usage. #' #' It returns a named vector. Portable fields: #' * `rss`: "Resident Set Size", this is the non-swapped physical memory a #' process has used (bytes). On UNIX it matches "top"‘s 'RES' column (see doc). On #' Windows this is an alias for `wset` field and it matches "Memory" #' column of `taskmgr.exe`. #' * `vmem`: "Virtual Memory Size", this is the total amount of virtual #' memory used by the process (bytes). On UNIX it matches "top"‘s 'VIRT' column #' (see doc). On Windows this is an alias for the `pagefile` field and #' it matches the "Working set (memory)" column of `taskmgr.exe`. #' #' Non-portable fields: #' * `shared`: (Linux) memory that could be potentially shared with other #' processes (bytes). This matches "top"‘s 'SHR' column (see doc). #' * `text`: (Linux): aka 'TRS' (text resident set) the amount of memory #' devoted to executable code (bytes). This matches "top"‘s 'CODE' column (see #' doc). #' * `data`: (Linux): aka 'DRS' (data resident set) the amount of physical #' memory devoted to other than executable code (bytes). It matches "top"‘s #' 'DATA' column (see doc). #' * `lib`: (Linux): the memory used by shared libraries (bytes). #' * `dirty`: (Linux): the amount of memory in dirty pages (bytes). #' * `pfaults`: (macOS): number of page faults. #' * `pageins`: (macOS): number of actual pageins. #' #' For the explanation of Windows fields see the #' [PROCESS_MEMORY_COUNTERS_EX](https://learn.microsoft.com/en-us/windows/win32/api/psapi/ns-psapi-process_memory_counters_ex) #' structure. #' #' `ps_memory_full_info()` returns all fields as `ps_memory_info()`, plus #' additional information, but typically takes slightly longer to run, and #' might not have access to some processes that `ps_memory_info()` can #' query: #' #' * `maxrss` maximum resident set size over the process's lifetime. This #' only works for the calling process, otherwise it is `NA_real_`. #' * `uss`: Unique Set Size, this is the memory which is unique to a #' process and which would be freed if the process was terminated right #' now. #' * `pss` (Linux only): Proportional Set Size, is the amount of memory #' shared with other processes, accounted in a way that the amount is #' divided evenly between the processes that share it. I.e. if a process #' has 10 MBs all to itself and 10 MBs shared with another process its #' PSS will be 15 MBs. #' * `swap` (Linux only): amount of memory that has been swapped out to #' disk. #' #' They both throw a `zombie_process()` error for zombie processes. #' #' @param p Process handle. #' @return Named real vector. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' p #' ps_memory_info(p) #' ps_memory_full_info(p) ps_memory_info <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_memory_info, p) } #' @export #' @rdname ps_memory_info ps_memory_full_info <- function(p = ps_handle()) { assert_ps_handle(p) info <- ps_memory_info(p) info[["maxrss"]] <- if (Sys.getpid() == ps_pid(p)) { .Call(psll_memory_maxrss, p) } else { NA_real_ } type <- ps_os_type() if (type[["LINUX"]]) { match <- function(re) { mt <- gregexpr(re, smaps, perl = TRUE)[[1]] st <- substring( smaps, attr(mt, "capture.start"), attr(mt, "capture.start") + attr(mt, "capture.length") - 1 ) sum(as.integer(st), na.rm = TRUE) * 1024 } smaps <- .Call(ps__memory_maps, p) info[["uss"]] <- match("\nPrivate.*:\\s+(\\d+)") info[["pss"]] <- match("\nPss:\\s+(\\d+)") info[["swap"]] <- match("\nSwap:\\s+(\\d+)") } else if (type[["MACOS"]]) { info[["uss"]] <- .Call(psll_memory_uss, p) } else if (type[["WINDOWS"]]) { info[["uss"]] <- .Call(psll_memory_uss, p) } info } process_signal_result <- function(p, res, err_msg) { ok <- map_lgl(res, function(x) is.character(x) || is.null(x)) if (all(ok)) { unlist(res) } else { for (i in which(!ok)) { class(res[[i]]) <- res[[i]][[2]] } pids <- map_int(res[!ok], function(x) x[["pid"]] %||% NA_integer_) nms <- map_chr(p[!ok], function(pp) { tryCatch(ps_name(pp), error = function(e) "???") }) pmsg <- paste0(pids, " (", nms, ")", collapse = ", ") # put these classes at the end common <- c("ps_error", "error", "condition") cls <- c( unique(setdiff(unlist(lapply(res[!ok], function(x) class(x))), common)), common ) err <- structure( list( message = paste0( err_msg, if (length(p) == 1) ": " else " some processes: ", pmsg ), results = res, pid = pids ), class = cls ) stop(err) } } #' Send signal to a process #' #' Send a signal to the process. Not implemented on Windows. See #' [signals()] for the list of signals on the current platform. #' #' It checks if the process is still running, before sending the signal, #' to avoid signalling the wrong process, because of pid reuse. #' #' @param p Process handle, or a list of process handles. #' @param sig Signal number, see [signals()]. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ps::ps_os_type()["POSIX"] && ! ps:::is_cran_check() #' px <- processx::process$new("sleep", "10") #' p <- ps_handle(px$get_pid()) #' p #' ps_send_signal(p, signals()$SIGINT) #' p #' ps_is_running(p) #' px$get_exit_status() ps_send_signal <- function(p = ps_handle(), sig) { p <- assert_ps_handle_or_handle_list(p) assert_signal(sig) res <- lapply(p, function(pp) { tryCatch( .Call(psll_send_signal, pp, sig), error = function(e) e ) }) process_signal_result(p, res, "Failed to send signal to") } #' Suspend (stop) the process #' #' Suspend process execution with `SIGSTOP` preemptively checking #' whether PID has been reused. On Windows this has the effect of #' suspending all process threads. #' #' @param p Process handle or a list of process handles. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ps::ps_os_type()["POSIX"] && ! ps:::is_cran_check() #' px <- processx::process$new("sleep", "10") #' p <- ps_handle(px$get_pid()) #' p #' ps_suspend(p) #' ps_status(p) #' ps_resume(p) #' ps_status(p) #' ps_kill(p) ps_suspend <- function(p = ps_handle()) { p <- assert_ps_handle_or_handle_list(p) res <- lapply(p, function(pp) { tryCatch( .Call(psll_suspend, pp), error = function(e) e ) }) process_signal_result(p, res, "Failed to suspend") } #' Resume (continue) a stopped process #' #' Resume process execution with SIGCONT preemptively checking #' whether PID has been reused. On Windows this has the effect of resuming #' all process threads. #' #' @param p Process handle or a list of process handles. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ps::ps_os_type()["POSIX"] && ! ps:::is_cran_check() #' px <- processx::process$new("sleep", "10") #' p <- ps_handle(px$get_pid()) #' p #' ps_suspend(p) #' ps_status(p) #' ps_resume(p) #' ps_status(p) #' ps_kill(p) ps_resume <- function(p = ps_handle()) { p <- assert_ps_handle_or_handle_list(p) res <- lapply(p, function(pp) { tryCatch( .Call(psll_resume, pp), error = function(e) e ) }) process_signal_result(p, res, "Failed to resume") } #' Terminate a Unix process #' #' Send a `SIGTERM` signal to the process. Not implemented on Windows. #' #' Checks if the process is still running, to work around pid reuse. #' #' @param p Process handle or a list of process handles. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ps::ps_os_type()["POSIX"] && ! ps:::is_cran_check() #' px <- processx::process$new("sleep", "10") #' p <- ps_handle(px$get_pid()) #' p #' ps_terminate(p) #' p #' ps_is_running(p) #' px$get_exit_status() ps_terminate <- function(p = ps_handle()) { p <- assert_ps_handle_or_handle_list(p) res <- lapply(p, function(pp) { tryCatch( .Call(psll_terminate, pp), error = function(e) e ) }) process_signal_result(p, res, "Failed to terminate") } #' Kill one or more processes #' #' Kill the process with SIGKILL preemptively checking whether PID has #' been reused. On Windows it uses `TerminateProcess()`. #' #' Note that since ps version 1.8, `ps_kill()` does not error if the #' `p` process (or some processes if `p` is a list) are already terminated. #' #' @param p Process handle, or a list of process handles. #' @param grace Grace period, in milliseconds, used on Unix. If it is not #' zero, then `ps_kill()` first sends a `SIGTERM` signal to all processes #' in `p`. If some proccesses do not terminate within `grace` #' milliseconds after the `SIGTERM` signal, `ps_kill()` kills them by #' sending `SIGKILL` signals. #' @return Character vector, with one element for each process handle in #' `p`. If the process was already dead before `ps_kill()` tried to kill #' it, the corresponding return value is `"dead"`. If `ps_kill()` just #' killed it, it is `"killed"`. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ps::ps_os_type()["POSIX"] && ! ps:::is_cran_check() #' px <- processx::process$new("sleep", "10") #' p <- ps_handle(px$get_pid()) #' p #' ps_kill(p) #' p #' ps_is_running(p) #' px$get_exit_status() ps_kill <- function(p = ps_handle(), grace = 200) { p <- assert_ps_handle_or_handle_list(p) grace <- assert_grace(grace) if (ps_os_type()[["WINDOWS"]]) { res <- lapply(p, function(pp) { tryCatch({ if (ps_is_running(pp)) { .Call(psll_kill, pp, 0L) "killed" } else { "dead" } }, error = function(e) { if (inherits(e, "no_such_process")) "dead" else e }) }) } else { res <- call_with_cleanup(psll_kill, p, grace) } process_signal_result(p, res, "Failed to kill") } #' List of child processes (process objects) of the process. Note that #' this typically requires enumerating all processes on the system, so #' it is a costly operation. #' #' @param p Process handle. #' @param recursive Whether to include the children of the children, etc. #' @return List of `ps_handle` objects. #' #' @family process handle functions #' @export #' @importFrom utils head tail #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_parent(ps_handle()) #' ps_children(p) ps_children <- function(p = ps_handle(), recursive = FALSE) { assert_ps_handle(p) assert_flag(recursive) mypid <- ps_pid(p) mytime <- ps_create_time(p) map <- ps_ppid_map() ret <- list() if (!recursive) { for (i in seq_len(nrow(map))) { if (map$ppid[i] == mypid) { tryCatch({ child <- ps_handle(map$pid[i]) if (mytime <= ps_create_time(child)) { ret <- c(ret, child) } }, no_such_process = function(e) NULL, zombie_process = function(e) NULL) } } } else { seen <- integer() stack <- mypid while (length(stack)) { pid <- tail(stack, 1) stack <- head(stack, -1) if (pid %in% seen) next # nocov (happens _very_ rarely) seen <- c(seen, pid) child_pids <- map[ map[,2] == pid, 1] for (child_pid in child_pids) { tryCatch({ child <- ps_handle(child_pid) if (mytime <= ps_create_time(child)) { ret <- c(ret, child) stack <- c(stack, child_pid) } }, no_such_process = function(e) NULL, zombie_process = function(e) NULL) } } } ## This will throw if p has finished ps_ppid(p) ret } #' Query the ancestry of a process #' #' Query the parent processes recursively, up to the first process. #' (On some platforms, like Windows, the process tree is not a tree #' and may contain loops, in which case `ps_descent()` only goes up #' until the first repetition.) #' #' @param p Process handle. #' @return A list of process handles, starting with `p`, each one #' is the parent process of the previous one. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' ps_descent() ps_descent <- function(p = ps_handle()) { assert_ps_handle(p) windows <- ps_os_type()[["WINDOWS"]] branch <- list() branch_pids <- integer() current <- p current_pid <- ps_pid(p) if (windows) current_time <- ps_create_time(p) while (TRUE) { branch <- c(branch, list(current)) branch_pids <- c(branch_pids, current_pid) parent <- fallback(ps_parent(current), NULL) # Might fail on Windows, if the process does not exist if (is.null(parent)) break; # If the parent pid is the same, we stop. # Also, Windows might have loops parent_pid <- ps_pid(parent) if (parent_pid %in% branch_pids) break; # Need to check for pid reuse on Windows if (windows) { parent_time <- ps_create_time(parent) if (current_time <= parent_time) break current_time <- parent_time } current <- parent current_pid <- parent_pid } branch } ps_ppid_map <- function() { pids <- ps_pids() processes <- not_null(lapply(pids, function(p) { tryCatch(ps_handle(p), error = function(e) NULL) })) pids <- map_int(processes, ps_pid) ppids <- map_int(processes, function(p) fallback(ps_ppid(p), NA_integer_)) ok <- !is.na(ppids) data_frame( pid = pids[ok], ppid = ppids[ok] ) } #' Number of open file descriptors #' #' Note that in some IDEs, e.g. RStudio or R.app on macOS, the IDE itself #' opens files from other threads, in addition to the files opened from the #' main R thread. #' #' For a zombie process it throws a `zombie_process` error. #' #' @param p Process handle. #' @return Integer scalar. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' ps_num_fds(p) #' f <- file(tmp <- tempfile(), "w") #' ps_num_fds(p) #' close(f) #' unlink(tmp) #' ps_num_fds(p) ps_num_fds <- function(p = ps_handle()) { assert_ps_handle(p) .Call(psll_num_fds, p) } #' Open files of a process #' #' Note that in some IDEs, e.g. RStudio or R.app on macOS, the IDE itself #' opens files from other threads, in addition to the files opened from the #' main R thread. #' #' For a zombie process it throws a `zombie_process` error. #' #' @param p Process handle. #' @return Data frame with columns: `fd` and `path`. `fd` is numeric #' file descriptor on POSIX systems, `NA` on Windows. `path` is an #' absolute path to the file. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' ps_open_files(p) #' f <- file(tmp <- tempfile(), "w") #' ps_open_files(p) #' close(f) #' unlink(tmp) #' ps_open_files(p) ps_open_files <- function(p = ps_handle()) { assert_ps_handle(p) l <- not_null(.Call(psll_open_files, p)) d <- data_frame( fd = vapply(l, "[[", integer(1), 2), path = vapply(l, "[[", character(1), 1)) d } #' List network connections of a process #' #' For a zombie process it throws a `zombie_process` error. #' #' @param p Process handle. #' @return Data frame, with columns: #' * `fd`: integer file descriptor on POSIX systems, `NA` on Windows. #' * `family`: Address family, string, typically `AF_UNIX`, `AF_INET` or #' `AF_INET6`. #' * `type`: Socket type, string, typically `SOCK_STREAM` (TCP) or #' `SOCK_DGRAM` (UDP). #' * `laddr`: Local address, string, `NA` for UNIX sockets. #' * `lport`: Local port, integer, `NA` for UNIX sockets. #' * `raddr`: Remote address, string, `NA` for UNIX sockets. This is #' always `NA` for `AF_INET` sockets on Linux. #' * `rport`: Remote port, integer, `NA` for UNIX sockets. #' * `state`: Socket state, e.g. `CONN_ESTABLISHED`, etc. It is `NA` #' for UNIX sockets. #' #' @family process handle functions #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() #' p <- ps_handle() #' ps_connections(p) #' sc <- socketConnection("httpbin.org", port = 80) #' ps_connections(p) #' close(sc) #' ps_connections(p) ps_connections <- function(p = ps_handle()) { assert_ps_handle(p) if (ps_os_type()[["LINUX"]]) return(psl_connections(p)) l <- not_null(.Call(psll_connections, p)) d <- data_frame( fd = vapply(l, "[[", integer(1), 1), family = match_names(ps_env$constants$address_families, vapply(l, "[[", integer(1), 2)), type = match_names(ps_env$constants$socket_types, vapply(l, "[[", integer(1), 3)), laddr = vapply(l, "[[", character(1), 4), lport = vapply(l, "[[", integer(1), 5), raddr = vapply(l, "[[", character(1), 6), rport = vapply(l, "[[", integer(1), 7), state = match_names(ps_env$constants$tcp_statuses, vapply(l, "[[", integer(1), 8))) d$laddr[d$laddr == ""] <- NA_character_ d$raddr[d$raddr == ""] <- NA_character_ d$lport[d$lport == 0] <- NA_integer_ d$rport[d$rport == 0] <- NA_integer_ d } #' Interrupt a process #' #' Sends `SIGINT` on POSIX, and 'CTRL+C' or 'CTRL+BREAK' on Windows. #' #' @param p Process handle or a list of process handles. #' @param ctrl_c On Windows, whether to send 'CTRL+C'. If `FALSE`, then #' 'CTRL+BREAK' is sent. Ignored on non-Windows platforms. #' #' @family process handle functions #' @export ps_interrupt <- function(p = ps_handle(), ctrl_c = TRUE) { p <- assert_ps_handle_or_handle_list(p) assert_flag(ctrl_c) res <- lapply(p, function(pp) { tryCatch({ if (ps_os_type()[["WINDOWS"]]) { interrupt <- get_tool("interrupt") .Call(psll_interrupt, pp, ctrl_c, interrupt) } else { .Call(psll_interrupt, pp, ctrl_c, NULL) } }, error = function(e) e) }) process_signal_result(p, res, "Failed to interrupt") } #' @return `ps_windows_nice_values()` return a character vector of possible #' priority values on Windows. #' @export #' @rdname ps_get_nice ps_windows_nice_values <- function() { c("realtime", "high", "above_normal", "normal", "idle", "below_normal") } #' Get or set the priority of a process #' #' `ps_get_nice()` returns the current priority, `ps_set_nice()` sets a #' new priority, `ps_windows_nice_values()` list the possible priority #' values on Windows. #' #' Priority values are different on Windows and Unix. #' #' On Unix, priority is an integer, which is maximum 20. 20 is the lowest #' priority. #' #' ## Rules: #' * On Windows you can only set the priority of the processes the current #' user has `PROCESS_SET_INFORMATION` access rights to. This typically #' means your own processes. #' * On Unix you can only set the priority of the your own processes. #' The superuser can set the priority of any process. #' * On Unix you cannot set a higher priority, unless you are the superuser. #' (I.e. you cannot set a lower number.) #' * On Unix the default priority of a process is zero. #' #' @param p Process handle. #' @return `ps_get_nice()` returns a string from #' `ps_windows_nice_values()` on Windows. On Unix it returns an integer #' smaller than or equal to 20. #' #' @export ps_get_nice <- function(p = ps_handle()) { assert_ps_handle(p) code <- .Call(psll_get_nice, p) if (ps_os_type()[["WINDOWS"]]) { ps_windows_nice_values()[code] } else { code } } #' @param value On Windows it must be a string, one of the values of #' `ps_windows_nice_values()`. On Unix it is a priority value that is #' smaller than or equal to 20. #' @return `ps_set_nice()` return `NULL` invisibly. #' #' @export #' @rdname ps_get_nice ps_set_nice <- function(p = ps_handle(), value) { assert_ps_handle(p) assert_nice_value(value) if (ps_os_type()[["POSIX"]]) { value <- as.integer(value) } else { value <- match(value, ps_windows_nice_values()) } invisible(.Call(psll_set_nice, p, value)) } #' List the dynamically loaded libraries of a process #' #' Note: this function currently only works on Windows. #' @param p Process handle. #' @return Data frame with one column currently: `path`, the #' absolute path to the loaded module or shared library. On Windows #' the list includes the executable file itself. #' #' @export #' @family process handle functions #' @family shared library tools #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() && ps::ps_os_type()[["WINDOWS"]] #' # The loaded DLLs of the current process #' ps_shared_libs() ps_shared_libs <- function(p = ps_handle()) { assert_ps_handle(p) if (!ps_os_type()[["WINDOWS"]]) { stop("`ps_shared_libs()` is currently only supported on Windows") } l <- .Call(psll_dlls, p) d <- data_frame( path = map_chr(l, "[[", 1) ) d } #' Query or set CPU affinity #' #' `ps_get_cpu_affinity()` queries the #' [CPU affinity](https://www.linuxjournal.com/article/6799?page=0,0) of #' a process. `ps_set_cpu_affinity()` sets the CPU affinity of a process. #' #' CPU affinity consists in telling the OS to run a process on a limited #' set of CPUs only (on Linux cmdline, the `taskset` command is typically #' used). #' #' These functions are only supported on Linux and Windows. They error on macOS. #' #' @param p Process handle. #' @param affinity Integer vector of CPU numbers to restrict a process to. #' CPU numbers start with zero, and they have to be smaller than the #' number of (logical) CPUs, see [ps_cpu_count()]. #' #' @return `ps_get_cpu_affinity()` returns an integer vector of CPU #' numbers, starting with zero. #' #' `ps_set_cpu_affinity()` returns `NULL`, invisibly. #' #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() && ! ps::ps_os_type()[["MACOS"]] #' # current #' orig <- ps_get_cpu_affinity() #' orig #' #' # restrict #' ps_set_cpu_affinity(affinity = 0:0) #' ps_get_cpu_affinity() #' #' # restore #' ps_set_cpu_affinity(affinity = orig) #' ps_get_cpu_affinity() ps_get_cpu_affinity <- function(p = ps_handle()) { assert_ps_handle(p) type <- ps_os_type() if (!type[["LINUX"]] && !type[["WINDOWS"]]) { stop("`ps_cpu_affinity()` is only supported on Windows and Linux") } .Call(psll_get_cpu_aff, p) } #' @export #' @rdname ps_get_cpu_affinity ps_set_cpu_affinity <- function(p = ps_handle(), affinity) { assert_ps_handle(p) type <- ps_os_type() if (!type[["LINUX"]] && !type[["WINDOWS"]]) { stop("`ps_cpu_affinity()` is only supported on Windows and Linux") } # check affinity values cnt <- ps_cpu_count() stopifnot(is.integer(affinity), all(affinity < cnt)) invisible(.Call(psll_set_cpu_aff, p, affinity)) } #' Wait for one or more processes to terminate, with a timeout #' #' This function supports interruption with SIGINT on Unix, or CTRL+C #' or CTRL+BREAK on Windows. #' #' @param p A process handle, or a list of process handles. The #' process(es) to wait for. #' @param timeout Timeout in milliseconds. If -1, `ps_wait()` will wait #' indefinitely (or until it is interrupted). If 0, then it checks which #' processes have already terminated, and returns immediately. #' @return Logical vector, with one value of each process in `p`. #' For processes that terminated it contains a `TRUE` value. For #' processes that are still running it contains a `FALSE` value. #' #' @export #' @examplesIf ps::ps_is_supported() && ! ps:::is_cran_check() && ps::ps_os_type()["POSIX"] #' # this example calls `sleep`, so it only works on Unix #' p1 <- processx::process$new("sleep", "100") #' p2 <- processx::process$new("sleep", "100") #' #' # returns c(FALSE, FALSE) immediately if p1 and p2 are running #' ps_wait(list(p1$as_ps_handle(), p2$as_ps_handle()), 0) #' #' # timeouts at one second #' ps_wait(list(p1$as_ps_handle(), p2$as_ps_handle()), 1000) #' #' p1$kill() #' p2$kill() #' # returns c(TRUE, TRUE) immediately #' ps_wait(list(p1$as_ps_handle(), p2$as_ps_handle()), 1000) ps_wait <- function(p, timeout = -1) { p <- assert_ps_handle_or_handle_list(p) timeout <- assert_integer(timeout) call_with_cleanup(psll_wait, p, timeout) } ps/R/kill-tree.R0000644000176200001440000001207314665030515013120 0ustar liggesusers #' Mark a process and its (future) child tree #' #' `ps_mark_tree()` generates a random environment variable name and sets #' it in the current R process. This environment variable will be (by #' default) inherited by all child (and grandchild, etc.) processes, and #' will help finding these processes, even if and when they are (no longer) #' related to the current R process. (I.e. they are not connected in the #' process tree.) #' #' `ps_find_tree()` finds the processes that set the supplied environment #' variable and returns them in a list. #' #' `ps_kill_tree()` finds the processes that set the supplied environment #' variable, and kills them (or sends them the specified signal on Unix). #' #' `with_process_cleanup()` evaluates an R expression, and cleans up all #' external processes that were started by the R process while evaluating #' the expression. This includes child processes of child processes, etc., #' recursively. It returns a list with entries: `result` is the result of #' the expression, `visible` is TRUE if the expression should be printed #' to the screen, and `process_cleanup` is a named integer vector of the #' cleaned pids, names are the process names. #' #' If `expr` throws an error, then so does `with_process_cleanup()`, the #' same error. Nevertheless processes are still cleaned up. #' #' @section Note: #' Note that `with_process_cleanup()` is problematic if the R process is #' multi-threaded and the other threads start subprocesses. #' `with_process_cleanup()` cleans up those processes as well, which is #' probably not what you want. This is an issue for example in RStudio. #' Do not use `with_process_cleanup()`, unless you are sure that the #' R process is single-threaded, or the other threads do not start #' subprocesses. E.g. using it in package test cases is usually fine, #' because RStudio runs these in a separate single-threaded process. #' #' The same holds for manually running `ps_mark_tree()` and then #' `ps_find_tree()` or `ps_kill_tree()`. #' #' A safe way to use process cleanup is to use the processx package to #' start subprocesses, and set the `cleanup_tree = TRUE` in #' [processx::run()] or the [processx::process] constructor. #' #' @return `ps_mark_tree()` returns the name of the environment variable, #' which can be used as the `marker` in `ps_kill_tree()`. #' #' `ps_find_tree()` returns a list of `ps_handle` objects. #' #' `ps_kill_tree()` returns the pids of the killed processes, in a named #' integer vector. The names are the file names of the executables, when #' available. #' #' `with_process_cleanup()` returns the value of the evaluated expression. #' #' @rdname ps_kill_tree #' @export ps_mark_tree <- function() { id <- get_id() do.call(Sys.setenv, structure(list("YES"), names = id)) id } get_id <- function() { paste0( "PS", paste( sample(c(LETTERS, 0:9), 10, replace = TRUE), collapse = "" ), "_", as.integer(Internal(Sys.time())) ) } #' @param expr R expression to evaluate in the new context. #' #' @rdname ps_kill_tree #' @export with_process_cleanup <- function(expr) { id <- ps_mark_tree() stat <- NULL do <- function() { on.exit(stat <<- ps_kill_tree(id), add = TRUE) withVisible(expr) } res <- do() ret <- list( result = res$value, visible = res$visible, process_cleanup = stat) class(ret) <- "with_process_cleanup" ret } #' @export print.with_process_cleanup <- function(x, ...) { if (x$visible) print(x$result) if (length(x$process_cleanup)) { cat("!! Cleaned up the following processes:\n") print(x$process_cleanup) } else { cat("-- No leftover processes to clean up.\n") } invisible(x) } #' @rdname ps_kill_tree #' @export ps_find_tree <- function(marker) { assert_string(marker) after <- as.numeric(strsplit(marker, "_", fixed = TRUE)[[1]][2]) pids <- setdiff(ps_pids(), Sys.getpid()) not_null(lapply(pids, function(p) { tryCatch( .Call(ps__find_if_env, marker, after, p), error = function(e) NULL ) })) } #' @param marker String scalar, the name of the environment variable to #' use to find the marked processes. #' @param sig The signal to send to the marked processes on Unix. On #' Windows this argument is ignored currently. #' @param grace Grace period, in milliseconds, used on Unix, if `sig` is #' `SIGKILL`. If it is not zero, then `ps_kill_tree()` first sends a #' `SIGTERM` signal to all processes. If some proccesses do not #' terminate within `grace` milliseconds after the `SIGTERM` signal, #' `ps_kill_tree()` kills them by sending `SIGKILL` signals. #' #' @rdname ps_kill_tree #' @export ps_kill_tree <- function(marker, sig = signals()$SIGKILL, grace = 200) { # NULL on Windows if (!ps_os_type()[["WINDOWS"]]) { sig <- assert_integer(sig) } procs <- ps_find_tree(marker) pids <- map_int(procs, ps_pid) nms <- map_chr( procs, function(p) tryCatch(ps_name(p), error = function(e) "???") ) if (!ps_os_type()[["WINDOWS"]] && sig == signals()$SIGKILL) { ps_send_signal(procs, sig) } else { ps_kill(procs, grace = grace) } structure(pids, names = nms) } ps/R/iso-date.R0000644000176200001440000001124214665545712012744 0ustar liggesusers milliseconds <- function(x) as.difftime(as.numeric(x) / 1000, units = "secs") seconds <- function(x) as.difftime(as.numeric(x), units = "secs") minutes <- function(x) as.difftime(as.numeric(x), units = "mins") hours <- function(x) as.difftime(as.numeric(x), units = "hours") days <- function(x) as.difftime(as.numeric(x), units = "days") weeks <- function(x) as.difftime(as.numeric(x), units = "weeks") wday <- function(x) as.POSIXlt(x, tz = "UTC")$wday + 1 with_tz <- function(x, tzone = "") as.POSIXct(as.POSIXlt(x, tz = tzone)) ymd <- function(x) as.POSIXct(x, format = "%Y %m %d", tz = "UTC") yj <- function(x) as.POSIXct(x, format = "%Y %j", tz = "UTC") parse_iso_8601 <- function(dates, default_tz = "UTC") { if (default_tz == "") default_tz <- Sys.timezone() dates <- as.character(dates) match <- re_match(dates, iso_regex) matching <- !is.na(match$.match) result <- rep(.POSIXct(NA_real_, tz = ""), length.out = length(dates)) result[matching] <- parse_iso_parts(match[matching, ], default_tz) class(result) <- c("POSIXct", "POSIXt") with_tz(result, "UTC") } parse_iso_parts <- function(mm, default_tz) { num <- nrow(mm) ## ----------------------------------------------------------------- ## Date first date <- .POSIXct(rep(NA_real_, num), tz = "") ## Years-days fyd <- is.na(date) & mm$yearday != "" date[fyd] <- yj(paste(mm$year[fyd], mm$yearday[fyd])) ## Years-weeks-days fywd <- is.na(date) & mm$week != "" & mm$weekday != "" date[fywd] <- iso_week(mm$year[fywd], mm$week[fywd], mm$weekday[fywd]) ## Years-weeks fyw <- is.na(date) & mm$week != "" date[fyw] <- iso_week(mm$year[fyw], mm$week[fyw], "1") ## Years-months-days fymd <- is.na(date) & mm$month != "" & mm$day != "" date[fymd] <- ymd(paste(mm$year[fymd], mm$month[fymd], mm$day[fymd])) ## Years-months fym <- is.na(date) & mm$month != "" date[fym] <- ymd(paste(mm$year[fym], mm$month[fym], "01")) ## Years fy <- is.na(date) date[fy] <- ymd(paste(mm$year, "01", "01")) ## ----------------------------------------------------------------- ## Now the time th <- mm$hour != "" date[th] <- date[th] + hours(mm$hour[th]) tm <- mm$min != "" date[tm] <- date[tm] + minutes(mm$min[tm]) ts <- mm$sec != "" date[ts] <- date[ts] + seconds(mm$sec[ts]) ## ----------------------------------------------------------------- ## Fractional time frac <- as.numeric(sub(",", ".", mm$frac)) tfs <- !is.na(frac) & mm$sec != "" date[tfs] <- date[tfs] + milliseconds(round(frac[tfs] * 1000)) tfm <- !is.na(frac) & mm$sec == "" & mm$min != "" sec <- trunc(frac[tfm] * 60) mil <- round((frac[tfm] * 60 - sec) * 1000) date[tfm] <- date[tfm] + seconds(sec) + milliseconds(mil) tfh <- !is.na(frac) & mm$sec == "" & mm$min == "" min <- trunc(frac[tfh] * 60) sec <- trunc((frac[tfh] * 60 - min) * 60) mil <- round((((frac[tfh] * 60) - min) * 60 - sec) * 1000) date[tfh] <- date[tfh] + minutes(min) + seconds(sec) + milliseconds(mil) ## ----------------------------------------------------------------- ## Time zone ftzpm <- mm$tzpm != "" m <- ifelse(mm$tzpm[ftzpm] == "+", -1, 1) ftzpmh <- ftzpm & mm$tzhour != "" date[ftzpmh] <- date[ftzpmh] + m * hours(mm$tzhour[ftzpmh]) ftzpmm <- ftzpm & mm$tzmin != "" date[ftzpmm] <- date[ftzpmm] + m * minutes(mm$tzmin[ftzpmm]) ftzz <- mm$tz == "Z" date[ftzz] <- as.POSIXct(date[ftzz], "UTC") ftz <- mm$tz != "Z" & mm$tz != "" date[ftz] <- as.POSIXct(date[ftz], mm$tz[ftz]) if (default_tz != "UTC") { ftna <- mm$tzpm == "" & mm$tz == "" if (any(ftna)) { dd <- as.POSIXct(format_iso_8601(date[ftna]), "%Y-%m-%dT%H:%M:%S+00:00", tz = default_tz) date[ftna] <- dd } } as.POSIXct(date, "UTC") } iso_regex <- paste0( "^\\s*", "(?[\\+-]?\\d{4}(?!\\d{2}\\b))", "(?:(?-?)", "(?:(?0[1-9]|1[0-2])", "(?:\\g{dash}(?[12]\\d|0[1-9]|3[01]))?", "|W(?[0-4]\\d|5[0-3])(?:-?(?[1-7]))?", "|(?00[1-9]|0[1-9]\\d|[12]\\d{2}|3", "(?:[0-5]\\d|6[1-6])))", "(?