diff --git a/DESCRIPTION b/DESCRIPTION index 2e47c29..56aedb3 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,6 +16,7 @@ BugReports: https://github.com/mengxu98/thisutils/issues Depends: R (>= 4.1.0) Imports: + callr, cli, doParallel, foreach, diff --git a/R/package_management.R b/R/package_management.R index 85d7584..3d95c15 100644 --- a/R/package_management.R +++ b/R/package_management.R @@ -12,6 +12,12 @@ #' and *LinkingTo*, excluding *Suggests*. #' @param force Whether to force the installation of packages. #' Default is `FALSE`. +#' @param install Whether missing or outdated packages may be installed. +#' Set to `FALSE` for read-only diagnostics. Default is `TRUE` for backward +#' compatibility. +#' @param timeout Maximum installation time in seconds. A finite timeout runs +#' installation in a supervised R subprocess and terminates only that process +#' tree on timeout. Default is `Inf`. #' @param load Whether to load packages after successful installation. #' Uses [do.call] dispatch to avoid CRAN static checks on [base::library]. #' Default is `FALSE`. @@ -24,9 +30,17 @@ check_r <- function( lib = .libPaths()[1], dependencies = NA, force = FALSE, + install = TRUE, + timeout = Inf, load = FALSE, verbose = TRUE ) { + if (!is.logical(install) || length(install) != 1L || is.na(install)) { + stop("`install` must be TRUE or FALSE", call. = FALSE) + } + if (!is.numeric(timeout) || length(timeout) != 1L || is.na(timeout) || timeout <= 0) { + stop("`timeout` must be one positive number or Inf", call. = FALSE) + } status_list <- list() error_details <- list() for (pkg in packages) { @@ -54,6 +68,15 @@ check_r <- function( force_update <- force_update || isTRUE(force) if (!check_pkg || force_update) { + if (!isTRUE(install)) { + status_list[[pkg_name]] <- FALSE + error_details[[pkg_name]] <- if (force_update && check_pkg) { + "the installed version does not satisfy the request and installation is disabled" + } else { + "the package is unavailable and installation is disabled" + } + next + } log_message( "Installing: {.pkg {pkg_name}}...", message_type = "running", @@ -65,25 +88,13 @@ check_r <- function( if (!dir.exists(lib)) { dir.create(lib, recursive = TRUE, showWarnings = FALSE) } - if (isTRUE(verbose)) { - pak::pkg_install( - pkg, - lib = lib, - ask = FALSE, - dependencies = dependencies - ) - } else { - invisible( - suppressMessages( - pak::pkg_install( - pkg, - lib = lib, - ask = FALSE, - dependencies = dependencies - ) - ) - ) - } + check_r_run_install( + pkg = pkg, + lib = lib, + dependencies = dependencies, + timeout = timeout, + verbose = verbose + ) }, error = function(e) { status_list[[pkg_name]] <- FALSE @@ -144,6 +155,67 @@ check_r <- function( return(invisible(status_list)) } +check_r_run_install <- function( + pkg, + lib, + dependencies = NA, + timeout = Inf, + verbose = TRUE +) { + process <- callr::r_bg( + func = function(pkg, lib, dependencies, verbose) { + install_call <- function() { + pak::pkg_install( + pkg, + lib = lib, + ask = FALSE, + dependencies = dependencies + ) + } + if (isTRUE(verbose)) { + install_call() + } else { + invisible(suppressMessages(install_call())) + } + invisible(TRUE) + }, + args = list( + pkg = pkg, + lib = lib, + dependencies = dependencies, + verbose = verbose + ), + libpath = unique(c(lib, .libPaths())), + stdout = "|", + stderr = "|", + supervise = TRUE, + package = FALSE + ) + on.exit({ + if (isTRUE(process$is_alive())) { + process$kill_tree() + } + }, add = TRUE) + + timeout_ms <- if (is.finite(timeout)) as.integer(min(timeout * 1000, .Machine$integer.max)) else -1L + process$wait(timeout = timeout_ms) + if (isTRUE(process$is_alive())) { + process$kill_tree() + stop( + sprintf("Package installation timed out after %s seconds: %s", format(timeout), pkg), + call. = FALSE + ) + } + if (isTRUE(verbose)) { + output <- process$read_all_output_lines() + errors <- process$read_all_error_lines() + if (length(output) > 0L) writeLines(output) + if (length(errors) > 0L) writeLines(errors, con = stderr()) + } + process$get_result() + invisible(TRUE) +} + load_packages <- function(pkgs, lib = .libPaths(), verbose = TRUE) { for (pkg in pkgs) { result <- tryCatch( diff --git a/man/check_r.Rd b/man/check_r.Rd index 6bec340..a1d8cf7 100644 --- a/man/check_r.Rd +++ b/man/check_r.Rd @@ -9,6 +9,8 @@ check_r( lib = .libPaths()[1], dependencies = NA, force = FALSE, + install = TRUE, + timeout = Inf, load = FALSE, verbose = TRUE ) @@ -28,6 +30,14 @@ and \emph{LinkingTo}, excluding \emph{Suggests}.} \item{force}{Whether to force the installation of packages. Default is \code{FALSE}.} +\item{install}{Whether missing or outdated packages may be installed. +Set to \code{FALSE} for read-only diagnostics. Default is \code{TRUE} for backward +compatibility.} + +\item{timeout}{Maximum installation time in seconds. A finite timeout runs +installation in a supervised R subprocess and terminates only that process +tree on timeout. Default is \code{Inf}.} + \item{load}{Whether to load packages after successful installation. Uses \link{do.call} dispatch to avoid CRAN static checks on \link[base:library]{base::library}. Default is \code{FALSE}.} diff --git a/tests/testthat/test-package-management.R b/tests/testthat/test-package-management.R index 75c5e6b..8a7d196 100644 --- a/tests/testthat/test-package-management.R +++ b/tests/testthat/test-package-management.R @@ -26,3 +26,44 @@ test_that("check_r loads each successful package from the requested library", { expect_identical(loaded, c("foo", "bar")) expect_identical(loaded_lib, lib) }) + +test_that("check_r supports read-only package diagnostics", { + install_called <- FALSE + testthat::local_mocked_bindings( + check_pkg_status = function(pkg, version = NULL, lib = NULL) FALSE, + check_r_run_install = function(...) { + install_called <<- TRUE + invisible(TRUE) + }, + .package = "thisutils" + ) + + status <- check_r( + c("missing", "owner/remote"), + install = FALSE, + verbose = FALSE + ) + + expect_identical(status, list(missing = FALSE, remote = FALSE)) + expect_false(install_called) +}) + +test_that("check_r forwards timeout to the supervised installer", { + observed_timeout <- NULL + testthat::local_mocked_bindings( + check_pkg_status = function(pkg, version = NULL, lib = NULL) FALSE, + check_r_run_install = function(pkg, lib, dependencies, timeout, verbose) { + observed_timeout <<- timeout + invisible(TRUE) + }, + .package = "thisutils" + ) + + check_r("missing", timeout = 2.5, verbose = FALSE) + expect_identical(observed_timeout, 2.5) +}) + +test_that("check_r validates installation controls", { + expect_error(check_r("stats", install = NA), "install") + expect_error(check_r("stats", timeout = 0), "timeout") +})