diff --git a/NEWS.md b/NEWS.md index 8536d9ef..4b9044fd 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,9 +1,12 @@ # packrat (development version) +- Update vendored `renv` to support recognition of Posit Package Manager + support for manylinux binaries. + - When restoring GitHub-hosted packages, packrat will now look for both `Github*` and `Remote*` fields to determine where to install from. (#740) -- When restoring packages from CRAN-like repositories, names are no +- When restoring packages from CRAN-like repositories, names are no longer used to detect if these are actually git-like. This prevents issues if you name a CRAN-like repository something like "GitHub". (#747) @@ -105,7 +108,7 @@ - The 'packrat::opts$ignored.packages()' project option ignores recursive package dependencies in addition to direct package dependencies. (#654) -- Use a bundled `renv` to perform dependency detection. Avoids a number of +- Use a bundled `renv` to perform dependency detection. Avoids a number of evaluation issues and side-effects. (#644) - Take an `renv` update to avoid an implicit dependency on the `quarto` package for all `*.qmd` content. @@ -150,7 +153,7 @@ - Added support for GitLab: packages downloaded from GitLab can now be restored by Packrat. (#562, @akgold) -- Fixed an issue where tangled R code chunks containing invalid R code prevented +- Fixed an issue where tangled R code chunks containing invalid R code prevented Packrat from finding any dependencies. Packrat will now look for package dependencies within each code chunk independently. (#551) @@ -163,7 +166,7 @@ - Fixed an issue where newly-added project options did not get their correct default value when no entry existed within the `packrat.opts` file. (#496) - + - Improve performance of dependency processing. (#615) - Infer package dependencies from `requireNamespace()` and `loadNamespace()` @@ -179,7 +182,7 @@ disable dependency discovery in projects. This can be useful if you find Packrat's dependency discovery is slow (as it can be in projects containing a large number of R Markdown files). (#513, @ras44) - + - The scheme used for hashing packages that enter the Packrat cache has changed -- now, a defined ordering of fields is used when hashing a package's DESCRIPTION file. Note that this implies a package may need to be @@ -258,7 +261,7 @@ - Packrat now screens out empty package names discovered during package dependency discovery. (#314) - + - The Packrat global cache is now enabled on Windows. Junction points (rather than symbolic links) are used to populate entries in the private Packrat library. @@ -301,12 +304,12 @@ - Packrat now provides APIs for accessing the active paths to resource directories, with: - + - `packrat::project_dir(project)` - `packrat::src_dir(project)` - `packrat::lib_dir(project)` - `packrat::bundles_dir(project)` - + See `?packrat-resources` for more details. - Packrat better preserves the pre-existing contents of ignore files. (#332) @@ -384,38 +387,38 @@ in the future once we have a reliable mechanism for detecting whether a particular directory is a reparse point without the use of compiled code within packrat. - + - Packrat uses `devtools` + `httr` (when available) to download files and directories from GitHub URLs. This should enable users to allow packrat to access private GitHub repositories as long as the `GITHUB_PAT` environment variable is set to an appropriate private access token. See `?devtools::install_github` for more details on setting up a private access token. - + - The `install_github()` shim from packrat has been removed -- please use `devtools::install_github()`, either by taking an explicit dependency on the `devtools` package, or by loading it from the user library with the packrat option `packrat::opts$external.packages("devtools")`. - + - Packrat is now smarter when managing symlinks within the project library (when package caching is enabled). This should allow multiple R processes to use the same packrat project at the same time. (Previously, there was risk that one R session might clear / refresh symlinks while another process attempted to access them). - + - Packrat no longer erroneously generates recursive symlinks (and attempts to clean up any recursive symlinks discovered as appropriate). - + - Packrat now records the original library paths within its `.onLoad()` handler, and uses these library paths when attempting to load packages from the user library. - + - Fixed a bug where recursive hashing of a package's LinkingTo dependencies could fail. - Fixed a bug where `with_extlib()` could force a promise in the wrong environment. - + # Packrat 0.4.6 - Packrat gains the option `snapshot.recommended.packages()`, to control @@ -452,7 +455,7 @@ - Packrat now understands the `pkgType = "both"` option and can properly restore projects when that option is set. - + - The `ignored.packages` option has been added, allowing users to specify packages that should not be tracked by packrat. Such packaes will not enter the lockfile on `packrat::snapshot()` calls; nor will they be @@ -460,7 +463,7 @@ - Simple functions for interacting with the set of available repositories have been added. See `?repository-management` for more details. - + - Facilities for interacting with local CRAN-like repositories have been added. This feature will eventually supersede the functionality offered by packrat's 'ad-hoc' local repositories. The functions `packrat::repos_create()` and @@ -473,7 +476,7 @@ - The cache directory layout has been modified to ensure help (`?`) calls succeed. This is a breaking change with older versions of Packrat, and so newer versions of Packrat will use a new cache folder. (#194) - + - Packrat issues a warning on `packrat::init()` if it was unable to infer the source of a particular package on initialization and instead uses the latest CRAN version. @@ -502,7 +505,7 @@ - Packrat properly infers whether a project is an R package. A project with a `DESCRIPTION` file that has no `Type:` field, or has the `Type: Package` field, will be considered as an `R` package. - + - Custom library paths can be set through the `R_PACKRAT_LIB_DIR` environment variable, which can be useful when using Packrat for non-local dependency management or deployment. @@ -512,7 +515,7 @@ - Symlinks to `R` packages are created and destroyed more conservatively; this should help prevent problems where multiple `R` processes are acting within a single Packrat project. - + - The autoloader was not properly created in rare cases (thanks, @krlmlr!) - `install_local()` now forces `lib` and `repos` to be passed as named arguments, @@ -679,25 +682,25 @@ have been `dot.cased`. We apologize for any broken workflows here; but we imagine that most of use of packrat is done through calls to exported functions with no arguments passed, so this shouldn't disrupt most workflows. - + - Packrat has introduced support for R packages -- you should now be able to develop R packages using packrat to manage your dependencies. Work here is on-going and feedback is appreciated. - + - `search_path()` allows you to discover which packages are currently `attach`ed, and from which library each package has been loaded from. - + - `status()` now (invisibly) returns a `data.frame` outlining the current status of your project, in addition to printing information to the console. - + - `packrat::on` now attempts to clean the search path when entering packrat mode. Any packages loaded from the user library will be unloaded before entering packrat mode. - + - The `init.R` script has been updated to work better with `bundle` / `unbundle`: after `bundle`ing a packrat project, one should be able to initialize a new project using a combination of `unbundle` and `source('packrat/init.R')`. - + - Migration scripts for Windows users have been added to packrat, to migrate user libraries away from the system library, to provide the library separation that Packrat requires. diff --git a/R/renv.R b/R/renv.R index 07630fbc..e2b1eb8f 100644 --- a/R/renv.R +++ b/R/renv.R @@ -1,11 +1,11 @@ # -# renv 1.0.3.9000 [rstudio/renv#1f5bafc]: A dependency management toolkit for R. -# Generated using `renv:::vendor()` at 2023-10-18 14:18:45.514687. +# renv 1.1.7 [rstudio/renv#53d868d]: A dependency management toolkit for R. +# Generated using `renv:::vendor()` at 2026-02-12 12:06:56.796845. # renv <- new.env(parent = new.env()) -renv$initialize <- function() { +renv$initialize <- function(libname, pkgname) { # set up renv + imports environments attr(renv, "name") <- "embedded:renv" attr(parent.env(renv), "name") <- "imports:renv" @@ -14,6 +14,8 @@ renv$initialize <- function() { imports <- list( tools = c( "file_ext", + "md5sum", + "package_dependencies", "pskill", "psnice", "write_PACKAGES" @@ -68,13 +70,14 @@ renv$initialize <- function() { renv$the$metadata <- list( embedded = TRUE, version = structure( - "1.0.3.9000", - sha = "1f5bafc05a09ce6b30b83b835ffcd70547fe4fae" + "1.1.7", + md5 = "5c2a82def4966cf44b900fddbeb62fab", + sha = "53d868dd20396f31df39ef8ed2a2a403c2ff31a7" ) ) # run our load / attach hooks so internal state is initialized - renv$renv_zzz_load() + renv$.onLoad(libname, pkgname) # remove our initialize method when we're done rm(list = "initialize", envir = renv) diff --git a/inst/vendor/renv.R b/inst/vendor/renv.R index d7d8b4b9..829d7b37 100644 --- a/inst/vendor/renv.R +++ b/inst/vendor/renv.R @@ -1,6 +1,6 @@ # -# renv 1.0.3.9000 [rstudio/renv#1f5bafc]: A dependency management toolkit for R. -# Generated using `renv:::vendor()` at 2023-10-18 14:18:45.514687. +# renv 1.1.7 [rstudio/renv#53d868d]: A dependency management toolkit for R. +# Generated using `renv:::vendor()` at 2026-02-12 12:06:56.796845. # # aaa.R ---------------------------------------------------------------------- @@ -8,18 +8,29 @@ # global variables the <- new.env(parent = emptyenv()) +the$paths <- new.env(parent = emptyenv()) # detect if we're running on CI ci <- function() { !is.na(Sys.getenv("CI", unset = NA)) } +# check if the renv autoloader is running +autoloading <- function() { + getOption("renv.autoloader.running", default = FALSE) +} + # detect if we're running within R CMD build building <- function() { nzchar(Sys.getenv("R_CMD")) && grepl("Rbuild", basename(dirname(getwd())), fixed = TRUE) } +# detect if we're running within R CMD INSTALL +installing <- function() { + nzchar(Sys.getenv("R_INSTALL_PKG")) +} + # are we running code within R CMD check? checking <- function() { "CheckExEnv" %in% search() || @@ -35,6 +46,25 @@ testing <- function() { identical(Sys.getenv("TESTTHAT"), "true") } +devel <- function() { + identical(R.version[["status"]], "Under development (unstable)") +} + +devmode <- function() { + + if ("devtools" %in% loadedNamespaces()) { + if (.packageName %in% devtools::dev_packages()) { + return(TRUE) + } + } + + if (Sys.getenv("DEVTOOLS_LOAD") == .packageName) + return(TRUE) + + FALSE + +} + # abi.R ---------------------------------------------------------------------- @@ -45,7 +75,7 @@ renv_abi_check <- function(packages = NULL, project = NULL) { if (renv_platform_windows()) { - writef("- ABI conflict checks are not yet implemented on Windows.") + writef("- ABI conflict checks are not available on Windows.") return() } @@ -70,10 +100,10 @@ renv_abi_check <- function(packages = NULL, ) }) - # report problmes + # report problems data <- problems$data() if (empty(data)) { - fmt <- "- No ABI conflicts were detected in the set of installed packages." + fmt <- "- No ABI problems were detected in the set of installed packages." writef(fmt) return(invisible(data)) } @@ -85,7 +115,7 @@ renv_abi_check <- function(packages = NULL, reasons <- unique(tbl$reason) if ("Rcpp_precious_list" %in% reasons) { packages <- sort(unique(tbl$package[tbl$reason == "Rcpp_precious_list"])) - caution_bullets( + bulletin( "The following packages were built against a newer version of Rcpp than is currently available:", packages, c( @@ -98,6 +128,27 @@ renv_abi_check <- function(packages = NULL, ) } + if ("missing" %in% reasons) { + + missing <- tbl[tbl$reason == "missing", ] + bulletin( + "The following required system libraries are unavailable:", + unique(missing$dependency), + c( + "These system libraries may need to be re-installed.", + "Alternatively, you may need to re-install the packages which depend on these libraries." + ) + ) + + # now, for each dependency, list the packages which require it + for (dep in unique(missing$dependency)) { + caution(header(sprintf("%s (required by)", dep))) + caution(paste("-", sort(tbl$package[missing$dependency == dep]))) + caution() + } + + } + invisible(tbl) } @@ -107,6 +158,12 @@ renv_abi_check_impl <- function(package, problems) { # find path to package pkgpath <- renv_package_find(package) + # check for dependency issues + if (renv_platform_macos()) + renv_abi_deps_macos(package, problems) + else if (renv_platform_linux()) + renv_abi_deps_linux(package, problems) + # look for an associated shared object shlib <- renv_package_shlib(pkgpath) if (!file.exists(shlib)) @@ -122,7 +179,7 @@ renv_abi_check_impl <- function(package, problems) { # handle Rcpp linkdeps <- renv_description_parse_field(pkgdesc$LinkingTo) - if ("Rcpp" %in% linkdeps$Package) + if ("Rcpp" %in% linkdeps$Package && renv_package_installed("Rcpp")) renv_abi_check_impl_rcpp(package, symbols, problems) # TODO: other checks? more direct symbol checks for other packages? @@ -152,6 +209,11 @@ renv_abi_check_impl_rcpp_preciouslist <- function(package, symbols, rcppsyms, pr if (length(available)) return() + # skip if Rcpp appears to be new enough anyhow + version <- renv_package_version("Rcpp") + if (renv_version_ge(version, "1.0.7")) + return() + problem <- renv_abi_problem( package = paste(package, renv_package_version(package)), dependency = paste("Rcpp", renv_package_version("Rcpp")), @@ -167,7 +229,7 @@ renv_abi_symbols <- function(path, args = NULL) { # invoke nm to read symbols output <- renv_system_exec( command = "nm", - args = c(args, renv_shell_path(path)), + args = c("-D", args, renv_shell_path(path)), action = "reading symbols" ) @@ -206,6 +268,47 @@ renv_abi_packages <- function(project, libpaths) { } +renv_abi_deps_macos <- function(package, problems) { + # TODO +} + +renv_abi_deps_linux <- function(package, problems) { + + # get shlib path, if any + shlib <- renv_package_shlib(package) + if (!file.exists(shlib)) + return() + + # attempt to read dependencies + output <- renv_system_exec("ldd", renv_shell_path(shlib)) + + # look for 'not found' entries + idx <- regexpr(" => not found", output, fixed = TRUE) + matches <- substring(output, 2L, idx - 1L) + + # drop duplicates, empty strings + names <- unique(matches[nzchar(matches)]) + if (empty(names)) + return() + + # add problems + for (name in names) { + + fmt <- "%s %s (%s)" + package <- sprintf(fmt, package, renv_package_version(package), shlib) + + problem <- renv_abi_problem( + package = package, + dependency = name, + reason = "missing" + ) + + problems$push(problem) + + } + +} + # abort.R -------------------------------------------------------------------- @@ -444,7 +547,7 @@ renv_actions_restore_clean <- function(actions, clean, project) { #' renv::activate() #' #' # activate a separate project -#' renv::activate("~/projects/analysis") +#' renv::activate(project = "~/projects/analysis") #' #' # deactivate the currently-activated project #' renv::deactivate() @@ -458,6 +561,7 @@ activate <- function(project = NULL, profile = NULL) { project <- renv_project_resolve(project) renv_project_lock(project = project) + profile <- profile %||% renv_profile_get() renv_profile_set(profile) renv_activate_impl( @@ -536,6 +640,13 @@ renv_activate_version_activate <- function(project) { line <- grep("version <-", contents, fixed = TRUE, value = TRUE)[[1L]] version <- parse(text = line)[[1L]][[3L]] + # check for md5 as well + line <- grep("attr(version, \"md5\")", contents, fixed = TRUE, value = TRUE) + if (length(line)) { + md5 <- parse(text = line)[[1L]][[3L]] + attr(version, "md5") <- md5 + } + # check for sha as well line <- grep("attr(version, \"sha\")", contents, fixed = TRUE, value = TRUE) if (length(line)) { @@ -592,25 +703,23 @@ renv_activate_prompt <- function(action, library, prompt, project) { } renv_activate_prompt_impl <- function(action, project = NULL) { - title <- c( - sprintf( - "It looks like you've called renv::%s() in a project that hasn't been activated yet.", - action - ), - "How would you like to proceed?" - ) + + fmt <- "It looks like you've called renv::%s() in a project that hasn't been activated yet." + title <- c(sprintf(fmt, action), "How would you like to proceed?") + choices <- c( activate = "Activate the project and use the project library.", continue = "Do not activate the project and use the current library paths.", - cancel = "Cancel and resolve the situation another way." + cancel = "Cancel and resolve the situation another way." ) choice <- menu(choices, title, default = "continue") switch(choice, activate = { activate(project = project); TRUE }, continue = FALSE, - cancel = cancel(), + cancel = cancel() ) + } @@ -706,7 +815,7 @@ renv_addins_embed <- function() { # aliases used primarily for nicer / normalized text output -the$aliases <- list( +the$aliases <- c( bioc = "Bioconductor", bioconductor = "Bioconductor", bitbucket = "Bitbucket", @@ -722,8 +831,74 @@ the$aliases <- list( xgit = "Git" ) -alias <- function(text) { - the$aliases[[text]] %||% text +alias <- function(text, aliases = the$aliases) { + matches <- text %in% names(aliases) + text[matches] <- aliases[text[matches]] + text +} + + +# ansify.R ------------------------------------------------------------------- + + +ansify <- function(text) { + if (renv_ansify_enabled()) + renv_ansify_enhanced(text) + else + renv_ansify_default(text) +} + +renv_ansify_enabled <- function() { + + override <- Sys.getenv("RENV_ANSIFY_ENABLED", unset = NA) + if (!is.na(override)) + return(as.logical(override)) + + pane <- Sys.getenv("RSTUDIO_CHILD_PROCESS_PANE", unset = NA) + if (identical(pane, "build")) + return(FALSE) + + testthat <- Sys.getenv("TESTTHAT", unset = "false") + if (tolower(testthat) %in% "true") + return(FALSE) + + iderun <- Sys.getenv("R_CLI_HAS_HYPERLINK_IDE_RUN", unset = "false") + if (tolower(iderun) %in% "false") + return(FALSE) + + TRUE + +} + +renv_ansify_default <- function(text) { + text +} + +renv_ansify_enhanced <- function(text) { + + # R help links + pattern <- "`\\?(renv::(?:[^`])+)`" + replacement <- "`\033]8;;x-r-help:\\1\a?\\1\033]8;;\a`" + text <- gsub(pattern, replacement, text, perl = TRUE) + + # runnable code + pattern <- "`(renv::(?:[^`])+)`" + replacement <- "`\033]8;;x-r-run:\\1\a\\1\033]8;;\a`" + text <- gsub(pattern, replacement, text, perl = TRUE) + + # return ansified text + text + +} + +renv_ansify_init <- function() { + + envir <- renv_envir_self() + if (renv_ansify_enabled()) + assign("ansify", renv_ansify_enhanced, envir = envir) + else + assign("ansify", renv_ansify_default, envir = envir) + } @@ -919,7 +1094,7 @@ renv_autoload_impl <- function() { } # if we have an activate script, run it - activate <- file.path(project, "renv/activate.R") + activate <- renv_paths_renv("activate.R", profile = FALSE, project = project) if (file.exists(activate)) { sys.source(activate, envir = globalenv()) return(TRUE) @@ -1031,7 +1206,7 @@ renv_available_packages_query <- function(type, repos, quiet = FALSE) { paste(c(header(url), msgs, ""), collapse = "\n") }) - caution_bullets(header, msgs) + bulletin(header, msgs) filter(dbs, Negate(is.null)) } @@ -1101,6 +1276,10 @@ renv_available_packages_query_impl <- function(url, type, errors) { renv_available_packages_success <- function(db, url, type) { + # https://github.com/rstudio/renv/issues/1706 + if (empty(db)) + return(data.frame()) + # convert to data.frame db <- as_data_frame(db) if (nrow(db) == 0L) @@ -1170,6 +1349,21 @@ renv_available_packages_entry <- function(package, entries[ordered[[1]], ] } + # if 'prefer' was supplied as a repository URL, include it + repos <- repos %||% as.list(getOption("repos")) + if (is.character(prefer)) { + + # ensure repositories are named + nms <- names(prefer) %||% rep.int("", length(prefer)) + nms[!nzchar(nms)] <- prefer[!nzchar(nms)] + names(prefer) <- nms + + # include any 'prefer' repositories that were supplied as URLs + isurl <- grep("^\\w+://", prefer) + repos <- c(prefer[isurl], repos) + + } + # read available packages dbs <- available_packages( type = type, @@ -1178,8 +1372,8 @@ renv_available_packages_entry <- function(package, ) # if a preferred repository is marked and available, prefer using that - if (length(prefer) == 1L && prefer %in% names(dbs)) { - idx <- match(prefer, names(dbs)) + if (is.character(prefer)) { + idx <- omit_if(match(names(prefer), names(dbs)), is.na) ord <- c(idx, setdiff(seq_along(dbs), idx)) dbs <- dbs[ord] } @@ -1216,10 +1410,8 @@ renv_available_packages_entry <- function(package, renv_available_packages_record <- function(entry, type) { - # check to see if this is already a proper record - attrs <- attributes(entry) - keys <- c("type", "url") - if (all(keys %in% names(attrs))) + # check if this record was already tagged + if (renv_record_tagged(entry)) return(entry) # otherwise, construct it @@ -1238,13 +1430,19 @@ renv_available_packages_record <- function(entry, type) { # form url url <- entry$Repository path <- entry$Path + name <- entry$Name + + # if path was supplied, it should be used relative + # to the repository URL if (length(path) && !is.na(path)) url <- paste(url, path, sep = "/") - attr(record, "type") <- type - attr(record, "url") <- url - - record + renv_record_tag( + record = record, + type = type, + url = url, + name = name + ) } @@ -1302,8 +1500,10 @@ renv_available_packages_latest <- function(package, { methods <- list( renv_available_packages_latest_repos, - if (renv_mran_enabled()) - renv_available_packages_latest_mran + if (getOption("renv.install.allowArchivedPackages", default = FALSE)) + renv_available_packages_latest_archive, + if (renv_p3m_enabled()) + renv_available_packages_latest_p3m ) errors <- stack() @@ -1361,22 +1561,19 @@ renv_available_packages_latest <- function(package, } -renv_available_packages_latest_mran <- function(package, - type = NULL, - repos = NULL) +renv_available_packages_latest_p3m <- function(package, + type = NULL, + repos = NULL) { - if (!config$mran.enabled()) - stop("MRAN is not enabled") - type <- type %||% getOption("pkgType") if (identical(type, "source")) - stop("MRAN database requires binary packages to be available") + stop("binary packages are not available") - # ensure local MRAN database is up-to-date - renv_mran_database_refresh(explicit = FALSE) + # ensure local p3m database is up-to-date + renv_p3m_database_refresh(explicit = FALSE) # attempt to read it - database <- catch(renv_mran_database_load()) + database <- catch(renv_p3m_database_load()) if (inherits(database, "error")) return(database) @@ -1384,14 +1581,14 @@ renv_available_packages_latest_mran <- function(package, suffix <- contrib.url("", type = "binary") entry <- database[[suffix]] if (is.null(entry)) - stopf("no MRAN records available from repository URL '%s'", suffix) + stopf("no records available from repository URL '%s'", suffix) # find all available packages keys <- attr(entry, "keys") pattern <- paste0("^", package, " ") matching <- grep(pattern, keys, perl = TRUE, value = TRUE) if (empty(matching)) - stopf("package '%s' is not available from MRAN", package) + stopf("package '%s' is not available", package) # take the latest-available package entries <- unlist(mget(matching, envir = entry)) @@ -1408,29 +1605,96 @@ renv_available_packages_latest_mran <- function(package, Package = package, Version = version, Source = "Repository", - Repository = "MRAN" + Repository = "P3M" ) # convert from integer to date date <- as.Date(idate, origin = "1970-01-01") # form url to binary package - base <- renv_mran_url(date, suffix) + base <- renv_p3m_url(date, suffix) name <- renv_retrieve_name(record, type = "binary") url <- file.path(base, name) # tag record with url + type - attr(record, "url") <- dirname(url) - attr(record, "type") <- "binary" + renv_record_tag( + record = record, + type = "binary", + url = dirname(url), + name = "P3M" + ) +} + +renv_available_packages_latest_archive_query <- function(repo) { + + index( + scope = "available-packages-archive", + key = repo, + value = tryCatch( + renv_available_packages_latest_archive_query_impl(repo), + error = function(e) list() + ) + ) + +} + +renv_available_packages_latest_archive_query_impl <- function(repo) { + url <- file.path(repo, "src/contrib/Meta/archive.rds") + destfile <- download(url, destfile = tempfile("archive-", fileext = ".rds"), quiet = TRUE) + readRDS(destfile) +} + +renv_available_packages_latest_archive <- function(package, + type = NULL, + repos = NULL) +{ + type <- type %||% getOption("pkgType") + repos <- repos %||% getOption("repos") + + for (i in seq_along(repos)) { + + # extract pieces of interest + name <- names(repos)[[i]] + repo <- repos[[i]] + + # check for potential packages in archive + archive <- renv_available_packages_latest_archive_query(repo) + entries <- archive[[package]] + if (NROW(entries) == 0L) + next + + # parse the package name + version from the row names + rns <- basename(row.names(entries)) + + # grab files that look like packages + extpat <- "(?:\\.tar\\.gz|\\.tgz|\\.zip)$" + parts <- strsplit(rns, "_", fixed = TRUE) + package <- map_chr(parts, `[[`, 1L) + rest <- map_chr(parts, `[[`, 2L) + version <- sub(extpat, "", rest) + + # put it into a data.frame + data <- data.frame(Package = package, Version = version) + + # take the newest version + ord <- order(numeric_version(version), decreasing = TRUE) + entry <- as.list(data[ord[[1L]], ]) + entry$Source <- "Repository" + entry$Repository <- name + + return(entry) + + } + + NULL - record } renv_available_packages_latest_repos <- function(package, type = NULL, repos = NULL) { - type <- type %||% getOption("pkgType") + type <- type %||% getOption("pkgType") repos <- repos %||% getOption("repos") # detect requests for only source packages @@ -1637,6 +1901,15 @@ renv_available_packages_flatten <- function(dbs) { # backports.R ---------------------------------------------------------------- +if (is.null(.BaseNamespaceEnv$dir.exists)) { + + dir.exists <- function(paths) { + info <- suppressWarnings(file.info(paths, extra_cols = FALSE)) + info$isdir %in% TRUE + } + +} + if (is.null(.BaseNamespaceEnv$lengths)) { lengths <- function(x, use.names = TRUE) { @@ -1645,6 +1918,16 @@ if (is.null(.BaseNamespaceEnv$lengths)) { } +if (is.null(.BaseNamespaceEnv$startsWith)) { + + startsWith <- function(x, prefix) { + pattern <- sprintf("^\\Q%s\\E", prefix) + grepl(pattern, x, perl = TRUE) + } + +} + + # base64.R ------------------------------------------------------------------- @@ -1936,6 +2219,66 @@ renv_bioconductor_manager <- function() { "BiocInstaller" } +renv_bioconductor_versions <- function() { + + # map versions of Bioconductor to the versions of R they can be used with + list( + "3.9" = "3.6", + "3.10" = "3.6", + "3.11" = "4.0", + "3.12" = "4.0", + "3.13" = "4.1", + "3.14" = "4.1", + "3.15" = "4.2", + "3.16" = "4.2", + "3.17" = "4.3", + "3.18" = "4.3", + "3.19" = "4.4", + "3.20" = "4.4", + "3.21" = "4.5", # speculative + "3.22" = "4.5" # speculative + ) + +} + +renv_bioconductor_validate <- function(version, prompt = interactive()) { + + # check for the requested Bioconductor version in our internal version map; + # if it doesn't exist, then just assume compatibility + # + # we previously used BiocManager for this, but because it makes web requests, + # this can be prohibitively slow for certain users + # + # https://github.com/rstudio/renv/issues/2091 + biocversions <- renv_bioconductor_versions() + rversion <- biocversions[[version]] + if (is.null(rversion)) + return(TRUE) + + # check that the version of R in use matches what Bioconductor requires + ok <- renv_version_eq(rversion, getRversion(), n = 2L) + if (ok) + return(TRUE) + + fmt <- lines( + "You are using Bioconductor %1$s, which is not compatible with R %2$s.", + "Use 'renv::init(bioconductor = TRUE)' to re-initialize this project with the appropriate Bioconductor release.", + if (renv_package_installed("BiocVersion")) + "Please uninstall the 'BiocVersion' package first, with `remove.packages(\"BiocVersion\")`." + ) + + caution(fmt, version, getRversion()) + + if (prompt) { + writef("") + response <- ask("Would you still like to use this version of Bioconductor?") + cancel_if(!response) + } + + TRUE + +} + renv_bioconductor_init <- function(library = NULL) { renv_scope_options(renv.verbose = FALSE) @@ -1952,7 +2295,8 @@ renv_bioconductor_init_biocmanager <- function(library = NULL) { return(TRUE) ensure_directory(library) - install("BiocManager", library = library) + install("BiocManager", library = library, prompt = FALSE) + TRUE } @@ -2029,12 +2373,20 @@ renv_bioconductor_repos <- function(project = NULL, version = NULL) { # read Bioconductor version (normally set during restore) version <- version %||% renv_bioconductor_version(project = project) + # get current repositories + repos <- getOption("repos") + # read Bioconductor repositories (prefer BiocInstaller for older R) - if (identical(renv_bioconductor_manager(), "BiocManager")) + biocrepos <- if (identical(renv_bioconductor_manager(), "BiocManager")) renv_bioconductor_repos_biocmanager(version) else renv_bioconductor_repos_biocinstaller(version) + # overlay new repos on old repos (this helps preserve ordering) + # https://github.com/rstudio/renv/issues/2128 + repos[names(biocrepos)] <- biocrepos + repos + } renv_bioconductor_repos_biocmanager <- function(version) { @@ -2081,6 +2433,16 @@ catf <- function(fmt, ..., appendLF = TRUE) { if (quiet) return(invisible()) + # also check for config environment variables that should suppress messages + # https://github.com/rstudio/renv/issues/2214 + enabled <- Sys.getenv("RENV_CONFIG_STARTUP_QUIET", unset = NA) + if (!is.na(enabled) && tolower(enabled) %in% c("true", "1")) + return(invisible()) + + enabled <- Sys.getenv("RENV_CONFIG_SYNCHRONIZED_CHECK", unset = NA) + if (!is.na(enabled) && tolower(enabled) %in% c("false", "0")) + return(invisible()) + msg <- sprintf(fmt, ...) cat(msg, file = stdout(), sep = if (appendLF) "\n" else "") @@ -2104,8 +2466,22 @@ header <- function(label, } -startswith <- function(string, prefix) { - substring(string, 1, nchar(prefix)) == prefix +heredoc <- function(text, leave = 0) { + + # remove leading, trailing whitespace + trimmed <- gsub("^\\s*\\n|\\n\\s*$", "", text) + + # split into lines + lines <- strsplit(trimmed, "\n", fixed = TRUE)[[1L]] + + # compute common indent + indent <- regexpr("[^[:space:]]", lines) + common <- min(setdiff(indent, -1L)) - leave + text <- paste(substring(lines, common), collapse = "\n") + + # substitute in ANSI links for executable renv code + ansify(text) + } bootstrap <- function(version, library) { @@ -2114,6 +2490,16 @@ bootstrap <- function(version, library) { section <- header(sprintf("Bootstrapping renv %s", friendly)) catf(section) + # try to install renv from cache + md5 <- attr(version, "md5", exact = TRUE) + if (length(md5)) { + pkgpath <- renv_bootstrap_find(version) + if (length(pkgpath) && file.exists(pkgpath)) { + file.copy(pkgpath, library, recursive = TRUE) + return(invisible()) + } + } + # attempt to download renv catf("- Downloading renv ... ", appendLF = FALSE) withCallingHandlers( @@ -2139,7 +2525,6 @@ bootstrap <- function(version, library) { # add empty line to break up bootstrapping from normal output catf("") - return(invisible()) } @@ -2156,12 +2541,20 @@ renv_bootstrap_repos <- function() { repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA) if (!is.na(repos)) { - # check for RSPM; if set, use a fallback repository for renv - rspm <- Sys.getenv("RSPM", unset = NA) - if (identical(rspm, repos)) - repos <- c(RSPM = rspm, CRAN = cran) + # split on ';' if present + parts <- strsplit(repos, ";", fixed = TRUE)[[1L]] - return(repos) + # split into named repositories if present + idx <- regexpr("=", parts, fixed = TRUE) + keys <- substring(parts, 1L, idx - 1L) + vals <- substring(parts, idx + 1L) + names(vals) <- keys + + # if we have a single unnamed repository, call it CRAN + if (length(vals) == 1L && identical(keys, "")) + names(vals) <- "CRAN" + + return(vals) } @@ -2263,8 +2656,11 @@ renv_bootstrap_download_impl <- function(url, destfile) { quiet = TRUE ) - if ("headers" %in% names(formals(utils::download.file))) - args$headers <- renv_bootstrap_download_custom_headers(url) + if ("headers" %in% names(formals(utils::download.file))) { + headers <- renv_bootstrap_download_custom_headers(url) + if (length(headers) && is.character(headers)) + args$headers <- headers + } do.call(utils::download.file, args) @@ -2343,10 +2739,21 @@ renv_bootstrap_download_cran_latest_find <- function(version) { for (type in types) { for (repos in renv_bootstrap_repos()) { + # build arguments for utils::available.packages() call + args <- list(type = type, repos = repos) + + # add custom headers if available -- note that + # utils::available.packages() will pass this to download.file() + if ("headers" %in% names(formals(utils::download.file))) { + headers <- renv_bootstrap_download_custom_headers(repos) + if (length(headers) && is.character(headers)) + args$headers <- headers + } + # retrieve package database db <- tryCatch( as.data.frame( - utils::available.packages(type = type, repos = repos), + do.call(utils::available.packages, args), stringsAsFactors = FALSE ), error = identity @@ -2396,6 +2803,51 @@ renv_bootstrap_download_cran_archive <- function(version) { } +renv_bootstrap_find <- function(version) { + + path <- renv_bootstrap_find_cache(version) + if (length(path) && file.exists(path)) { + catf("- Using renv %s from global package cache", version) + return(path) + } + +} + +renv_bootstrap_find_cache <- function(version) { + + md5 <- attr(version, "md5", exact = TRUE) + if (is.null(md5)) + return() + + # infer path to renv cache + cache <- Sys.getenv("RENV_PATHS_CACHE", unset = "") + if (!nzchar(cache)) { + root <- Sys.getenv("RENV_PATHS_ROOT", unset = NA) + if (!is.na(root)) + cache <- file.path(root, "cache") + } + + if (!nzchar(cache)) { + tools <- asNamespace("tools") + if (is.function(tools$R_user_dir)) { + root <- tools$R_user_dir("renv", "cache") + cache <- file.path(root, "cache") + } + } + + # start completing path to cache + file.path( + cache, + renv_bootstrap_cache_version(), + renv_bootstrap_platform_prefix(), + "renv", + version, + md5, + "renv" + ) + +} + renv_bootstrap_download_tarball <- function(version) { # if the user has provided the path to a tarball via @@ -2428,6 +2880,14 @@ renv_bootstrap_download_tarball <- function(version) { } +renv_bootstrap_github_token <- function() { + for (envvar in c("GITHUB_TOKEN", "GITHUB_PAT", "GH_TOKEN")) { + envval <- Sys.getenv(envvar, unset = NA) + if (!is.na(envval)) + return(envval) + } +} + renv_bootstrap_download_github <- function(version) { enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE") @@ -2435,16 +2895,19 @@ renv_bootstrap_download_github <- function(version) { return(FALSE) # prepare download options - pat <- Sys.getenv("GITHUB_PAT") - if (nzchar(Sys.which("curl")) && nzchar(pat)) { + token <- renv_bootstrap_github_token() + if (is.null(token)) + token <- "" + + if (nzchar(Sys.which("curl")) && nzchar(token)) { fmt <- "--location --fail --header \"Authorization: token %s\"" - extra <- sprintf(fmt, pat) + extra <- sprintf(fmt, token) saved <- options("download.file.method", "download.file.extra") options(download.file.method = "curl", download.file.extra = extra) on.exit(do.call(base::options, saved), add = TRUE) - } else if (nzchar(Sys.which("wget")) && nzchar(pat)) { + } else if (nzchar(Sys.which("wget")) && nzchar(token)) { fmt <- "--header=\"Authorization: token %s\"" - extra <- sprintf(fmt, pat) + extra <- sprintf(fmt, token) saved <- options("download.file.method", "download.file.extra") options(download.file.method = "wget", download.file.extra = extra) on.exit(do.call(base::options, saved), add = TRUE) @@ -2569,11 +3032,19 @@ renv_bootstrap_install_impl <- function(library, tarball) { } -renv_bootstrap_platform_prefix <- function() { +renv_bootstrap_platform_prefix_default <- function() { - # construct version prefix - version <- paste(R.version$major, R.version$minor, sep = ".") - prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-") + # read version component + version <- Sys.getenv("RENV_PATHS_VERSION", unset = "R-%v") + + # expand placeholders + placeholders <- list( + list("%v", format(getRversion()[1, 1:2])), + list("%V", format(getRversion()[1, 1:3])) + ) + + for (placeholder in placeholders) + version <- gsub(placeholder[[1L]], placeholder[[2L]], version, fixed = TRUE) # include SVN revision for development versions of R # (to avoid sharing platform-specific artefacts with released versions of R) @@ -2582,10 +3053,19 @@ renv_bootstrap_platform_prefix <- function() { identical(R.version[["nickname"]], "Unsuffered Consequences") if (devel) - prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r") + version <- paste(version, R.version[["svn rev"]], sep = "-r") + + version + +} + +renv_bootstrap_platform_prefix <- function() { + + # construct version prefix + version <- renv_bootstrap_platform_prefix_default() # build list of path components - components <- c(prefix, R.version$platform) + components <- c(version, R.version$platform) # include prefix if provided by user prefix <- renv_bootstrap_platform_prefix_impl() @@ -2606,6 +3086,9 @@ renv_bootstrap_platform_prefix_impl <- function() { # if the user has requested an automatic prefix, generate it auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA) + if (is.na(auto) && getRversion() >= "4.4.0") + auto <- "TRUE" + if (auto %in% c("TRUE", "True", "true", "1")) return(renv_bootstrap_platform_prefix_auto()) @@ -2797,24 +3280,23 @@ renv_bootstrap_validate_version <- function(version, description = NULL) { # the loaded version of renv doesn't match the requested version; # give the user instructions on how to proceed - remote <- if (!is.null(description[["RemoteSha"]])) { + dev <- identical(description[["RemoteType"]], "github") + remote <- if (dev) paste("rstudio/renv", description[["RemoteSha"]], sep = "@") - } else { + else paste("renv", description[["Version"]], sep = "@") - } # display both loaded version + sha if available friendly <- renv_bootstrap_version_friendly( version = description[["Version"]], - sha = description[["RemoteSha"]] + sha = if (dev) description[["RemoteSha"]] ) - fmt <- paste( - "renv %1$s was loaded from project library, but this project is configured to use renv %2$s.", - "- Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile.", - "- Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library.", - sep = "\n" - ) + fmt <- heredoc(" + renv %1$s was loaded from project library, but this project is configured to use renv %2$s. + - Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile. + - Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library. + ") catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote) FALSE @@ -2822,13 +3304,19 @@ renv_bootstrap_validate_version <- function(version, description = NULL) { } renv_bootstrap_validate_version_dev <- function(version, description) { + expected <- description[["RemoteSha"]] - is.character(expected) && startswith(expected, version) + if (!is.character(expected)) + return(FALSE) + + pattern <- sprintf("^\\Q%s\\E", version) + grepl(pattern, expected, perl = TRUE) + } renv_bootstrap_validate_version_release <- function(version, description) { expected <- description[["Version"]] - is.character(expected) && identical(expected, version) + is.character(expected) && identical(c(expected), c(version)) } renv_bootstrap_hash_text <- function(text) { @@ -3003,10 +3491,10 @@ renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) renv_bootstrap_exec <- function(project, libpath, version) { if (!renv_bootstrap_load(project, libpath, version)) - renv_bootstrap_run(version, libpath) + renv_bootstrap_run(project, libpath, version) } -renv_bootstrap_run <- function(version, libpath) { +renv_bootstrap_run <- function(project, libpath, version) { # perform bootstrap bootstrap(version, libpath) @@ -3017,7 +3505,7 @@ renv_bootstrap_run <- function(version, libpath) { # try again to load if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) { - return(renv::load(project = getwd())) + return(renv::load(project = project)) } # failed to download or load renv; warn the user @@ -3030,21 +3518,29 @@ renv_bootstrap_run <- function(version, libpath) { } +renv_bootstrap_cache_version <- function() { + # NOTE: users should normally not override the cache version; + # this is provided just to make testing easier + Sys.getenv("RENV_CACHE_VERSION", unset = "v5") +} + +renv_bootstrap_cache_version_previous <- function() { + version <- renv_bootstrap_cache_version() + number <- as.integer(substring(version, 2L)) + paste("v", number - 1L, sep = "") +} + # cache.R -------------------------------------------------------------------- # tools for interacting with the renv global package cache renv_cache_version <- function() { - # NOTE: users should normally not override the cache version; - # this is provided just to make testing easier - Sys.getenv("RENV_CACHE_VERSION", unset = "v5") + renv_bootstrap_cache_version() } renv_cache_version_previous <- function() { - version <- renv_cache_version() - number <- as.integer(substring(version, 2L)) - paste("v", number - 1L, sep = "") + renv_bootstrap_cache_version_previous() } # given a record, find a compatible version of that package in the cache, @@ -3109,6 +3605,10 @@ renv_cache_find <- function(record) { record <- record[nzchar(record)] dcf <- dcf[nzchar(dcf)] + # drop remote fields for cranlike remotes + if (renv_record_cranlike(dcf)) + dcf <- dcf[grep("^Remote(?!s)", names(dcf), invert = TRUE, perl = TRUE)] + # check identical lhs <- keep(record, fields) rhs <- keep(dcf, fields) @@ -3127,7 +3627,7 @@ renv_cache_find <- function(record) { # were moved to the renv cache renv_cache_path <- function(path) { record <- renv_description_read(path) - record$Hash <- renv_hash_description(path) + record[["Hash"]] <- renv_hash_description(path) renv_cache_find(record) } @@ -3161,7 +3661,7 @@ renv_cache_synchronize <- function(record, linkable = FALSE) { return(FALSE) # if we don't have a hash, compute it now - record$Hash <- record$Hash %||% renv_hash_description(path) + record[["Hash"]] <- record[["Hash"]] %||% renv_hash_description(path) # construct cache entry caches <- renv_cache_find(record) @@ -3221,42 +3721,49 @@ renv_cache_synchronize_impl <- function(cache, record, linkable, path) { renv_cache_copy(path, cache, overwrite = TRUE) } - if (renv_platform_unix()) { + # invoke cache callbacks + renv_cache_callbacks(cache) - # change the cache owner if set - user <- Sys.getenv("RENV_CACHE_USER", unset = NA) - if (!is.na(user)) { - parent <- dirname(dirname(dirname(cache))) - renv_system_exec( - command = "chown", - args = c("-Rf", renv_shell_quote(user), renv_shell_path(parent)), - action = "chowning cached package", - quiet = TRUE, - success = NULL - ) - } + TRUE - # change file modes after copy if set - mode <- Sys.getenv("RENV_CACHE_MODE", unset = NA) - if (!is.na(mode)) { - parent <- dirname(dirname(dirname(cache))) - renv_system_exec( - command = "chmod", - args = c("-Rf", renv_shell_quote(mode), renv_shell_path(parent)), - action = "chmoding cached package", - quiet = TRUE, - success = NULL - ) - } +} - # finally, allow for an arbitrary callback if set - callback <- getOption("renv.cache.callback") - if (is.function(callback)) - callback(cache) +renv_cache_callbacks <- function(cache) { + + # only done on unix platforms + if (!renv_platform_unix()) + return(FALSE) + # change the cache owner if set + user <- Sys.getenv("RENV_CACHE_USER", unset = NA) + if (!is.na(user)) { + parent <- dirname(dirname(dirname(cache))) + renv_system_exec( + command = "chown", + args = c("-Rf", renv_shell_quote(user), renv_shell_path(parent)), + action = "chowning cached package", + quiet = TRUE, + success = NULL + ) } - TRUE + # change file modes after copy if set + mode <- Sys.getenv("RENV_CACHE_MODE", unset = NA) + if (!is.na(mode)) { + parent <- dirname(dirname(dirname(cache))) + renv_system_exec( + command = "chmod", + args = c("-Rf", renv_shell_quote(mode), renv_shell_path(parent)), + action = "chmoding cached package", + quiet = TRUE, + success = NULL + ) + } + + # finally, allow for an arbitrary callback if set + callback <- getOption("renv.cache.callback") + if (is.function(callback)) + callback(cache) } @@ -3306,7 +3813,7 @@ renv_cache_diagnose_corrupt_metadata <- function(paths, problems, verbose) { # nocov start if (verbose) { - caution_bullets( + bulletin( "The following package(s) are missing 'Meta/package.rds':", renv_cache_format_path(bad), "These packages should be purged and reinstalled." @@ -3335,7 +3842,7 @@ renv_cache_diagnose_corrupt_metadata <- function(paths, problems, verbose) { # nocov start if (verbose) { - caution_bullets( + bulletin( "The following package(s) have corrupt 'Meta/package.rds' files:", renv_cache_format_path(bad), "These packages should be purged and reinstalled." @@ -3366,7 +3873,7 @@ renv_cache_diagnose_missing_descriptions <- function(paths, problems, verbose) { # nocov start if (verbose) { - caution_bullets( + bulletin( "The following packages are missing DESCRIPTION files in the cache:", renv_cache_format_path(bad), "These packages should be purged and reinstalled." @@ -3400,7 +3907,7 @@ renv_cache_diagnose_bad_hash <- function(paths, problems, verbose) { fmt <- "%s %s [Hash: %s != %s]" entries <- sprintf(fmt, lhs$Package, lhs$Version, lhs$Hash, rhs$Hash) - caution_bullets( + bulletin( "The following packages have incorrect hashes:", entries, "Consider using `renv::rehash()` to re-hash these packages." @@ -3443,7 +3950,7 @@ renv_cache_diagnose_wrong_built_version <- function(paths, problems, verbose) { # nocov start if (verbose) { - caution_bullets( + bulletin( "The following packages have no 'Built' field recorded in their DESCRIPTION file:", paths[isna], "renv is unable to validate the version of R this package was built for." @@ -3481,7 +3988,7 @@ renv_cache_diagnose_wrong_built_version <- function(paths, problems, verbose) { # nocov start if (verbose) { - caution_bullets( + bulletin( "The following packages in the cache were built for a different version of R:", renv_cache_format_path(paths[wrong]), "These packages will need to be purged and reinstalled." @@ -3636,45 +4143,32 @@ renv_cache_linkable <- function(project, library) { # given a call of the form e.g. 'pkg::foo()' or 'foo()', # check that method 'foo()' is truly being called and -# strip off the 'pkg::' part for easier parsing +# strip off the 'pkg::' part for easier parsing. renv_call_expect <- function(node, package, methods) { - if (!is.call(node)) - return(NULL) + result <- NULL # check for call of the form 'pkg::foo(a, b, c)' - colon <- renv_call_matches(node[[1L]], name = c("::", ":::"), n_args = 2) - - if (colon) { - - # validate the package name - lhs <- node[[1L]][[2L]] - if (as.character(lhs) != package) - return(NULL) + if (is.call(call <- node[[1L]])) + if (is.symbol(symbol <- call[[1L]])) + if (symbol == "::" || symbol == ":::") + if (call[[2L]] == package) + node[[1L]] <- call[[3L]] - # extract the inner call - rhs <- node[[1L]][[3L]] - node[[1L]] <- rhs - } - - # check for method match - match <- - is.name(node[[1L]]) && - as.character(node[[1L]]) %in% methods + # check for any method match + if (is.symbol(symbol <- node[[1L]])) + if (any(symbol == methods)) + result <- node - if (!match) - return(NULL) - - node + result } -renv_call_normalize <- function(node, stack) { +renv_call_normalize <- function(node) { # check for magrittr pipe -- if this part of the expression is # being piped into, then we need to munge the call - ispipe <- renv_call_matches(node, name = c("%>%", "%T>%", "%<>%")) - + ispipe <- renv_call_matches(node, names = c("%>%", "%T>%", "%<>%")) if (!ispipe) return(node) @@ -3707,22 +4201,17 @@ renv_call_normalize <- function(node, stack) { } -renv_call_matches <- function(call, name = NULL, n_args = NULL) { - if (!is.call(call)) - return(FALSE) +renv_call_matches <- function(call, names, nargs = NULL) { - if (!is.null(name)) { - if (!is.name(call[[1]])) - return(FALSE) + ok <- FALSE - if (!as.character(call[[1]]) %in% name) - return(FALSE) - } + if (is.call(call)) + if (is.symbol(sym <- call[[1L]])) + if (any(names == sym)) + ok <- is.null(nargs) || length(call) == nargs + 1L - if (!is.null(n_args) && length(call) != n_args + 1L) - return(FALSE) + ok - TRUE } @@ -3735,12 +4224,12 @@ caution <- function(fmt = "", ..., con = stdout()) { writeLines(sprintf(fmt, ...), con = con) } -caution_bullets <- function(preamble = NULL, - values = NULL, - postamble = NULL, - ..., - bullets = TRUE, - emitter = NULL) +bulletin <- function(preamble = NULL, + values = NULL, + postamble = NULL, + ..., + bullets = TRUE, + emitter = NULL) { if (empty(values)) return(invisible()) @@ -3748,7 +4237,7 @@ caution_bullets <- function(preamble = NULL, renv_dots_check(...) lines <- c( - if (length(preamble)) paste(preamble, collapse = "\n"), + if (length(preamble)) paste(preamble, collapse = "\n"), if (bullets) paste("-", values, collapse = "\n") else @@ -3888,7 +4377,7 @@ renv_check_unknown_source <- function(records, project = NULL) { #' Checkout a repository #' -#' `renv::checkout()` can be used to retrieve the latest-availabe packages from +#' `renv::checkout()` can be used to retrieve the latest-available packages from #' a (set of) package repositories. #' #' `renv::checkout()` is most useful with services like the Posit's @@ -3898,6 +4387,15 @@ renv_check_unknown_source <- function(records, project = NULL) { #' packages used in a particular renv project to the package versions #' provided by a particular snapshot. #' +#' Note that calling `renv::checkout()` will also install the version of `renv` +#' available as of the requested snapshot date, which might be older or lack +#' features available in the currently-installed version of `renv`. In addition, +#' the project's `renv/activate.R` script will be re-generated after checkout. +#' If this is undesired, you can re-install a newer version of `renv` after +#' checkout from your regular \R package repository. +#' +#' @section Caveats: +#' #' If your library contains packages installed from other remote sources (e.g. #' GitHub), but a version of a package of the same name is provided by the #' repositories being checked out, then please be aware that the package will be @@ -3920,12 +4418,16 @@ renv_check_unknown_source <- function(records, project = NULL) { #' [Package Manager](https://packagemanager.rstudio.com/) instance will be #' used. Ignored if `repos` is non-`NULL`. #' +#' @param restart Should the \R session be restarted after the new +#' packages have been checked out? When `NULL` (the default), the +#' session is restarted if the `"restore"` action was taken. +#' #' @param actions The action(s) to perform with the requested repositories. -#' This can either be "snapshot", in which `renv` will generate a lockfile +#' This can either be `"snapshot"`, in which `renv` will generate a lockfile #' based on the latest versions of the packages available from `repos`, or -#' "restore" if you'd like to install those packages. You can use +#' `"restore"` if you'd like to install those packages. You can use #' `c("snapshot", "restore")` if you'd like to generate a lockfile and -#' install those packages in the same step. +#' install those packages in a single call. #' #' @examples #' \dontrun{ @@ -3934,11 +4436,14 @@ renv_check_unknown_source <- function(records, project = NULL) { #' renv::checkout(date = "2023-01-02") #' #' # alternatively, supply the full repository path -#' renv::checkout(repos = "https://packagemanager.rstudio.com/cran/2023-01-02") +#' renv::checkout(repos = c(PPM = "https://packagemanager.rstudio.com/cran/2023-01-02")) #' #' # only check out some subset of packages (and their recursive dependencies) #' renv::checkout(packages = "dplyr", date = "2023-01-02") #' +#' # generate a lockfile based on a snapshot date +#' renv::checkout(date = "2023-01-02", actions = "snapshot") +#' #' } #' @export checkout <- function(repos = NULL, @@ -3947,6 +4452,7 @@ checkout <- function(repos = NULL, date = NULL, clean = FALSE, actions = "restore", + restart = NULL, project = NULL) { renv_consent_check() @@ -3969,21 +4475,45 @@ checkout <- function(repos = NULL, remotes <- renv_checkout_remotes(packages, project) # parse these into package records - records <- map(remotes, renv_remotes_resolve) + records <- map(remotes, renv_remotes_resolve, latest = TRUE) # create a lockfile matching this request lockfile <- renv_lockfile_init(project) lockfile$Packages <- records - # perform requested actions - for (action in actions) { - case( - action == "snapshot" ~ renv_lockfile_write(lockfile, file = renv_lockfile_path(project)), - action == "restore" ~ restore(lockfile = lockfile, clean = clean), - ~ stopf("unrecognized action '%s'") - ) + if ("restore" %in% actions) local({ + + # install the requested packages + restore(lockfile = lockfile, clean = clean) + + # make sure we can find 'renv' on the library paths + path <- renv_namespace_path("renv") + renv_scope_libpaths(c(dirname(path), renv_libpaths_all())) + + # invoke activate + args <- c("--vanilla", "-s", "-e", shQuote("renv::activate()")) + r(args) + + # update the renv lockfile record + # (note: it might not be available when running tests) + renv <- renv_lockfile_records(lockfile)[["renv"]] + if (!is.null(renv)) { + renv_scope_options(renv.verbose = FALSE) + record(records = list(renv = renv), project = project) + } + + }) + + # re-generate the lockfile if requested + if ("snapshot" %in% actions) { + snapshot(project) } + # try to restart the session if we installed some packages + restart <- restart %||% "restore" %in% actions + if (restart) + renv_restart_request(project = project, reason = "renv has been updated") + invisible(lockfile) } @@ -4012,7 +4542,7 @@ renv_checkout_remotes <- function(packages, project) { # remove ignored packages -- note we intentionally do this before # computing recursive dependencies as we don't want to allow users # to ignore a recursive dependency of a required package - ignored <- c("renv", renv_project_ignored_packages(project)) + ignored <- renv_project_ignored_packages(project) packages <- setdiff(packages, ignored) # compute recursive dependencies for these packages @@ -4248,7 +4778,7 @@ renv_clean_library_tempdirs <- function(project, prompt) { # nocov start if (prompt || renv_verbose()) { - caution_bullets("The following directories will be removed:", bad) + bulletin("The following directories will be removed:", bad) if (prompt && !proceed()) cancel() @@ -4294,7 +4824,7 @@ renv_clean_system_library <- function(project, prompt) { # nocov start if (prompt || renv_verbose()) { - caution_bullets( + bulletin( "The following non-system packages are installed in the system library:", packages, c( @@ -4324,9 +4854,12 @@ renv_clean_unused_packages <- function(project, prompt) { # find packages installed in the project library library <- renv_paths_library(project = project) - installed <- list.files(library) + installed <- list.files(library, pattern = renv_regexps_package_name()) if (empty(installed)) return(ntd()) + + # ignore 'pak' if we're configured to use it + installed <- setdiff(installed, if (config$pak.enabled()) "pak") # find packages used in the project and their recursive dependencies packages <- renv_snapshot_dependencies(project, dev = TRUE) @@ -4341,7 +4874,7 @@ renv_clean_unused_packages <- function(project, prompt) { # nocov start if (prompt || renv_verbose()) { - caution_bullets( + bulletin( c( "The following packages are installed in the project library,", "but appear to be no longer used in your project." @@ -4386,7 +4919,7 @@ renv_clean_package_locks <- function(project, prompt) { # nocov start if (prompt || renv_verbose()) { - caution_bullets( + bulletin( "The following stale package locks were discovered in your library:", basename(old), "These locks will be removed." @@ -4420,7 +4953,7 @@ renv_clean_cache <- function(project, prompt) { missing <- !file.exists(projlist) if (any(missing)) { - caution_bullets( + bulletin( "The following projects are monitored by renv, but no longer exist:", projlist[missing], "These projects will be removed from renv's project list." @@ -4456,7 +4989,7 @@ renv_clean_cache <- function(project, prompt) { if (prompt || renv_verbose()) { - caution_bullets( + bulletin( "The following packages are installed in the cache but no longer used:", renv_cache_format_path(diff), "These packages will be removed." @@ -4598,7 +5131,7 @@ renv_cli_exec_impl <- function(clargs) { return(renv_cli_unknown(method, exports)) # begin building call - args <- list(call("::", as.name("renv"), as.name(method))) + args <- list(call("::", as.symbol("renv"), as.symbol(method))) for (clarg in clargs[-1L]) { @@ -4812,6 +5345,15 @@ config <- list( ) }, + bioconductor.init = function(..., default = NULL) { + renv_config_get( + name = "bioconductor.init", + type = "*", + default = default, + args = list(...) + ) + }, + bitbucket.host = function(..., default = "api.bitbucket.org/2.0") { renv_config_get( name = "bitbucket.host", @@ -5118,6 +5660,15 @@ config <- list( ) }, + sysreqs.check = function(..., default = TRUE) { + renv_config_get( + name = "sysreqs.check", + type = "logical[1]", + default = default, + args = list(...) + ) + }, + updates.check = function(..., default = FALSE) { renv_config_get( name = "updates.check", @@ -5272,7 +5823,7 @@ renv_config_get <- function(name, return(renv_config_validate(name, optval, type, default, args)) # check for environment variable - envname <- gsub(".", "_", toupper(name), fixed = TRUE) + envname <- chartr(".", "_", toupper(name)) envkey <- paste("RENV", toupper(scope), envname, sep = "_") envval <- Sys.getenv(envkey, unset = NA) if (!is.na(envval) && nzchar(envval)) { @@ -5303,12 +5854,57 @@ renv_config_decode_envvar <- function(envname, envval) { return(get(envval, envir = map, inherits = FALSE)) libvars <- c("RENV_CONFIG_EXTERNAL_LIBRARIES", "RENV_CONFIG_HYDRATE_LIBPATHS") - pattern <- if (envname %in% libvars) - "\\s*[:;,]\\s*" - else - "\\s*,\\s*" + if (envname %in% libvars) { + decoded <- renv_config_decode_libpaths(envval) + return(decoded) + } + + # handle repos override with KEY=VAL;KEY2=VAL2 format + if (identical(envname, "RENV_CONFIG_REPOS_OVERRIDE")) { + decoded <- renv_config_decode_keyval(envval) + return(decoded) + } + + strsplit(envval, "\\s*,\\s*", perl = TRUE)[[1L]] + +} + +renv_config_decode_libpaths <- function(envval) { + + # get the location of potential split delimiters + pattern <- "\\s*[:;,]\\s*" + indices <- gregexpr(pattern, envval, perl = TRUE)[[1L]] + if (identical(c(indices), -1L)) + return(envval) + + # drop delimiters that are a distance of 2 from previous + # https://github.com/rstudio/renv/issues/2069 + diffs <- diff(c(0L, indices)) + indices <- indices[diffs != 2L] + + # split at the discovered indices + starts <- c(1L, indices + 1L) + ends <- c(indices - 1L, nchar(envval)) + substring(envval, starts, ends) + +} + +renv_config_decode_keyval <- function(envval) { + + # split on ';' if present + parts <- strsplit(envval, ";", fixed = TRUE)[[1L]] + + # split into named repositories if present + idx <- regexpr("=", parts, fixed = TRUE) + keys <- substring(parts, 1L, idx - 1L) + vals <- substring(parts, idx + 1L) + names(vals) <- keys - strsplit(envval, pattern, perl = TRUE)[[1L]] + # if we have a single unnamed repository, call it CRAN + if (length(vals) == 1L && identical(keys, "")) + names(vals) <- "CRAN" + + vals } @@ -5540,6 +6136,34 @@ renv_cran_status_maintainer_email <- function(package = NULL) { } +renv_cran_mirrors_impl <- function() { + + tryCatch( + getCRANmirrors(local.only = TRUE), + error = function(cnd) { + warning(conditionMessage(cnd)) + NULL + } + ) + +} + +renv_cran_mirrors <- function() { + + mirrors <- memoize( + key = "renv_cran_mirrors", + value = renv_cran_mirrors_impl() + ) + + c( + getOption("renv.cran.mirrors", default = character()), + mirrors$URL, + "https://cran.rstudio.com/", + "https://cran.rstudio.org/" + ) + +} + # nocov end @@ -5652,7 +6276,7 @@ as_data_frame <- function(data) { # recycle columns n <- lengths(data, use.names = FALSE) - nrow <- max(n) + nrow <- max(n, 0L) # start recycling for (i in seq_along(data)) { @@ -5786,8 +6410,12 @@ renv_dcf_read_impl <- function(file, ...) { renv_dcf_write <- function(x, file = "") { + # NOTE: Older versions of write.dcf() will coerce the value into a data.frame + # without setting 'optional = TRUE'; make sure we do this ourselves first + value <- as_data_frame(x) + keep.white <- c("Description", "Authors@R", "Author", "Built", "Packaged") - result <- write.dcf(as.list(x), file = file, indent = 4L, width = 80L, keep.white = keep.white) + result <- write.dcf(value, file = file, indent = 4L, width = 80L, keep.white = keep.white) renv_filebacked_invalidate(file) @@ -5875,6 +6503,17 @@ renv_debuggify_dump_impl_one <- function(var, call, frame) { # environment hosting exit callbacks the$defer_callbacks <- new.env(parent = emptyenv()) +renv_defer_init <- function() { + + # make sure we run callbacks set on the global environment on exit + # but only in non-interactive sessions, just to be safe + if (interactive()) + return() + + reg.finalizer(.GlobalEnv, renv_defer_execute, onexit = TRUE) + +} + defer <- function(expr, scope = parent.frame()) { handler <- renv_defer_add( @@ -5947,28 +6586,28 @@ renv_defer_add <- function(envir, handler) { #' Find R package dependencies in a project #' #' @description -#' `dependencies()` will crawl files within your project, looking for \R files +#' `dependencies()` will scan files within your project, looking for \R files #' and the packages used within those \R files. This is done primarily by #' parsing the code and looking for calls of the form `library(package)`, #' `require(package)`, `requireNamespace("package")`, and `package::method()`. #' renv also supports package loading with #' [box](https://cran.r-project.org/package=box) (`box::use(...)`) and -#' [pacman](https://cran.r-project.org/package=pacman) (`pacman::p_load(...)`) -#' . +#' [pacman](https://cran.r-project.org/package=pacman) (`pacman::p_load(...)`). #' -#' For \R package projects, dependencies expressed in the `DESCRIPTION` file -#' will also be discovered. +#' For \R package projects, `renv` will also detect dependencies expressed +#' in the `DESCRIPTION` file. For projects using Python, \R dependencies within +#' the \R code chunks of your project's `.ipynb` files will also be used. #' -#' Note that the rmarkdown package is required in order to crawl dependencies -#' in R Markdown files. +#' Note that the \code{\link[rmarkdown:rmarkdown-package]{rmarkdown}} package is +#' required in order to scan dependencies in R Markdown files. #' #' # Missing dependencies #' #' `dependencies()` uses static analysis to determine which packages are used -#' by your project. This means that it inspects, but doesn't run, your -#' source. Static analysis generally works well, but is not 100% reliable in -#' detecting the packages required by your project. For example, renv is -#' unable to detect this kind of usage: +#' by your project. This means that it inspects, but doesn't run, the \R code +#' in your project. Static analysis generally works well, but is not +#' 100% reliable in detecting the packages required by your project. For +#' example, `renv` is unable to detect this kind of usage: #' #' ```{r eval=FALSE} #' for (package in c("dplyr", "ggplot2")) { @@ -5977,8 +6616,9 @@ renv_defer_add <- function(envir, handler) { #' ``` #' #' It also can't generally tell if one of the packages you use, uses one of -#' its suggested packages. For example, `tidyr::separate_wider_delim()` -#' uses the stringr package which is only suggested, not required by tidyr. +#' its suggested packages. For example, the `tidyr::separate_wider_delim()` +#' function requires the `stringr` package, but `stringr` is only suggested, +#' not required, by `tidyr`. #' #' If you find that renv's dependency discovery misses one or more packages #' that you actually use in your project, one escape hatch is to include a file @@ -5990,25 +6630,6 @@ renv_defer_add <- function(envir, handler) { #' library(stringr) #' ``` #' -#' # Explicit dependencies -#' -#' Alternatively, you can suppress dependency discover and instead rely -#' on an explicit set of packages recorded by you in a project `DESCRIPTION` file. -#' Call `renv::settings$snapshot.type("explicit")` to enable "explicit" mode, -#' then enumerate your dependencies in a project `DESCRIPTION` file. -#' -#' In that case, your `DESCRIPTION` might look something like this: -#' -#' ``` -#' Type: project -#' Description: My project. -#' Depends: -#' tidyverse, -#' devtools, -#' shiny, -#' data.table -#' ``` -#' #' # Ignoring files #' #' By default, renv will read your project's `.gitignore`s (if present) to @@ -6036,7 +6657,32 @@ renv_defer_add <- function(envir, handler) { #' Using ignore files is important if your project contains a large number #' of files; for example, if you have a `data/` directory containing many #' text files. - +#' +#' +#' ## Profile-specific Ignore Rules +#' +#' Profile-specific sections are also supported in `.renvignore` files. +#' These sections are marked with a comment header of the form `#| `, +#' where `` is \R code that indicates if this section of the `.renvignore` +#' should apply. The `profile` variable is set to the same value as the current +#' profile, or `"default"` if the default profile (no profile) is selected. +#' See `vignette("profiles", package = "renv")` for more information on profiles. +#' +#' ``` +#' # ignore all directories by default +#' */ +#' +#' #| profile == "default" +#' !default +#' +#' #| profile == "extra" +#' !extra +#' ``` +#' +#' Note that the first section in a `.renvignore` file implicitly applies to +#' all profiles. +#' +#' #' # Errors #' #' renv's attempts to enumerate package dependencies in your project can fail @@ -6176,6 +6822,14 @@ renv_dependencies_impl <- function( # resolve errors errors <- match.arg(errors) + # the path to the user .Rprofile is used when discovering dependencies, + # so resolve that eagerly now + renv_scope_binding( + envir = the$paths, + symbol = "r_profile_user", + replacement = Sys.getenv("R_PROFILE_USER", unset = path.expand("~/.Rprofile")) + ) + before <- Sys.time() renv_dependencies_scope(root = root) files <- renv_dependencies_find(path, root) @@ -6184,17 +6838,20 @@ renv_dependencies_impl <- function( elapsed <- difftime(after, before, units = "secs") renv_condition_signal("renv.dependencies.elapsed_time", elapsed) - renv_dependencies_report(errors) - deps <- if (empty(deps) || nrow(deps) == 0L) { - renv_dependencies_list_empty() - } else { - # drop NAs, and only keep 'dev' dependencies if requested - rows(deps, deps$Dev %in% c(dev, FALSE)) + if (empty(deps) || nrow(deps) == 0L) { + result <- renv_dependencies_list_empty() + return(take(result, field)) } - take(deps, field) + # drop other NAs, just in case -- this really is an issue in the underlying + # dependency computation code somewhere, but we still want to insulate users + # from unexpected errors + # + # https://github.com/rstudio/renv/issues/2110 + keep <- !is.na(deps$Package) & deps$Dev %in% c(dev, FALSE) + take(rows(deps, keep), field) } renv_dependencies_root <- function(path = getwd()) { @@ -6230,18 +6887,16 @@ renv_dependencies_root_impl <- function(path) { renv_dependencies_callback <- function(path) { - # user .Rprofile - if (renv_path_same(path, Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile"))) { - return(function(path) renv_dependencies_discover_r(path, dev = TRUE)) - } - cbname <- list( + ".lintr" = function(path) renv_dependencies_discover_lintr(path), ".Rprofile" = function(path) renv_dependencies_discover_r(path), "DESCRIPTION" = function(path) renv_dependencies_discover_description(path), "NAMESPACE" = function(path) renv_dependencies_discover_namespace(path), "_bookdown.yml" = function(path) renv_dependencies_discover_bookdown(path), "_pkgdown.yml" = function(path) renv_dependencies_discover_pkgdown(path), "_quarto.yml" = function(path) renv_dependencies_discover_quarto(path), + "_server.yml" = function(path) renv_dependencies_discover_plumber_server(path), + "_server.yaml" = function(path) renv_dependencies_discover_plumber_server(path), "renv.lock" = function(path) renv_dependencies_discover_renv_lock(path), "rsconnect" = function(path) renv_dependencies_discover_rsconnect(path) ) @@ -6299,9 +6954,9 @@ renv_dependencies_find <- function(path = getwd(), root = getwd()) { extra <- renv_dependencies_find_extra(root) if (config$user.profile()) { - rprofile_path <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile") - if (file.exists(rprofile_path)) { - extra <- c(extra, rprofile_path) + profile <- the$paths$r_profile_user + if (file.exists(profile)) { + extra <- c(extra, profile) } } @@ -6437,13 +7092,13 @@ renv_dependencies_discover_impl <- function(path) { return(NULL) } - tryCatch( - filebacked("dependencies", path, callback), - error = function(cnd) { - warning(cnd) - NULL - } - ) + status <- catch(filebacked("dependencies", path, callback)) + if (inherits(status, "error")) { + signalCondition(warnify(status)) + NULL + } + + status } @@ -6457,7 +7112,7 @@ renv_dependencies_discover_preflight <- function(paths, errors) { lines <- c( "A large number of files (%i in total) have been discovered.", - "It may take renv a long time to crawl these files for dependencies.", + "It may take renv a long time to scan these files for dependencies.", "Consider using .renvignore to ignore irrelevant files.", "See `?renv::dependencies` for more information.", "Set `options(renv.config.dependencies.limit = Inf)` to disable this warning.", @@ -6523,16 +7178,20 @@ renv_dependencies_discover_description <- function(path, path = path ) + names(data) <- fields + # if this is a bioconductor package, add their implicit dependencies - if ("biocViews" %in% names(dcf)) { + # guard against packages which have an empty biocViews field + # https://github.com/rstudio/renv/issues/2149 + if (nzchar(dcf[["biocViews"]] %||% "")) { data[[length(data) + 1L]] <- renv_dependencies_list( source = path, packages = c(renv_bioconductor_manager(), "BiocVersion") ) + names(data)[[length(data)]] <- "Bioconductor" } - bind(data) - + bind(data, index = "Type") } renv_dependencies_discover_namespace <- function(path) { @@ -6587,6 +7246,14 @@ renv_dependencies_discover_description_impl <- function(dcf, field, path) { m <- regexec(pattern, x) matches <- regmatches(x, m) + if (empty(matches)) + return(list()) + + # drop R (https://github.com/rstudio/renv/issues/1806) + matches <- filter(matches, function(match) { + !identical(match[[2L]], "R") + }) + if (empty(matches)) return(list()) @@ -6622,6 +7289,25 @@ renv_dependencies_discover_quarto <- function(path) { renv_dependencies_list_empty() } +renv_dependencies_discover_plumber_server <- function(path) { + # require yaml package for parsing YAML + if (!renv_dependencies_require("yaml", basename(path))) + return(renv_dependencies_list_empty()) + + # read and parse yaml file + contents <- catch(yaml::read_yaml(path)) + if (inherits(contents, "error")) + return(renv_dependencies_error(path, error = contents)) + + # check if engine field exists and has a value + engine <- contents$engine + if (!pstring(engine) || !nzchar(engine)) + return(renv_dependencies_list_empty()) + + # return the engine as a dependency + renv_dependencies_list(path, engine) +} + renv_dependencies_discover_rsconnect <- function(path) { renv_dependencies_list(path, "rsconnect") } @@ -6676,6 +7362,12 @@ renv_dependencies_discover_rmd_yaml_header <- function(path, mode) { if (inherits(yaml, "error")) return(renv_dependencies_error(path, error = yaml, packages = "rmarkdown")) + # https://github.com/rstudio/renv/issues/2117 + if (!is.list(yaml)) { + msg <- "document contains an unexpected or malformed YAML header" + return(renv_dependencies_error(path, error = msg, packages = "rmarkdown")) + } + # check for Shiny runtime runtime <- yaml[["runtime"]] %||% "" if (pstring(runtime) && grepl("shiny", runtime, fixed = TRUE)) @@ -6691,12 +7383,12 @@ renv_dependencies_discover_rmd_yaml_header <- function(path, mode) { pattern <- renv_regexps_package_name() # check recursively for package usages of the form 'package::method' - recurse(yaml, function(node, stack) { + recurse(yaml, function(node) { # look for keys of the form 'package::method' values <- c(names(node), if (pstring(node)) node) for (value in values) { call <- tryCatch(parse(text = value)[[1]], error = function(err) NULL) - if (renv_call_matches(call, name = c("::", ":::"), n_args = 2)) { + if (renv_call_matches(call, names = c("::", ":::"), nargs = 2L)) { deps$push(as.character(call[[2L]])) } } @@ -6759,7 +7451,7 @@ renv_dependencies_discover_chunks_ignore <- function(chunk) { # skip non-R chunks engine <- chunk$params[["engine"]] - ok <- is.character(engine) && engine %in% c("r", "rscript") + ok <- is.character(engine) && tolower(engine) %in% c("r", "rscript") if (!ok) return(TRUE) @@ -6772,9 +7464,13 @@ renv_dependencies_discover_chunks_ignore <- function(chunk) { return(TRUE) # skip chunks whose labels end in '-display' - label <- chunk$params[["label"]] %||% "" - if (grepl("-display$", label)) + label <- chunk$params[["label"]] + if (is.character(label) && + length(label) == 1L && + grepl("-display$", label)) + { return(TRUE) + } # ok, don't ignore this chunk FALSE @@ -6850,7 +7546,7 @@ renv_dependencies_discover_chunks <- function(path, mode) { if (mode %in% "qmd") { for (chunk in chunks) { engine <- chunk$params[["engine"]] - if (is.character(engine) && engine %in% c("r", "rscript")) { + if (is.character(engine) && tolower(engine) %in% c("r", "rscript")) { qdeps <- renv_dependencies_list(path, "rmarkdown") break } @@ -6928,7 +7624,13 @@ renv_dependencies_discover_chunks_ranges <- function(path, contents, patterns) { renv_dependencies_discover_ipynb <- function(path) { - json <- renv_json_read(path) + json <- catch(renv_json_read(path)) + if (inherits(json, "error")) { + info <- renv_file_info(path) + if (!is.na(info$size) && info$size > 1) + renv_dependencies_error(path, error = json) + } + if (!identical(json$metadata$kernelspec$language, "R")) return() @@ -6962,11 +7664,15 @@ renv_dependencies_discover_rproj <- function(path) { } -renv_dependencies_discover_r <- function(path = NULL, - text = NULL, - expr = NULL, +renv_dependencies_discover_lintr <- function(path) { + renv_dependencies_list(path, "lintr", dev = TRUE) +} + +renv_dependencies_discover_r <- function(path = NULL, + text = NULL, + expr = NULL, envir = NULL, - dev = FALSE) + dev = NULL) { expr <- case( is.function(expr) ~ body(expr), @@ -6980,6 +7686,9 @@ renv_dependencies_discover_r <- function(path = NULL, if (inherits(expr, "error")) return(renv_dependencies_error(path, error = expr)) + # resolve dev + dev <- dev %||% path == the$paths$r_profile_user + # update current path state <- renv_dependencies_state() if (!is.null(state)) @@ -6991,37 +7700,64 @@ renv_dependencies_discover_r <- function(path = NULL, renv_dependencies_discover_r_library_require, renv_dependencies_discover_r_require_namespace, renv_dependencies_discover_r_colon, + renv_dependencies_discover_r_citation, + renv_dependencies_discover_r_data, renv_dependencies_discover_r_pacman, renv_dependencies_discover_r_modules, renv_dependencies_discover_r_import, - renv_dependencies_discover_r_box, + renv_dependencies_discover_r_use, renv_dependencies_discover_r_targets, renv_dependencies_discover_r_glue, + renv_dependencies_discover_r_ggplot2, renv_dependencies_discover_r_parsnip, + renv_dependencies_discover_r_testthat, + renv_dependencies_discover_r_knitr, renv_dependencies_discover_r_database ) envir <- envir %||% new.env(parent = emptyenv()) - recurse(expr, function(node, stack) { + callback <- if (renv_ext_enabled()) { + + function(node) { + node <- renv_call_normalize(node) + for (method in methods) + method(node, envir) + invisible(node) + } + + } else { - # normalize calls (handle magrittr pipes) - node <- renv_call_normalize(node, stack) + function(node) { - # invoke methods on call objects - if (is.call(node)) + node <- renv_call_normalize(node) for (method in methods) - method(node, stack, envir) + method(node, envir) - # return node - node + assign("object", node, envir = parent.frame()) + invisible(node) - }) + } + } + + renv_dependencies_recurse(expr, callback) packages <- ls(envir = envir, all.names = TRUE) + + # also try to detect knitr::spin() dependencies -- this needs to + # happen outside of the regular dependency discovery machinery + # as it will rely on checking comments in the document + # + # https://github.com/rstudio/renv/issues/2023 + if (is.character(text) || is.character(path)) { + text <- text %||% readLines(path, n = 1L, warn = FALSE) + if (length(text) && grepl("^\\s*#'\\s*[-]{3}\\s*$", text[[1L]], perl = TRUE)) + packages <- union(c("knitr", "rmarkdown"), packages) + } + renv_dependencies_list(path, packages, dev = dev) } -renv_dependencies_discover_r_methods <- function(node, stack, envir) { +renv_dependencies_discover_r_methods <- function(node, envir) { node <- renv_call_expect(node, "methods", c("setClass", "setGeneric")) if (is.null(node)) @@ -7032,7 +7768,7 @@ renv_dependencies_discover_r_methods <- function(node, stack, envir) { } -renv_dependencies_discover_r_xfun <- function(node, stack, envir) { +renv_dependencies_discover_r_xfun <- function(node, envir) { node <- renv_call_expect(node, "xfun", c("pkg_attach", "pkg_attach2")) if (is.null(node)) @@ -7046,7 +7782,7 @@ renv_dependencies_discover_r_xfun <- function(node, stack, envir) { # extract character vectors from `...` strings <- stack() - recurse(matched[["..."]], function(node, stack) { + recurse(matched[["..."]], function(node) { if (is.character(node)) strings$push(node) }) @@ -7062,7 +7798,7 @@ renv_dependencies_discover_r_xfun <- function(node, stack, envir) { TRUE } -renv_dependencies_discover_r_library_require <- function(node, stack, envir) { +renv_dependencies_discover_r_library_require <- function(node, envir) { node <- renv_call_expect(node, "base", c("library", "require")) if (is.null(node)) @@ -7093,7 +7829,7 @@ renv_dependencies_discover_r_library_require <- function(node, stack, envir) { } -renv_dependencies_discover_r_require_namespace <- function(node, stack, envir) { +renv_dependencies_discover_r_require_namespace <- function(node, envir) { node <- renv_call_expect(node, "base", c("requireNamespace", "loadNamespace")) if (is.null(node)) @@ -7115,10 +7851,9 @@ renv_dependencies_discover_r_require_namespace <- function(node, stack, envir) { } -renv_dependencies_discover_r_colon <- function(node, stack, envir) { - - ok <- renv_call_matches(node, name = c("::", ":::"), n_args = 2) +renv_dependencies_discover_r_colon <- function(node, envir) { + ok <- renv_call_matches(node, names = c("::", ":::"), nargs = 2L) if (!ok) return(FALSE) @@ -7126,7 +7861,7 @@ renv_dependencies_discover_r_colon <- function(node, stack, envir) { if (is.symbol(package)) package <- as.character(package) - if (!is.character(package) || length(package) != 1) + if (!is.character(package) || length(package) != 1L) return(FALSE) envir[[package]] <- TRUE @@ -7134,7 +7869,45 @@ renv_dependencies_discover_r_colon <- function(node, stack, envir) { } -renv_dependencies_discover_r_pacman <- function(node, stack, envir) { +renv_dependencies_discover_r_citation <- function(node, envir) { + + node <- renv_call_expect(node, "utils", "citation") + if (is.null(node)) + return(FALSE) + + matched <- catch(match.call(utils::citation, node)) + if (inherits(matched, "error")) + return(FALSE) + + package <- matched[["package"]] + if (!is.character(package) || length(package) != 1L) + return(FALSE) + + envir[[package]] <- TRUE + TRUE + +} + +renv_dependencies_discover_r_data <- function(node, envir) { + + node <- renv_call_expect(node, "utils", "data") + if (is.null(node)) + return(FALSE) + + matched <- catch(match.call(utils::data, node)) + if (inherits(matched, "error")) + return(FALSE) + + package <- matched[["package"]] + if (!is.character(package) || length(package) != 1L) + return(FALSE) + + envir[[package]] <- TRUE + TRUE + +} + +renv_dependencies_discover_r_pacman <- function(node, envir) { node <- renv_call_expect(node, "pacman", "p_load") if (is.null(node) || length(node) < 2) @@ -7150,7 +7923,7 @@ renv_dependencies_discover_r_pacman <- function(node, stack, envir) { char <- node[["char"]] # detect vector of packages passed as vector - if (renv_call_matches(char, name = "c")) + if (renv_call_matches(char, "c")) parts <- c(parts, as.list(char[-1L])) # detect plain old package name @@ -7186,32 +7959,31 @@ renv_dependencies_discover_r_pacman <- function(node, stack, envir) { } -renv_dependencies_discover_r_modules <- function(node, stack, envir) { +renv_dependencies_discover_r_modules <- function(node, envir) { - # check for call of the form 'pkg::foo(a, b, c)' - colon <- renv_call_matches(node[[1]], name = c("::", ":::"), n_args = 2) - - node <- renv_call_expect(node, "modules", c("import")) - if (is.null(node)) - return(FALSE) + # check for an explicit call to 'modules::import()' + if (identical(node[[1L]], quote(modules::import))) { + renv_dependencies_discover_r_modules_impl(node, envir) + } - ok <- FALSE - if (colon) { - # include if fully qualified call to modules::import - ok <- TRUE - } else { - # otherwise only consider calls within a 'module' block - # (to reduce confusion with reticulate::import) - for (parent in stack) { - parent <- renv_call_expect(parent, "modules", c("amodule", "module")) - if (!is.null(parent)) { - ok <- TRUE - break - } - } + # check for 'import' usages with a module block + node <- renv_call_expect(node, "modules", "module") + if (length(node) >= 2L && + identical(node[[1L]], quote(module)) && + is.call(node[[2L]]) && + identical(node[[2L]][[1L]], as.symbol("{"))) + { + renv_dependencies_recurse(node[[2L]], function(node) { + renv_dependencies_discover_r_modules_impl(node, envir) + }) } - if (!ok) +} + +renv_dependencies_discover_r_modules_impl <- function(node, envir) { + + node <- renv_call_expect(node, "modules", c("import")) + if (is.null(node)) return(FALSE) # attempt to match the call @@ -7228,11 +8000,16 @@ renv_dependencies_discover_r_modules <- function(node, stack, envir) { # package could be symbols or character so call as.character # to be safe then mark packages as known envir[[as.character(package)]] <- TRUE - TRUE + } -renv_dependencies_discover_r_import <- function(node, stack, envir) { +renv_dependencies_discover_r_import <- function(node, envir) { + + # require that usages are colon-prefixed + colon <- renv_call_matches(node[[1L]], names = c("::", ":::"), nargs = 2L) + if (!colon) + return(FALSE) node <- renv_call_expect(node, "import", c("from", "here", "into")) if (is.null(node)) @@ -7249,40 +8026,94 @@ renv_dependencies_discover_r_import <- function(node, stack, envir) { if (inherits(matched, "error")) return(FALSE) - # the '.from' argument is the package name, either a character vector of length one or a symbol + # the '.from' argument is the package name + # either a character vector of length one or a symbol from <- matched$.from - if (is.symbol(from)) - from <- as.character(from) - - ok <- - is.character(from) && - length(from) == 1 + if (is.symbol(from)) { + co <- node[[".character_only"]] + if (!identical(co, TRUE)) + from <- as.character(from) + } + ok <- is.character(from) && length(from) == 1L if (!ok) return(FALSE) + # '.from' can also be an R script; if it appears to be a path, then ignore it + # this is unfortunately problematic for some packages like 'treesitter.r' + # + # https://github.com/rstudio/renv/issues/1743 + # https://github.com/rstudio/renv/issues/2212 + if (grepl("\\.[rR]$", from, perl = TRUE)) + return(FALSE) + envir[[from]] <- TRUE TRUE } -renv_dependencies_discover_r_box <- function(node, stack, envir) { +renv_dependencies_discover_r_use <- function(node, envir) { - node <- renv_call_expect(node, "box", "use") - if (is.null(node)) + # There are multiple possible packages providing a function called 'use'. + # renv will currently assume that any invocation of 'use' without a + # package prefix is one that belongs to 'base'. + if (is.call(node) && identical(node[[1L]], as.symbol("use"))) + return(renv_dependencies_discover_r_use_base(node, envir)) + + # `base::use()` + m <- renv_call_expect(node, "base", "use") + if (length(m)) + return(renv_dependencies_discover_r_use_base(m, envir)) + + # `renv::use()` + m <- renv_call_expect(node, "renv", "use") + if (length(m)) { + pkgs <- setdiff(names(m), names(formals(renv::use))) + for (pkg in pkgs) + if (nzchar(pkg)) + envir[[pkg]] <- TRUE + return(TRUE) + } + + # `box::use()` + m <- renv_call_expect(node, "box", "use") + if (length(m)) { + for (i in seq.int(2L, length.out = length(m) - 1L)) + renv_dependencies_discover_r_use_box(m[[i]], envir) + return(TRUE) + } + + # no implementation matched + FALSE + +} + +renv_dependencies_discover_r_use_base <- function(node, envir) { + + # attempt to match the call + matched <- tryCatch( + match.call(function(package, include.only) {}, node), + error = identity + ) + + if (inherits(matched, "error")) return(FALSE) - for (i in seq.int(2L, length.out = length(node) - 1L)) - renv_dependencies_discover_r_box_impl(node[[i]], stack, envir) + # check for a character argument + package <- matched[["package"]] + if (!is.character(package)) + return(FALSE) + # add to dependency set + envir[[package]] <- TRUE TRUE } -renv_dependencies_discover_r_box_impl <- function(node, stack, envir) { +renv_dependencies_discover_r_use_box <- function(node, envir) { # if the call uses /, it's a path, not a package - while (renv_call_matches(node, name = "/")) + if (renv_call_matches(node, "/")) return(FALSE) # if the node is just a symbol, then it's the name of a package @@ -7290,7 +8121,7 @@ renv_dependencies_discover_r_box_impl <- function(node, stack, envir) { name <- if (is.symbol(node) && !identical(node, quote(expr = ))) { as.character(node) } else if ( - renv_call_matches(node, name = "[") && + renv_call_matches(node, "[") && length(node) > 1L && is.symbol(node[[2L]])) { as.character(node[[2L]]) @@ -7305,7 +8136,7 @@ renv_dependencies_discover_r_box_impl <- function(node, stack, envir) { } -renv_dependencies_discover_r_targets <- function(node, stack, envir) { +renv_dependencies_discover_r_targets <- function(node, envir) { node <- renv_call_expect(node, "targets", "tar_option_set") if (is.null(node)) @@ -7331,7 +8162,7 @@ renv_dependencies_discover_r_targets <- function(node, stack, envir) { } -renv_dependencies_discover_r_glue <- function(node, stack, envir) { +renv_dependencies_discover_r_glue <- function(node, envir) { node <- renv_call_expect(node, "glue", "glue") if (is.null(node)) @@ -7350,6 +8181,91 @@ renv_dependencies_discover_r_glue <- function(node, stack, envir) { } +renv_dependencies_discover_r_ggplot2 <- function(node, envir) { + + node <- renv_call_expect(node, "ggplot2", "ggsave") + if (is.null(node)) + return(FALSE) + + # check for attempts to save to '.svg', and assume svglite is + # required in this scenario. + matched <- catch(match.call(function(filename, ...) {}, node)) + if (inherits(matched, "error")) + return(FALSE) + + filename <- matched$filename + if (!is.character(filename)) + return(FALSE) + + if (!endswith(filename, ".svg")) + return(FALSE) + + envir[["svglite"]] <- TRUE + TRUE + +} + +renv_dependencies_discover_r_testthat <- function(node, envir) { + + # check for construction of JunitReporter + if (identical(node, quote(JunitReporter$new))) { + envir[["xml2"]] <- TRUE + return(TRUE) + } + + # check for an R6 class inheriting from a JunitReporter + class <- renv_call_expect(node, "R6", "R6Class") + if (!is.null(class) && identical(class$inherit, quote(JunitReporter))) { + envir[["xml2"]] <- TRUE + return(TRUE) + } + + # check for calls to various test runners, which accept a reporter + node <- renv_call_expect(node, "testthat", c("test_package", "test_dir", "test_file")) + if (is.null(node)) + return(FALSE) + + candidates <- list( + "Junit", + "junit", + quote(JunitReporter), + quote(testthat::JunitReporter) + ) + + reporter <- node$reporter + if (!is.null(reporter)) { + for (candidate in candidates) { + if (identical(candidate, reporter)) { + envir[["xml2"]] <- TRUE + return(TRUE) + } + } + } + + FALSE + +} + +renv_dependencies_discover_r_knitr <- function(node, envir) { + + matched <- is.call(node) && ( + identical(node[[1L]], quote(knitr::opts_chunk$set)) || + identical(node[[1L]], quote(opts_chunk$set)) + ) + + if (!matched) + return(FALSE) + + args <- as.list(node) + if (identical(args[["dev"]], "ragg_png")) { + envir[["ragg"]] <- TRUE + return(TRUE) + } + + FALSE + +} + renv_dependencies_discover_r_glue_impl <- function(string, node, envir) { # get open, close delimiters @@ -7474,7 +8390,7 @@ renv_dependencies_discover_r_glue_impl <- function(string, node, envir) { } -renv_dependencies_discover_r_parsnip <- function(node, stack, envir) { +renv_dependencies_discover_r_parsnip <- function(node, envir) { node <- renv_call_expect(node, "parsnip", "set_engine") if (is.null(node)) @@ -7517,23 +8433,31 @@ renv_dependencies_discover_r_parsnip <- function(node, stack, envir) { } -renv_dependencies_discover_r_database <- function(node, stack, envir) { +renv_dependencies_discover_r_database <- function(node, envir) { found <- FALSE + matched <- function(requirements) { + for (requirement in requirements) + envir[[requirement]] <<- TRUE + found <<- TRUE + } + db <- renv_dependencies_database() enumerate(db, function(package, dependencies) { enumerate(dependencies, function(method, requirements) { - expect <- renv_call_expect(node, package, method) - if (is.null(expect)) - return(FALSE) - - for (requirement in requirements) - envir[[requirement]] <- TRUE + if (is.call(node)) { + expect <- renv_call_expect(node, package, method) + if (!is.null(expect)) + return(matched(requirements)) + } - found <<- TRUE - TRUE + if (is.symbol(node)) { + value <- as.character(node) + if (identical(value, method)) + return(matched(requirements)) + } }) }) @@ -7543,16 +8467,12 @@ renv_dependencies_discover_r_database <- function(node, stack, envir) { } renv_dependencies_database <- function() { - dynamic( - key = list(), - value = renv_dependencies_database_impl() - ) -} - -renv_dependencies_database_impl <- function() { - db <- getOption("renv.dependencies.database", default = list()) - db$ggplot2$geom_hex <- "hexbin" - db + the$dependencies_database <- the$dependencies_database %||% { + db <- getOption("renv.dependencies.database", default = list()) + db$ggplot2$geom_hex <- "hexbin" + db$testthat$JunitReporter <- "xml2" + db + } } renv_dependencies_list <- function(source, @@ -7640,6 +8560,10 @@ renv_dependencies_error <- function(path, error = NULL, packages = NULL) { if (is.null(error)) return(renv_dependencies_list(path, packages)) + # coerce character message errors + if (is.character(error)) + error <- simpleError(error) + # push the error report renv_dependencies_error_push(path, error) @@ -7678,7 +8602,7 @@ renv_dependencies_report <- function(errors) { paste(c(header(file), messages, ""), collapse = "\n") }) - caution_bullets( + bulletin( "WARNING: One or more problems were discovered while enumerating dependencies.", c("", lines), "Please see `?renv::dependencies` for more information.", @@ -7718,6 +8642,25 @@ renv_dependencies_eval <- function(expr) { } +renv_dependencies_recurse <- function(object, callback) { + + if (is.call(object)) + callback(object) + + if (is.recursive(object)) + for (i in seq_along(object)) + if (is.call(object[[i]])) + renv_dependencies_recurse_impl(object[[i]], callback) + +} + +renv_dependencies_recurse_impl <- function(object, callback) { + callback(object) + for (i in seq_along(object)) + if (is.call(object[[i]])) + renv_dependencies_recurse_impl(object[[i]], callback) +} + # description.R -------------------------------------------------------------- @@ -7774,18 +8717,25 @@ renv_description_read_impl <- function(path = NULL, subdir = NULL, ...) { # those from GitHub) the first entry may not be the package name, so # just consume everything up to the first slash subdir <- subdir %||% "" - parts <- c("^[^/]+", if (nzchar(subdir)) subdir, "DESCRIPTION$") + + # tolerate leading './' components in the archive paths + # https://github.com/rstudio/renv/issues/1852 + prefix <- "^(?:\\./)*[^/]+" + + # build pattern looking for the DESCRIPTION file + parts <- c(prefix, if (nzchar(subdir)) subdir, "DESCRIPTION$") pattern <- paste(parts, collapse = "/") - descs <- grep(pattern, files, value = TRUE) + descs <- grep(pattern, files, perl = TRUE, value = TRUE) if (empty(descs)) { fmt <- "archive '%s' does not appear to contain a DESCRIPTION file" stopf(fmt, renv_path_aliased(path)) } # choose the shortest DESCRPITION file matching + file <- descs[[which.min(nchar(descs))]] + # unpack into tempdir location - file <- descs[[1]] exdir <- renv_scope_tempfile("renv-description-") renv_archive_decompress(path, files = file, exdir = exdir) @@ -7870,16 +8820,16 @@ renv_description_dependency_fields_expand <- function(fields) { case( identical(field, FALSE) - ~ NULL, + ~ NULL, identical(field, "strong") || is.na(field) - ~ c("Depends", "Imports", "LinkingTo"), + ~ c("Depends", "Imports", "LinkingTo"), identical(field, "most") || identical(field, TRUE) - ~ c("Depends", "Imports", "LinkingTo", "Suggests"), + ~ c("Depends", "Imports", "LinkingTo", "Suggests"), - identical(field, "all") ~ - c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"), + identical(field, "all") + ~ c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"), field @@ -7912,10 +8862,26 @@ renv_description_remotes <- function(path) { if (is.null(remotes)) return(list()) + # if possible, resolve remotes lazily splat <- strsplit(remotes, "[[:space:]]*,[[:space:]]*")[[1]] - resolved <- lapply(splat, renv_remotes_resolve) - names(resolved) <- extract_chr(resolved, "Package") - resolved + remotes <- lapply(splat, function(spec) { + + # if this is a named remote, we can resolve it lazily + idx <- c(regexpr("=", spec, fixed = TRUE)) + result <- if (idx == -1L) { + remote <- renv_remotes_resolve(spec) + list(Package = remote$Package, Remote = remote) + } else { + package <- substring(spec, 1L, idx - 1L) + list(Package = package, Remote = function() renv_remotes_resolve(spec)) + } + + }) + + # put together into named list + records <- map(remotes, `[[`, 2L) + names(records) <- map_chr(remotes, `[[`, 1L) + records } @@ -7949,10 +8915,13 @@ diagnostics <- function(project = NULL) { renv_scope_options(renv.verbose = TRUE) reporters <- list( + renv_diagnostics_os, renv_diagnostics_session, renv_diagnostics_project, renv_diagnostics_status, renv_diagnostics_packages, + renv_diagnostics_sysreqs, + renv_diagnostics_r, renv_diagnostics_abi, renv_diagnostics_profile, renv_diagnostics_settings, @@ -7974,6 +8943,19 @@ diagnostics <- function(project = NULL) { } +renv_diagnostics_os <- function(project) { + + if (renv_platform_linux()) { + releases <- list.files("/etc", pattern = "-release$", full.names = TRUE) + for (release in releases) { + writef(header(release)) + writeLines(readLines(release)) + writef() + } + } + +} + renv_diagnostics_session <- function(project) { writef(header("Session Info")) renv_scope_options(width = 80) @@ -8056,6 +9038,52 @@ renv_diagnostics_packages <- function(project) { } +renv_diagnostics_r <- function(project) { + + makeconf <- file.path(R.home("etc"), "Makeconf") + if (file.exists(makeconf)) { + writef(header(makeconf)) + writeLines(readLines(makeconf)) + writeLines("") + } + + tools <- renv_namespace_load("tools") + keys <- c("makevars_user", "makevars_site") + for (key in keys) { + if (is.function(tools[[key]])) { + paths <- tools[[key]]() + for (path in paths) { + if (file.exists(path)) { + writef(header(path)) + writeLines(readLines(path)) + writeLines("") + } + } + } + } + + if (getRversion() >= "3.6.0") { + writef(header("R CMD config --all")) + system2(R(), c("CMD", "config", "--all")) + } + +} + +renv_diagnostics_sysreqs <- function(project) { + + if (!renv_platform_linux()) + return() + + writef(header("R System Requirements")) + + lockfile <- renv_lockfile_create(project) + records <- renv_lockfile_records(lockfile) + sysreqs <- map(records, `[[`, "SystemRequirements") + ok <- renv_sysreqs_check(sysreqs, prompt = FALSE) + invisible(ok) + +} + renv_diagnostics_packages_version <- function(lockfile, all) { data <- rep.int(NA_character_, length(all)) @@ -8118,6 +9146,9 @@ renv_diagnostics_packages_dependencies <- function(project) { renv_diagnostics_abi <- function(project) { + if (!renv_platform_linux()) + return() + writef(header("ABI")) tryCatch( renv_abi_check(), @@ -8183,8 +9214,10 @@ renv_diagnostics_envvars <- function(project) { envvars <- convert(as.list(Sys.getenv()), "character") useful <- c( + "CC", "CXX", "CPPFLAGS", "CFLAGS", "CXXFLAGS", "LDFLAGS", "R_LIBS_USER", "R_LIBS_SITE", "R_LIBS", "HOME", "LANG", "MAKE", + grep("_proxy", names(envvars), ignore.case = TRUE, value = TRUE), grep("^RENV_", names(envvars), value = TRUE) ) @@ -8477,8 +9510,16 @@ renv_download_impl <- function(url, destfile, type = NULL, request = "GET", head renv_download_default ) - # run downloader, catching errors and warnings - catchall(downloader(url, destfile, type, request, headers)) + # disable warnings in this scope; it is not safe to try and catch + # warnings as R will try to clean up open sockets after emitting + # warnings, and catching a warning would hence prevent that + # https://bugs.r-project.org/show_bug.cgi?id=18634 + catch( + withCallingHandlers( + downloader(url, destfile, type, request, headers), + warning = function(cnd) invokeRestart("muffleWarning") + ) + ) } @@ -8604,14 +9645,14 @@ renv_download_curl <- function(url, destfile, type, request, headers) { auth <- renv_download_auth(url, type) if (length(auth)) { authtext <- paste(names(auth), auth, sep = ": ") - names(authtext) <- "header" + names(authtext) <- rep.int("header", times = length(authtext)) fields <- c(fields, authtext) } # add other custom headers if (length(headers)) { lines <- paste(names(headers), headers, sep = ": ") - names(lines) <- "header" + names(lines) <- rep.int("header", times = length(lines)) fields <- c(fields, lines) } @@ -8620,6 +9661,10 @@ renv_download_curl <- function(url, destfile, type, request, headers) { vals <- renv_json_quote(fields) text <- paste(keys, vals, sep = " = ") + # remove duplicated authorization headers + dupes <- startsWith(text, "header =") & duplicated(text) + text <- text[!dupes] + # add in stand-along flags flags <- c("location", "fail", "silent", "show-error") if (request == "HEAD") @@ -8641,10 +9686,12 @@ renv_download_curl <- function(url, destfile, type, request, headers) { args$push(extra) } - # honor R_LIBCURL_SSL_REVOKE_BEST_EFFORT - # https://github.com/wch/r-source/commit/f1ec503e986593bced6720a5e9099df58a4162e7 - if (Sys.getenv("R_LIBCURL_SSL_REVOKE_BEST_EFFORT") %in% c("T", "t", "TRUE", "true")) - args$push("--ssl-revoke-best-effort") + # https://github.com/rstudio/renv/issues/1739 + if (renv_platform_windows()) { + enabled <- Sys.getenv("R_LIBCURL_SSL_REVOKE_BEST_EFFORT", unset = "TRUE") + if (truthy(enabled)) + args$push("--ssl-revoke-best-effort") + } # add in any user configuration files userconfig <- getOption( @@ -8789,7 +9836,7 @@ renv_download_auth_type <- function(url) { ) for (host in github_hosts) - if (startswith(url, host)) + if (startsWith(url, host)) return("github") gitlab_hosts <- c( @@ -8797,7 +9844,7 @@ renv_download_auth_type <- function(url) { ) for (host in gitlab_hosts) - if (startswith(url, host)) + if (startsWith(url, host)) return("gitlab") bitbucket_hosts <- c( @@ -8806,7 +9853,7 @@ renv_download_auth_type <- function(url) { ) for (host in bitbucket_hosts) - if (startswith(url, host)) + if (startsWith(url, host)) return("bitbucket") "unknown" @@ -8819,7 +9866,7 @@ renv_download_auth <- function(url, type) { switch( type, bitbucket = renv_download_auth_bitbucket(), - github = renv_download_auth_github(), + github = renv_download_auth_github(url), gitlab = renv_download_auth_gitlab(), character() ) @@ -8844,25 +9891,60 @@ renv_download_auth_bitbucket <- function() { } -renv_download_auth_github <- function() { +renv_download_auth_github <- function(url) { - pat <- renv_download_auth_github_pat() - if (is.null(pat)) + token <- renv_download_auth_github_token(url) + if (is.null(token)) return(character()) - c("Authorization" = paste("token", pat)) + c("Authorization" = paste("token", token)) } -renv_download_auth_github_pat <- function() { +renv_download_auth_github_token <- function(url) { + + # check for an existing token from environment variable + token <- renv_bootstrap_github_token() + if (length(token)) + return(token) + + # if gitcreds is available, try to use it + gitcreds <- + getOption("renv.gitcreds.enabled", default = TRUE) && + requireNamespace("gitcreds", quietly = TRUE) - pat <- Sys.getenv("GITHUB_PAT", unset = NA) - if (!is.na(pat)) - return(pat) + if (gitcreds) { - token <- tryCatch(gitcreds::gitcreds_get(), error = function(e) NULL) - if (!is.null(token)) - return(token$password) + # ensure URL has protocol pre-pended + url <- renv_retrieve_origin(url) + + # use 'github.com' for credentials instead of 'api.github.com' + url <- sub("https://api.github.com", "https://github.com", url, fixed = TRUE) + + # request credentials for URL + dlog("download", "requesting git credentials for url '%s'", url) + creds <- tryCatch( + gitcreds::gitcreds_get(url), + error = function(cnd) { + warning(conditionMessage(cnd)) + NULL + } + ) + + # use if available + if (!is.null(creds)) + return(creds$password) + + } + + # ask the user to set a GITHUB_PAT + if (once()) { + writeLines(c( + "- GitHub authentication credentials are not available.", + "- Please set GITHUB_PAT, or ensure the 'gitcreds' package is installed.", + "- See https://usethis.r-lib.org/articles/git-credentials.html for more details." + )) + } } @@ -8876,7 +9958,7 @@ renv_download_auth_gitlab <- function() { } -renv_download_headers <- function(url, type, headers) { +renv_download_headers <- function(url, type = NULL, headers = NULL) { # check for compatible download method method <- renv_download_method() @@ -8891,7 +9973,7 @@ renv_download_headers <- function(url, type, headers) { destfile = file, type = type, request = "HEAD", - headers = headers + headers = headers %||% renv_download_custom_headers(url) ) # check for failure @@ -9068,9 +10150,9 @@ renv_download_local_copy <- function(url, destfile, headers) { # remove file prefix (to get path to local / server file) url <- case( - startswith(url, "file:///") ~ substring(url, 8L), - startswith(url, "file://") ~ substring(url, 6L), - startswith(url, "file:") ~ substring(url, 6L), + startsWith(url, "file:///") ~ substring(url, 8L), + startsWith(url, "file://") ~ substring(url, 6L), + startsWith(url, "file:") ~ substring(url, 6L), TRUE ~ url ) @@ -9277,7 +10359,7 @@ renv_download_trace_result <- function(output) { the$dynamic_envir <- NULL the$dynamic_objects <- new.env(parent = emptyenv()) -dynamic <- function(key, value, envir = NULL) { +dynamic <- function(key, value, envir = NULL, force = FALSE) { # allow opt-out just in case enabled <- getOption("renv.dynamic.enabled", default = TRUE) @@ -9286,7 +10368,7 @@ dynamic <- function(key, value, envir = NULL) { # get a unique id for the scope where this function was invoked caller <- sys.call(sys.parent())[[1L]] - if (renv_call_matches(caller, name = ":::")) + if (renv_call_matches(caller, ":::")) caller <- caller[[3L]] # handle cases like FUN @@ -9307,16 +10389,15 @@ dynamic <- function(key, value, envir = NULL) { the$dynamic_envir <- the$dynamic_envir %||% renv_dynamic_envir(envir) # resolve key from variables in the parent frame - key <- paste( - names(key), - map_chr(key, stringify), - sep = " = ", - collapse = ", " - ) + key <- paste(names(key), map_chr(key, stringify), sep = " = ", collapse = ", ") # put it together id <- sprintf("%s(%s)", as.character(caller), key) + # if we're forcing, clear the memoized value + if (force) + the$dynamic_objects[[id]] <- NULL + # memoize the result of the expression the$dynamic_objects[[id]] <- the$dynamic_objects[[id]] %||% { dlog("dynamic", "memoizing dynamic value for '%s'", id) @@ -9356,7 +10437,8 @@ renv_dynamic_reset <- function() { # embed.R -------------------------------------------------------------------- -#' Capture and re-use dependencies within a `.R` or `.Rmd` + +#' Capture and re-use dependencies within a `.R`, `.Rmd` or `.qmd` #' #' @description #' Together, `embed()` and `use()` provide a lightweight way to specify and @@ -9374,12 +10456,12 @@ renv_dynamic_reset <- function() { #' ) #' ``` #' -#' Then, when you next run your R script or render your `.Rmd`, `use()` will: +#' When you next run your R script or render your `.Rmd` or `.qmd`, `use()` will: #' -#' 1. Create a temporary library path. +#' 1. Create a temporary library path, #' #' 1. Install the requested packages and their recursive dependencies into that -#' library. +#' library, #' #' 1. Activate the library, so it's used for the rest of the script. #' @@ -9411,7 +10493,8 @@ renv_dynamic_reset <- function() { #' @param lockfile #' The path to an renv lockfile. When `NULL` (the default), the project #' lockfile will be read (if any); otherwise, a new lockfile will be generated -#' from the current library paths. +#' from the current library paths. Use `lockfile = FALSE` to force `renv` +#' to ignore the project lockfile, if any. #' #' @export embed <- function(path = NULL, @@ -9424,7 +10507,8 @@ embed <- function(path = NULL, ext <- tolower(fileext(path)) method <- case( ext == ".r" ~ renv_embed_r, - ext == ".rmd" ~ renv_embed_rmd + ext == ".rmd" ~ renv_embed_rmd, + ext == ".qmd" ~ renv_embed_rmd ) if (is.null(method)) { @@ -9455,30 +10539,46 @@ renv_embed_path_impl <- function() { rstudio$.rs.api.documentPath() } -renv_embed_create <- function(path = NULL, - lockfile = NULL, - project = NULL) +renv_embed_create_lockfile <- function(path = NULL, + lockfile = NULL, + project = NULL) { - # generate lockfile - project <- renv_project_resolve(project) - lockfile <- renv_embed_lockfile_resolve(lockfile, project) - - # figure out recursive package dependencies - deps <- renv_dependencies_impl(path) - packages <- sort(unique(deps$Package)) + # figure out the package dependencies for this script + deps <- dependencies(path, quiet = TRUE) + packages <- sort(unique(deps[["Package"]])) all <- renv_package_dependencies(packages) + # notify user if some dependencies appear to be unavailable + ok <- nzchar(all) + missing <- names(all)[!ok] + if (length(missing)) { + missing <- sort(unique(missing)) + stop("required packages are not installed: ", paste(missing, collapse = ", ")) + } + + # create a lockfile + lockfile <- renv_embed_lockfile_resolve(path, names(all), lockfile, project) + # keep only matched records - lockfile$Packages <- keep(lockfile$Packages, c("renv", names(all))) + renv_lockfile_records(lockfile) <- + renv_lockfile_records(lockfile) %>% + keep(c("renv", names(all))) + + invisible(lockfile) +} - # write compact use statement +renv_embed_create <- function(path = NULL, + lockfile = NULL, + project = NULL) +{ + lockfile <- renv_embed_create_lockfile(path, lockfile, project) renv_lockfile_compact(lockfile) } renv_embed_r <- function(path, ..., lockfile = NULL, project = NULL) { # resolve project - project <- renv_project_resolve(project) + project <- renv_project_resolve(project, default = NULL) # read file contents contents <- readLines(path, warn = FALSE, encoding = "UTF-8") @@ -9509,7 +10609,7 @@ renv_embed_r <- function(path, ..., lockfile = NULL, project = NULL) { lines <- grep("^\\s*\\)\\s*$", contents, perl = TRUE) end <- min(lines[lines > start], n + 1L) - # inject new lockfile + # insert new lockfile contents <- c( head(contents, n = start - 1L), embed, @@ -9526,8 +10626,7 @@ renv_embed_create_rmd <- function(path = NULL, project = NULL) { # create lockfile - project <- renv_project_resolve(project) - lockfile <- renv_embed_lockfile_resolve(lockfile, project) + lockfile <- renv_embed_create_lockfile(path, lockfile, project) # create embed embed <- renv_embed_create( @@ -9548,7 +10647,7 @@ renv_embed_rmd <- function(path, project = NULL) { # resolve project - project <- renv_project_resolve(project) + project <- renv_project_resolve(project, default = NULL) # read file contents contents <- readLines(path, warn = FALSE, encoding = "UTF-8") @@ -9592,7 +10691,7 @@ renv_embed_rmd <- function(path, ends <- which(contents == footer) end <- min(ends[ends > start]) - # inject new lockfile + # insert new lockfile contents <- c( head(contents, n = start - 1L), embed, @@ -9604,23 +10703,39 @@ renv_embed_rmd <- function(path, } -renv_embed_lockfile_resolve <- function(lockfile, project) { +renv_embed_lockfile_resolve <- function(path, packages, lockfile, project) { - # if lockfile is character, assume it's the path to a lockfile - if (is.character(lockfile)) - return(renv_lockfile_read(lockfile)) + # handle lockfile argument + if (!identical(lockfile, FALSE)) { - # if lockfile is not NULL, assume lockfile object - if (!is.null(lockfile)) - return(lockfile) + # if lockfile is character, assume it's the path to a lockfile + if (is.character(lockfile)) + return(renv_lockfile_read(lockfile)) - # check for lockfile in project - path <- renv_lockfile_path(project) - if (file.exists(path)) - return(renv_lockfile_read(path)) + # if lockfile is not NULL, assume lockfile object + if (is.list(lockfile)) + return(lockfile) - # no lockfile available; just snapshot - snapshot(project = project, lockfile = NULL) + # check for lockfile in project + if (length(project)) { + path <- renv_lockfile_path(project) + if (file.exists(path)) + return(renv_lockfile_read(path)) + } + + } + + # no lockfile was provided; we need to infer package versions based + # on the packages that are currently installed, or what's available + # in the user's package repositories + project <- renv_project_resolve(project, default = NULL) + + # generate lockfile + snapshot( + lockfile = NULL, + packages = packages, + project = project + ) } @@ -9907,7 +11022,7 @@ renv_equip_macos_toolchain <- function() { return(TRUE) command <- paste("sudo /usr/sbin/installer -pkg", shQuote(destfile), "-target /") - caution_bullets( + bulletin( "The R LLVM toolchain has been successfully downloaded. Please execute:", command, "in a separate terminal to complete installation." @@ -9950,7 +11065,7 @@ renv_equip_macos_rstudio <- function(spec, destfile) { if (!installed) return(FALSE) - caution_bullets( + bulletin( "The R LLVM toolchain has been downloaded and installed to:", spec$dst, "This toolchain will be used by renv when installing packages from source." @@ -10056,7 +11171,7 @@ renv_error_simplify_function <- function(object) { renv_error_simplify_recursive <- function(object) { - longcall <- renv_call_matches(object, name = "{") && length(object) >= 8 + longcall <- renv_call_matches(object, "{") && length(object) >= 8 if (longcall) return(quote(...)) @@ -10165,6 +11280,165 @@ renv_error_handler_call <- function() { } +# expr.R --------------------------------------------------------------------- + + +expr <- function(expr, envir = parent.frame()) { + renv_expr_impl(substitute(expr), envir) +} + +renv_expr_impl <- function(expr, envir) { + + # repair parse trees + expr <- renv_expr_repair(expr) + + # check for inject calls + if (is.call(expr) && identical(expr[[1L]], as.symbol("!"))) { + inner <- expr[[2L]] + if (is.call(inner) && identical(inner[[1L]], as.symbol("!"))) { + value <- eval(inner[[2L]], envir = envir) + return(value) + } + } + + # recurse where possible + if (is.recursive(expr)) { + for (i in seq_along(expr)) { + expr[[i]] <- renv_expr_impl(expr[[i]], envir) + } + } + + expr + +} + +renv_expr_extract <- function(expr) { + + if (is.call(expr) && identical(expr[[1L]], as.symbol("!"))) { + inner <- expr[[2L]] + if (is.call(inner) && identical(inner[[1L]], as.symbol("!"))) { + return(inner[[2L]]) + } + } + +} + +# TODO: Doesn't properly handle precedence for multiple injections, +# e.g. in '!!a + !!b + !!c'. +renv_expr_repair <- function(expr) { + + lhs <- renv_expr_extract(expr) + if (is.null(lhs)) + return(expr) + + check <- is.call(lhs) && length(lhs) == 3L + if (!check) + return(expr) + + rhs <- renv_expr_extract(lhs[[3L]]) + if (is.null(rhs)) + return(expr) + + parts <- list( + lhs[[1L]], + call("!", call("!", lhs[[2L]])), + call("!", call("!", rhs)) + ) + + as.call(parts) + +} + + +# ext.R ---------------------------------------------------------------------- + + +renv_ext_enabled <- function() { + + # disable on Windows; may be able to re-evaluate in future + if (renv_platform_windows()) + return(FALSE) + + # disable if we're embedded + if (!identical(.packageName, "renv")) + return(FALSE) + + # otherwise, check envvar + truthy(Sys.getenv("RENV_EXT_ENABLED", unset = "TRUE")) + +} + +renv_ext_init <- function() { + + if (!renv_ext_enabled() || is.null(the$dll_info)) + return() + + envir <- renv_envir_self() + symbols <- ls(envir = envir, pattern = "^__ffi__") + map(symbols, function(symbol) { + renv_binding_replace( + envir = envir, + symbol = substring(symbol, 8L), + replacement = envir[[symbol]] + ) + }) + +} + +renv_ext_onload <- function(libname, pkgname) { + + if (!renv_ext_enabled()) + return() + + # if we're being invoked via devtools::load_all(), compile extensions + package <- file.path(libname, pkgname) + libsdir <- renv_package_libsdir(package) + + # use alternate library path for load_all + tests + compile <- + renv_envvar_exists("DEVTOOLS_LOAD") && + !renv_envvar_exists("CALLR_IS_RUNNING") + + if (compile) { + renv_ext_compile(package, libsdir) + } + + # now try to load it + soname <- paste0("renv", .Platform$dynlib.ext) + sofile <- file.path(libsdir, soname) + if (file.exists(sofile)) { + info <- library.dynam("renv", pkgname, libname) + the$dll_info <- info + } + +} + +renv_ext_compile <- function(package, libsdir = renv_package_libsdir(package)) { + + if (!renv_ext_enabled()) + return() + + soname <- if (renv_platform_windows()) "renv.dll" else "renv.so" + unlink(file.path(libsdir, soname)) + + extdirs <- file.path(package, c("inst/ext", "ext")) + extdir <- filter(extdirs, file.exists)[[1L]] + + srcfiles <- list.files(extdir, "\\.c$", full.names = TRUE) + ensure_directory(libsdir) + file.copy(srcfiles, libsdir) + + renv_scope_wd(libsdir) + r <- file.path(R.home("bin"), if (.Platform$OS.type == "unix") "R" else "R.exe") + system2(r, c("CMD", "SHLIB", shQuote(basename(srcfiles)))) + + oldfiles <- list.files(pattern = "\\.[co]$", full.names = TRUE) + unlink(oldfiles) + +} + + + # extsoft.R ------------------------------------------------------------------ @@ -10200,7 +11474,7 @@ renv_extsoft_install <- function(quiet = FALSE) { if (interactive()) { - caution_bullets( + bulletin( "The following external software tools will be installed:", files, sprintf("Tools will be installed into %s.", renv_path_pretty(extsoft)) @@ -10288,23 +11562,23 @@ renv_extsoft_use <- function(quiet = FALSE) { contents <- original localsoft <- paste("LOCAL_SOFT", extsoft, sep = " = ") - contents <- inject(contents, "^#?LOCAL_SOFT", localsoft) + contents <- insert(contents, "^#?LOCAL_SOFT", localsoft) localcpp <- "LOCAL_CPPFLAGS = -I\"$(LOCAL_SOFT)/include\"" - contents <- inject(contents, "^#?LOCAL_CPPFLAGS", localcpp) + contents <- insert(contents, "^#?LOCAL_CPPFLAGS", localcpp) locallibs <- "LOCAL_LIBS = -L\"$(LOCAL_SOFT)/lib$(R_ARCH)\" -L\"$(LOCAL_SOFT)/lib\"" - contents <- inject(contents, "^#?LOCAL_LIBS", locallibs) + contents <- insert(contents, "^#?LOCAL_LIBS", locallibs) libxml <- paste("LIB_XML", extsoft, sep = " = ") - contents <- inject(contents, "^#?LIB_XML", libxml) + contents <- insert(contents, "^#?LIB_XML", libxml) if (identical(original, contents)) return(TRUE) if (interactive()) { - caution_bullets( + bulletin( "The following entries will be added to ~/.R/Makevars:", c(localsoft, libxml, localcpp, locallibs), "These tools will be used when compiling R packages from source." @@ -10326,6 +11600,68 @@ renv_extsoft_manifest_path <- function(file) { } +# ffi.R ---------------------------------------------------------------------- + + +`__ffi__enumerate` <- function(x, f, ..., FUN.VALUE = NULL) { + + f <- match.fun(f) + + .Call( + "renv_ffi__enumerate", + x, + FUN.VALUE, + environment(), + PACKAGE = "renv" + ) + +} + +`__ffi__recurse` <- function(object, callback, ...) { + + callback <- match.fun(callback) + + .Call( + "renv_ffi__recurse", + object, + callback, + environment(), + PACKAGE = "renv" + ) + +} + +`__ffi__renv_call_expect` <- function(node, package, methods) { + + .Call( + "renv_ffi__renv_call_expect", + node, + as.character(package), + as.character(methods), + PACKAGE = "renv" + ) + +} + +`__ffi__renv_dependencies_recurse` <- function(object, callback) { + + symbol <- as.symbol(names(formals(args(callback)))[[1L]]) + expr <- body(callback) + envir <- new.env(parent = environment(callback)) + + .Call( + "renv_ffi__renv_dependencies_recurse", + object, + symbol, + expr, + envir, + PACKAGE = "renv" + ) + +} + + + # filebacked.R --------------------------------------------------------------- @@ -10432,7 +11768,8 @@ filebacked <- function(context, path, callback, ...) { renv_filebacked_invalidate <- function(path) { renv_scope_options(warn = -1L) eapply(the$filebacked_cache, function(context) { - rm(list = path, envir = context) + if (exists(path, envir = context)) + rm(list = path, envir = context) }) } @@ -10740,19 +12077,27 @@ renv_file_same <- function(source, target) { if (identical(source, target)) return(TRUE) - # if either file is missing, return false - if (!renv_file_exists(source) || !renv_file_exists(target)) - return(FALSE) # for hard links + junction points, it's difficult to detect # whether the two files point to the same object; use some # heuristics to guess (note that these aren't perfect) sinfo <- renv_file_info(source) + if (is.na(sinfo$isdir)) + return(FALSE) + tinfo <- renv_file_info(target) - if (!identical(c(sinfo), c(tinfo))) + if (is.na(tinfo$isdir)) return(FALSE) - TRUE + # NOTE: we intentionally exclude 'size' for directories, as + # on Windows the 'size' field might be reported as 0 for + # junction points? + if (renv_platform_windows()) { + if (sinfo$isdir || tinfo$isdir) + sinfo$size <- tinfo$size <- 0L + } + + identical(c(sinfo), c(tinfo)) } @@ -10775,7 +12120,7 @@ renv_file_backup <- function(path) { pattern <- sprintf(".renv-backup-%i-%s", Sys.getpid(), basename(path)) tempfile <- tempfile(pattern, tmpdir = dirname(path)) if (!renv_file_move(path, tempfile)) - return(function() {}) + stopf("couldn't rename '%s' prior to transaction", renv_path_pretty(path)) # return callback that will restore if needed function() { @@ -11009,16 +12354,13 @@ renv_file_broken_unix <- function(paths) { !is.na(Sys.readlink(paths)) & !file.exists(paths) } +# unfortunately, as far as I know, there isn't a more reliable +# way of detecting broken junction points on Windows using vanilla R renv_file_broken_win32 <- function(paths) { - # TODO: the behavior of file.exists() for a broken junction point - # appears to have changed in the development version of R; - # we have to be extra careful here... - if (getRversion() < "4.2.0") { - info <- renv_file_info(paths) - (info$isdir %in% TRUE) & is.na(info$mtime) - } else { - file.access(paths, mode = 0L) == 0L & !file.exists(paths) - } + time <- Sys.time() + map_lgl(paths, function(path) { + file.access(path) == 0L && !Sys.setFileTime(path, time) + }) } renv_file_size <- function(path) { @@ -11101,6 +12443,11 @@ renv_git_root <- function(project) { } +# github.R ------------------------------------------------------------------- + + + + # graph.R -------------------------------------------------------------------- @@ -11558,6 +12905,44 @@ renv_hash_text <- function(text) { renv_bootstrap_hash_text(text) } +renv_hash_fields <- function(dcf) { + c( + renv_hash_fields_default(), + renv_hash_fields_remotes(dcf) + ) +} + +renv_hash_fields_default <- function() { + c( + "Package", "Version", "Title", + "Author", "Maintainer", "Description", + "Depends", "Imports", "Suggests", "LinkingTo" + ) +} + +renv_hash_fields_remotes <- function(dcf) { + + # if this seems to be a cran-like record, only keep remotes + # when RemoteSha appears to be a hash (e.g. for r-universe) + # note that RemoteSha may be a package version when installed + # by e.g. pak + if (renv_record_cranlike(dcf)) { + sha <- dcf[["RemoteSha"]] + if (is.null(sha) || nchar(sha) < 40L) + return(character()) + } + + # grab the relevant remotes + remotes <- grep("^Remote", names(dcf), perl = TRUE, value = TRUE) + + # don't include 'RemoteRef' if it's a non-informative remote + if (identical(dcf[["RemoteRef"]], "HEAD")) + remotes <- setdiff(remotes, "RemoteRef") + + remotes + +} + renv_hash_description <- function(path) { filebacked( context = "renv_hash_description", @@ -11567,31 +12952,31 @@ renv_hash_description <- function(path) { } renv_hash_description_impl <- function(path) { + record <- renv_description_read(path) + renv_hash_record(record) +} - dcf <- case( - is.character(path) ~ renv_description_read(path), - is.list(path) ~ path, - ~ stop("unexpected path '%s'", path) - ) +renv_hash_record <- function(record) { - # include default fields - fields <- c( - "Package", "Version", "Title", "Author", "Maintainer", "Description", - "Depends", "Imports", "Suggests", "LinkingTo" - ) + # find relevant fields for hashing + fields <- renv_hash_fields(record) - # add remotes fields - remotes <- renv_hash_description_remotes(dcf) + # collapse vector / list dependency fields + depfields <- c("Depends", "Imports", "Suggests", "LinkingTo", "Enhances") + for (depfield in depfields) { + if (!is.null(record[[depfield]])) { + value <- unlist(record[[depfield]]) + record[[depfield]] <- paste(value, collapse = ", ") + } + } # retrieve these fields - subsetted <- dcf[renv_vector_intersect(c(fields, remotes), names(dcf))] + subsetted <- record[renv_vector_intersect(fields, names(record))] # sort names (use C locale to ensure consistent ordering) ordered <- subsetted[csort(names(subsetted))] - # write to tempfile (use binary connection to ensure unix-style - # newlines for cross-platform hash stability) - tempfile <- tempfile("renv-description-hash-") + # paste together into single string contents <- paste(names(ordered), ordered, sep = ": ", collapse = "\n") # remove whitespace -- it's possible that tools (e.g. Packrat) that @@ -11603,40 +12988,8 @@ renv_hash_description_impl <- function(path) { # configured based on the 'width' option) contents <- gsub("[[:space:]]", "", contents) - # create the file connection (use binary so that unix newlines are used - # across platforms, for more stable hashing) - con <- file(tempfile, open = "wb") - - # write to the file - writeLines(enc2utf8(contents), con = con, useBytes = TRUE) - - # flush to ensure we've written to file - flush(con) - - # close the connection and remove the file - close(con) - - # ready for hasing - hash <- unname(tools::md5sum(tempfile)) - - # remove the old file - unlink(tempfile) - - # return hash - invisible(hash) - -} - -renv_hash_description_remotes <- function(dcf) { - - type <- dcf[["RemoteType"]] - if (is.null(type)) - return(character()) - - if (type == "standard") - return(character()) - - grep("^Remote", names(dcf), value = TRUE) + # compute the hash + invisible(md5(contents)) } @@ -11751,8 +13104,14 @@ renv_homebrew_root <- function() { renv_http_useragent <- function() { + + # https://github.com/rstudio/renv/issues/1787 agent <- getOption("renv.http.useragent", default = getOption("HTTPUserAgent")) - agent %||% renv_http_useragent_default() + if (is.character(agent) && length(agent) == 1L) + return(agent) + + renv_http_useragent_default() + } renv_http_useragent_default <- function() { @@ -11773,7 +13132,7 @@ renv_http_useragent_default <- function() { #' that you should need it otherwise, as it can easily get your project into #' an inconsistent state. #' -#' It may very occasionally be useful to call `hydate(update = "all")` if you +#' It may very occasionally be useful to call `hydrate(update = "all")` if you #' want to update project packages to match those installed in your global #' library (as opposed to using [update()] which will get the latest versions #' from CRAN). In this case, you should verify that your code continues to work, @@ -11853,9 +13212,34 @@ hydrate <- function(packages = NULL, # remove 'renv' since it's managed separately deps$renv <- NULL + # figure out required packages which aren't installed + missing <- deps[!nzchar(deps)] + + # also consider remotes; if a package is listed within Remotes, + # then choose to install that package instead of linking it + filter <- function(specs, remotes) { + + packages <- enum_chr(remotes, function(package, remote) { + + # if we have a package name, use it + if (is.character(package) && nzchar(package)) + return(package) + + # otherwise, resolve the remote and use the package field + remote <- resolve(remote) + remote[["Package"]] + + }) + + keep(specs, packages) + + } + + remotes <- renv_project_remotes(project, filter = filter, resolve = TRUE) + missing[map_chr(remotes, `[[`, "Package")] <- "" + # remove base + missing packages base <- renv_packages_base() - missing <- deps[!nzchar(deps)] packages <- deps[renv_vector_diff(names(deps), c(names(missing), base))] # figure out if we will copy or link @@ -11899,7 +13283,7 @@ hydrate <- function(packages = NULL, } # attempt to install missing packages (if any) - missing <- renv_hydrate_resolve_missing(project, library, missing) + missing <- renv_hydrate_resolve_missing(project, library, remotes, missing) # we're done! result <- list(packages = packages, missing = missing) @@ -11909,16 +13293,12 @@ hydrate <- function(packages = NULL, renv_hydrate_filter <- function(packages, library, update) { # run filter - keep <- enumerate( - packages, - renv_hydrate_filter_impl, - library = library, - update = update, - FUN.VALUE = logical(1) - ) + keep <- enumerate(packages, function(package, path) { + renv_hydrate_filter_impl(package, path, library, update) + }) # filter based on kept packages - packages[keep] + packages[as.logical(keep)] } @@ -12003,11 +13383,15 @@ renv_hydrate_libpaths <- function() { # to the (private) library 'library' renv_hydrate_link_package <- function(package, location, library) { - # construct path to cache + # compute package record record <- catch(renv_snapshot_description(location)) if (inherits(record, "error")) return(FALSE) + # compute a hash now if we don't have one + record[["Hash"]] <- record[["Hash"]] %||% renv_hash_description(location) + + # construct path to cache cache <- renv_cache_find(record) if (!nzchar(cache)) return(FALSE) @@ -12018,6 +13402,9 @@ renv_hydrate_link_package <- function(package, location, library) { renv_file_copy(location, cache) } + # invoke cache callbacks + renv_cache_callbacks(cache) + # link package back from cache to library target <- file.path(library, package) ensure_parent_directory(target) @@ -12059,22 +13446,20 @@ renv_hydrate_copy_packages <- function(packages, library, project) { copied } -renv_hydrate_resolve_missing <- function(project, library, na) { +renv_hydrate_resolve_missing <- function(project, library, remotes, missing) { # make sure requested library is made active # # note that we only want to place the requested library on the library path; # we want to ensure that all required packages are hydrated into the - # reqeusted library + # requested library # # https://github.com/rstudio/renv/issues/1177 ensure_directory(library) renv_scope_libpaths(library) - # figure out which packages are missing (if any) - packages <- names(na) - installed <- installed_packages(lib.loc = library) - if (all(packages %in% installed$Package)) + packages <- names(missing) + if (empty(packages)) return() writef("- Resolving missing dependencies ... ") @@ -12092,10 +13477,11 @@ renv_hydrate_resolve_missing <- function(project, library, na) { project = project, library = library, packages = packages, + records = remotes, handler = handler ) - records <- retrieve(packages) + records <- renv_retrieve_impl(packages) renv_install_impl(records) # if we failed to restore anything, warn the user @@ -12112,7 +13498,7 @@ renv_hydrate_resolve_missing <- function(project, library, na) { sprintf("[%s]: %s", package, short) }) - caution_bullets( + bulletin( "The following package(s) were not installed successfully:", text, "You may need to manually download and install these packages." @@ -12162,7 +13548,7 @@ renv_hydrate_report <- function(packages, na, linkable) { } if (length(na)) { - caution_bullets( + bulletin( "The following packages are used in this project, but not available locally:", csort(names(na)), "renv will attempt to download and install these packages." @@ -12414,7 +13800,7 @@ renv_imbue_impl <- function(project, recursive = FALSE ) - records <- retrieve("renv") + records <- renv_retrieve_impl("renv") renv_install_impl(records) record <- records[["renv"]] @@ -12474,7 +13860,7 @@ renv_imbue_self_binary <- function(source, target) { #' @importFrom tools -#' file_ext pskill psnice write_PACKAGES +#' file_ext md5sum package_dependencies pskill psnice write_PACKAGES #' #' @importFrom utils #' adist available.packages browseURL citation contrib.url download.file @@ -12804,6 +14190,7 @@ renv_infrastructure_write_activate <- function(project = NULL, { project <- renv_project_resolve(project) version <- version %||% renv_activate_version(project) + md5 <- attr(version, "md5", exact = TRUE) sha <- attr(version, "sha", exact = TRUE) source <- system.file("resources/activate.R", package = "renv") @@ -12817,6 +14204,7 @@ renv_infrastructure_write_activate <- function(project = NULL, text = template, replacements = list( version = stringify(as.character(version)), + md5 = stringify(md5), sha = stringify(sha) ), format = "..%s.." @@ -12965,19 +14353,20 @@ the$init_running <- FALSE #' #' 1. Set up project infrastructure (as described in [scaffold()]) including #' the project library and the `.Rprofile` that ensures renv will be -#' used in all future sessions. +#' used in all future sessions, #' -#' 1. Discover the packages that are currently being used in your project and -#' install them into the project library (as described in [hydrate()]). +#' 1. Discover the packages that are currently being used in your project +#' (via [dependencies()]), and install them into the project library +#' (as described in [hydrate()]), #' #' 1. Create a lockfile that records the state of the project library so it -#' can be restored by others (as described in [snapshot()]). +#' can be restored by others (as described in [snapshot()]), #' -#' 1. Restarts R (if running inside RStudio). +#' 1. Restart R (if running inside RStudio). #' -#' If you call `init()` on a project that already uses renv, it will attempt -#' to do the right thing: it will restore the project library if it's missing, -#' or otherwise ask you what to do. +#' If you call `renv::init()` with a project that is already using renv, it will +#' attempt to do the right thing: it will restore the project library if it's +#' missing, or otherwise ask you what to do. #' #' # Repositories #' @@ -12997,12 +14386,12 @@ the$init_running <- FALSE #' @param settings A list of [settings] to be used with the newly-initialized #' project. #' -#' @param bare Boolean; initialize the project without attempting to discover -#' and install R package dependencies? +#' @param bare Boolean; initialize the project with an empty project library, +#' without attempting to discover and install \R package dependencies? #' #' @param force Boolean; force initialization? By default, renv will refuse #' to initialize the home directory as a project, to defend against accidental -#' mis-usages of `init()`. +#' misusages of `init()`. #' #' @param repos The \R repositories to be used in this project. #' See **Repositories** for more details. @@ -13011,13 +14400,15 @@ the$init_running <- FALSE #' Setting this may be appropriate if renv is unable to determine that your #' project depends on a package normally available from Bioconductor. Set this #' to `TRUE` to use the default version of Bioconductor recommended by the -#' BiocManager package. +#' `BiocManager` package. When `NULL` (the default), the value is inferred +#' from the `bioconductor.init` configuration option -- see [config] for more +#' details. #' #' @param load Boolean; should the project be loaded after it is initialized? #' #' @param restart Boolean; attempt to restart the \R session after initializing #' the project? A session restart will be attempted if the `"restart"` \R -#' option is set by the frontend embedding \R. +#' option is set by the frontend hosting \R. #' #' @export #' @@ -13048,6 +14439,7 @@ init <- function(project = NULL, # normalize repos repos <- renv_repos_normalize(repos %||% renv_init_repos()) + renv_scope_options(repos = repos) # form path to lockfile, library library <- renv_paths_library(project = project) @@ -13061,12 +14453,16 @@ init <- function(project = NULL, biocver <- renv_init_bioconductor(bioconductor, project) if (!is.null(biocver)) { + # validate that this version of bioconductor is appropriate + renv_bioconductor_validate(version = biocver) + # make sure a Bioconductor package manager is installed renv_bioconductor_init(library = library) # retrieve bioconductor repositories appropriate for this project repos <- renv_bioconductor_repos(project = project, version = biocver) - + renv_scope_options(repos = repos) + # notify user writef("- Using Bioconductor version '%s'.", biocver) settings[["bioconductor.version"]] <- biocver @@ -13084,7 +14480,7 @@ init <- function(project = NULL, } # compute and cache dependencies to (a) reveal problems early and (b) compute once - deps <- renv_snapshot_dependencies(project, type = type, dev = TRUE) + renv_snapshot_dependencies(project, type = type, dev = TRUE) # determine appropriate action action <- renv_init_action(project, library, lockfile, bioconductor) @@ -13098,9 +14494,10 @@ init <- function(project = NULL, renv_scope_options(renv.config.dependency.errors = "ignored") renv_imbue_impl(project, library = library) hydrate(library = library, repos = repos, prompt = FALSE, report = FALSE, project = project) - snapshot(library = libpaths, repos = repos, prompt = FALSE, project = project) + snapshot(library = libpaths, repos = repos, prompt = FALSE, project = project, force = TRUE) } else if (action == "restore") { ensure_directory(library) + renv_sandbox_activate(project = project) restore(project = project, library = libpaths, repos = repos, prompt = FALSE) } @@ -13177,11 +14574,20 @@ renv_init_action_conflict_library <- function(project, library, lockfile) { if (!interactive()) return("nothing") - # if the project library exists, but it's empty, or only renv is installed, + # if the project library exists, but it's empty, # treat this as a request to initialize the project # https://github.com/rstudio/renv/issues/1668 db <- installed_packages(lib.loc = library, priority = NA_character_) - if (nrow(db) == 0L || identical(db$Package, "renv")) + if (nrow(db) == 0L) + return("init") + + # if only renv is installed, but it matches the version of renv being used + renvonly <- + NROW(db) == 1L && + db[["Package"]] == "renv" && + db[["Version"]] == renv_package_version("renv") + + if (renvonly) return("init") title <- "This project already has a private library. What would you like to do?" @@ -13240,10 +14646,13 @@ renv_init_bioconductor <- function(bioconductor, project) { lockpath <- renv_paths_lockfile(project = project) if (file.exists(lockpath)) { lockfile <- renv_lockfile_read(lockpath) - bioconductor <- !is.null(lockfile$Bioconductor) + bioconductor <- !is.null(lockfile[["Bioconductor"]]) } } + # allow override via option when null + bioconductor <- bioconductor %||% config$bioconductor.init() + # resolve bioconductor argument case( is.character(bioconductor) ~ bioconductor, @@ -13253,25 +14662,37 @@ renv_init_bioconductor <- function(bioconductor, project) { } -renv_init_repos <- function() { +renv_init_repos <- function(repos = getOption("repos")) { # if PPM is disabled, just use default repositories - repos <- convert(getOption("repos"), "list") + repos <- convert(repos, "list") if (!renv_ppm_enabled()) return(repos) + # check whether the user has opted into using PPM by default enabled <- config$ppm.default() if (!enabled) return(repos) - # check for default repositories set - rstudio <- attr(repos, "RStudio", exact = TRUE) - if (identical(rstudio, TRUE) || identical(repos, list(CRAN = "@CRAN@"))) { + # check for default repositories + # + # note that if the user is using RStudio, we only want to override + # the repositories if they haven't explicitly set their own repo URL + # + # https://github.com/rstudio/renv/issues/1782 + rstudio <- structure( + list(CRAN = "https://cran.rstudio.com/"), + RStudio = TRUE + ) + + isdefault <- + identical(repos, list(CRAN = "@CRAN@")) || + identical(repos, rstudio) + + if (isdefault) { repos[["CRAN"]] <- config$ppm.url() - return(repos) } - # repos appears to have been configured separately; just use it repos } @@ -13359,28 +14780,28 @@ the$install_step_width <- 48L #' #' @inherit renv-params #' -#' @param packages Either `NULL` (the default) to install all packages required -#' by the project, or a character vector of packages to install. renv -#' supports a subset of the remotes syntax used for package installation, -#' e.g: -#' -#' * `pkg`: install latest version of `pkg` from CRAN. -#' * `pkg@version`: install specified version of `pkg` from CRAN. -#' * `username/repo`: install package from GitHub -#' * `bioc::pkg`: install `pkg` from Bioconductor. -#' -#' See and the examples -#' below for more details. -#' -#' renv deviates from the remotes spec in one important way: subdirectories -#' are separated from the main repository specification with a `:`, not `/`. -#' So to install from the `subdir` subdirectory of GitHub package -#' `username/repo` you'd use `"username/repo:subdir`. +#' @param include Packages which should be installed. `include` can +#' occasionally be useful when you'd like to call `renv::install()` with +#' no arguments, but restrict package installation to only some subset +#' of dependencies in the project. #' #' @param exclude Packages which should not be installed. `exclude` is useful #' when using `renv::install()` to install all dependencies in a project, #' except for a specific set of packages. #' +#' @param verbose Boolean; report output from `R CMD build` and `R CMD INSTALL` +#' during installation? When `NULL` (the default), the value of `config$install.verbose()` +#' will be used. When `FALSE`, installation output will be emitted only if +#' a package fails to install. +#' +#' @param transactional Whether or not to use a 'transactional' package +#' installation. See **Transactional Restore** in [renv::restore()] for +#' more details. When `NULL` (the default), the value of the +#' `install.transactional` [`config`] option will be used. +#' +#' @param lock Boolean; update the `renv.lock` lockfile after the successful +#' installation of the requested packages? +#' #' @return A named list of package records which were installed by renv. #' #' @export @@ -13413,14 +14834,18 @@ the$install_step_width <- 48L #' } install <- function(packages = NULL, ..., - exclude = NULL, - library = NULL, - type = NULL, - rebuild = FALSE, - repos = NULL, - prompt = interactive(), - dependencies = NULL, - project = NULL) + include = NULL, + exclude = NULL, + library = NULL, + type = NULL, + rebuild = FALSE, + repos = NULL, + prompt = interactive(), + dependencies = NULL, + verbose = NULL, + transactional = NULL, + lock = FALSE, + project = NULL) { renv_consent_check() renv_scope_error_handler() @@ -13442,6 +14867,14 @@ install <- function(packages = NULL, renv_scope_binding(the, "install_dependency_fields", fields) } + # handle 'verbose' + verbose <- verbose %||% config$install.verbose() + renv_scope_options(renv.config.install.verbose = verbose) + + # handle 'transactional' + transactional <- transactional %||% config$install.transactional() + renv_scope_options(renv.config.install.transactional = transactional) + # set up library paths libpaths <- renv_libpaths_resolve(library) renv_scope_libpaths(libpaths) @@ -13460,7 +14893,16 @@ install <- function(packages = NULL, # if users have requested the use of pak, delegate there if (config$pak.enabled() && !recursing()) { renv_pak_init() - return(renv_pak_install(packages, libpaths, project)) + return( + renv_pak_install( + packages = packages, + library = libpaths, + type = type, + rebuild = rebuild, + prompt = prompt, + project = project + ) + ) } # resolve remotes from explicitly-requested packages @@ -13477,6 +14919,10 @@ install <- function(packages = NULL, if (length(exclude)) packages <- setdiff(packages, exclude) + # apply include parameter + if (length(include)) + packages <- intersect(packages, include) + if (empty(packages)) { writef("- There are no packages to install.") return(invisible(list())) @@ -13517,7 +14963,7 @@ install <- function(packages = NULL, ) # retrieve packages - records <- retrieve(packages) + records <- renv_retrieve_impl(packages) if (empty(records)) { writef("- There are no packages to install.") return(invisible(list())) @@ -13528,6 +14974,14 @@ install <- function(packages = NULL, cancel_if(prompt && !proceed()) } + # check for installed dependencies + if (config$sysreqs.check(default = renv_platform_linux())) { + paths <- map(records, `[[`, "Path") + sysreqs <- map(paths, renv_sysreqs_read) + renv_sysreqs_check(sysreqs, prompt = prompt) + } + + # install retrieved records before <- Sys.time() renv_install_impl(records) @@ -13540,6 +14994,31 @@ install <- function(packages = NULL, # check loaded packages and inform user if out-of-sync renv_install_postamble(names(records)) + # update lockfile if requested + if (lock && length(records)) { + + # avoid next automatic snapshot + renv_snapshot_auto_suppress_next() + + # re-compute the records, to ensure they're normalized in the same + # way as they might be in snapshot() + # https://github.com/rstudio/renv/issues/1828 + updates <- renv_lockfile_create( + project = project, + libpaths = libpaths, + packages = names(records), + exclude = exclude, + prompt = FALSE, + force = TRUE + ) + + # overlay these records onto the existing lockfile + lockfile <- renv_lockfile_load(project = project) + lockfile <- renv_lockfile_modify(lockfile, renv_lockfile_records(updates)) + renv_lockfile_save(lockfile, project = project) + + } + invisible(records) } @@ -13718,12 +15197,14 @@ renv_install_package <- function(record) { # link into cache if (renv_cache_config_enabled(project = project)) { - renv_cache_synchronize(record, linkable = linkable) - feedback <- paste0(feedback, " and cached") + cached <- renv_cache_synchronize(record, linkable = linkable) + if (cached) + feedback <- paste(feedback, "and cached") } + verbose <- config$install.verbose() elapsed <- difftime(after, before, units = "auto") - renv_install_step_ok(feedback, elapsed = elapsed) + renv_install_step_ok(feedback, elapsed = elapsed, verbose = verbose) invisible() @@ -13747,14 +15228,14 @@ renv_install_package_cache <- function(record, cache, linker) { return(TRUE) library <- renv_libpaths_active() - target <- file.path(library, record$Package) + target <- file.path(library, record[["Package"]]) # back up the previous installation if needed callback <- renv_file_backup(target) defer(callback()) # report successful link to user - renv_install_step_start("Installing", record$Package) + renv_install_step_start("Installing", record, verbose = FALSE) before <- Sys.time() linker(cache, target) @@ -13829,7 +15310,8 @@ renv_install_package_impl_prebuild <- function(record, path, quiet) { return(path) } - renv_install_step_start("Building", record$Package) + verbose <- config$install.verbose() + renv_install_step_start("Building", record, verbose = verbose) before <- Sys.time() package <- record$Package @@ -13867,7 +15349,10 @@ renv_install_package_impl <- function(record, quiet = TRUE) { # check whether we should build before install path <- renv_install_package_impl_prebuild(record, path, quiet) - renv_install_step_start("Installing", record$Package) + + # report start of installation to user + verbose <- config$install.verbose() + renv_install_step_start("Installing", record, verbose = verbose) # run user-defined hooks before, after install options <- renv_install_package_options(package) @@ -13962,10 +15447,11 @@ renv_install_test <- function(package) { # we use 'loadNamespace()' rather than 'library()' because some packages might # intentionally throw an error in their .onAttach() hooks # https://github.com/rstudio/renv/issues/1611 - code <- substitute({ + code <- expr({ + .libPaths(!!.libPaths()) options(warn = 1L) - loadNamespace(package) - }, list(package = package)) + loadNamespace(!!package) + }) # write it to a tempfile script <- renv_scope_tempfile("renv-install-", fileext = ".R") @@ -14035,7 +15521,7 @@ renv_install_preflight_requirements <- function(records) { fmt <- "Package '%s' requires '%s', but '%s' will be installed" text <- sprintf(fmt, format(package), format(requires), format(actual)) if (renv_verbose()) { - caution_bullets( + bulletin( "The following issues were discovered while preparing for installation:", text, "Installation of these packages may not succeed." @@ -14058,7 +15544,7 @@ renv_install_postamble <- function(packages) { installed <- map_chr(packages, renv_package_version) loaded <- map_chr(packages, renv_namespace_version) - caution_bullets( + bulletin( c("", "The following loaded package(s) have been updated:"), packages[installed != loaded], "Restart your R session to use the new versions." @@ -14095,7 +15581,7 @@ renv_install_preflight_permissions <- function(library) { postamble <- sprintf(fmt, info$effective_user %||% info$user) # print it - caution_bullets( + bulletin( preamble = preamble, values = library, postamble = postamble @@ -14111,6 +15597,7 @@ renv_install_preflight_permissions <- function(library) { renv_install_preflight <- function(project, libpaths, records) { library <- nth(libpaths, 1L) + records <- filter(records, Negate(is.function)) all( renv_install_preflight_unknown_source(records), @@ -14127,15 +15614,22 @@ renv_install_report <- function(records, library) { ) } -renv_install_step_start <- function(action, package) { - message <- sprintf("- %s %s ... ", action, package) +renv_install_step_start <- function(action, record, verbose = FALSE) { + + pkgver <- paste(record[["Package"]], record[["Version"]]) + if (verbose) + return(writef("- %s %s ...", action, pkgver)) + + message <- sprintf("- %s %s ... ", action, pkgver) printf(format(message, width = the$install_step_width)) + } -renv_install_step_ok <- function(..., elapsed = NULL) { +renv_install_step_ok <- function(..., elapsed = NULL, verbose = FALSE) { renv_report_ok( message = paste(..., collapse = ""), - elapsed = elapsed + elapsed = elapsed, + verbose = verbose ) } @@ -14262,6 +15756,79 @@ renv_isolate_windows <- function(project) { } +# job.R ---------------------------------------------------------------------- + + +job <- function(callback, data = list()) { + + # unquote things in the callback + body(callback) <- renv_expr_impl(body(callback), envir = parent.frame()) + + # set up job directory + jobdir <- tempfile("renv-job-") + ensure_directory(jobdir) + + # set up paths + paths <- list( + options = file.path(jobdir, "options.rds"), + workspace = file.path(jobdir, "workspace.Rdata"), + script = file.path(jobdir, "script.R"), + result = file.path(jobdir, "result.rds") + ) + + # save options + names <- list("download.file.method", "download.file.extra", "pkgType", "repos") + saveRDS(do.call(options, names), file = paths$options) + + # save callback and data + save(callback, data, file = paths$workspace) + + # find path where renv is installed + library <- if (devmode() || testing()) { + dirname(renv_package_find("renv")) + } else { + dirname(renv_namespace_path("renv")) + } + + # create a script that will load this data and run it + code <- expr({ + + # load renv, and make internal functions visible + renv <- loadNamespace("renv", lib.loc = !!library) + renv$summon() + + # invoke the provided callback + result <- catch({ + options(readRDS(!!paths$options)) + base::load(!!paths$workspace) + do.call(callback, data) + }) + + # write result to file + saveRDS(result, file = !!paths$result) + + }) + + # write code to script + writeLines(deparse(code), con = paths$script) + + # run that code + renv_scope_envvars(RENV_WATCHDOG_ENABLED = FALSE) + args <- c("--vanilla", "-s", "-f", renv_shell_path(paths$script)) + status <- r(args) + if (status != 0L) + stopf("error executing job [error code %i]", status) + + # collect the result + result <- readRDS(paths$result) + if (inherits(result, "error")) + stop(result) + + result + +} + + # json-read.R ---------------------------------------------------------------- @@ -14272,7 +15839,7 @@ renv_json_read <- function(file = NULL, text = NULL) { # if jsonlite is loaded, use that instead if ("jsonlite" %in% loadedNamespaces()) { - json <- catch(renv_json_read_jsonlite(file, text)) + json <- tryCatch(renv_json_read_jsonlite(file, text), error = identity) if (!inherits(json, "error")) return(json) @@ -14281,7 +15848,7 @@ renv_json_read <- function(file = NULL, text = NULL) { } # otherwise, fall back to the default JSON reader - json <- catch(renv_json_read_default(file, text)) + json <- tryCatch(renv_json_read_default(file, text), error = identity) if (!inherits(json, "error")) return(json) @@ -14294,103 +15861,110 @@ renv_json_read <- function(file = NULL, text = NULL) { } renv_json_read_jsonlite <- function(file = NULL, text = NULL) { - text <- paste(text %||% read(file), collapse = "\n") + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") jsonlite::fromJSON(txt = text, simplifyVector = FALSE) } -renv_json_read_default <- function(file = NULL, text = NULL) { +renv_json_read_patterns <- function() { - # find strings in the JSON - text <- paste(text %||% read(file), collapse = "\n") - pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]' - locs <- gregexpr(pattern, text, perl = TRUE)[[1]] + list( - # if any are found, replace them with placeholders - replaced <- text - strings <- character() - replacements <- character() + # objects + list("{", "\t\n\tobject(\t\n\t", TRUE), + list("}", "\t\n\t)\t\n\t", TRUE), - if (!identical(c(locs), -1L)) { + # arrays + list("[", "\t\n\tarray(\t\n\t", TRUE), + list("]", "\n\t\n)\n\t\n", TRUE), - # get the string values - starts <- locs - ends <- locs + attr(locs, "match.length") - 1L - strings <- substring(text, starts, ends) + # maps + list(":", "\t\n\t=\t\n\t", TRUE), - # only keep those requiring escaping - strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE) + # newlines + list("\\u000a", "\n", FALSE) - # compute replacements - replacements <- sprintf('"\032%i\032"', seq_along(strings)) + ) - # replace the strings - mapply(function(string, replacement) { - replaced <<- sub(string, replacement, replaced, fixed = TRUE) - }, strings, replacements) +} - } +renv_json_read_envir <- function() { - # transform the JSON into something the R parser understands - transformed <- replaced - transformed <- gsub("{}", "`names<-`(list(), character())", transformed, fixed = TRUE) - transformed <- gsub("[[{]", "list(", transformed, perl = TRUE) - transformed <- gsub("[]}]", ")", transformed, perl = TRUE) - transformed <- gsub(":", "=", transformed, fixed = TRUE) - text <- paste(transformed, collapse = "\n") + envir <- new.env(parent = emptyenv()) - # parse it - json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]] + envir[["+"]] <- `+` + envir[["-"]] <- `-` - # construct map between source strings, replaced strings - map <- as.character(parse(text = strings)) - names(map) <- as.character(parse(text = replacements)) + envir[["object"]] <- function(...) { + result <- list(...) + names(result) <- as.character(names(result)) + result + } - # convert to list - map <- as.list(map) + envir[["array"]] <- list - # remap strings in object - remapped <- renv_json_remap(json, map) + envir[["true"]] <- TRUE + envir[["false"]] <- FALSE + envir[["null"]] <- NULL - # evaluate - eval(remapped, envir = baseenv()) + envir } -renv_json_remap <- function(json, map) { +renv_json_read_remap <- function(object, patterns) { - # fix names - if (!is.null(names(json))) { - lhs <- match(names(json), names(map), nomatch = 0L) - rhs <- match(names(map), names(json), nomatch = 0L) - names(json)[rhs] <- map[lhs] - } + # repair names if necessary + if (!is.null(names(object))) { - # fix values - if (is.character(json)) - return(map[[json]] %||% json) + nms <- names(object) + for (pattern in patterns) + nms <- gsub(pattern[[2L]], pattern[[1L]], nms, fixed = TRUE) + names(object) <- nms - # handle true, false, null - if (is.name(json)) { - text <- as.character(json) - if (text == "true") - return(TRUE) - else if (text == "false") - return(FALSE) - else if (text == "null") - return(NULL) } - # recurse - if (is.recursive(json)) { - for (i in seq_along(json)) { - json[i] <- list(renv_json_remap(json[[i]], map)) - } + # repair strings if necessary + if (is.character(object)) { + for (pattern in patterns) + object <- gsub(pattern[[2L]], pattern[[1L]], object, fixed = TRUE) } - json + # recurse for other objects + if (is.recursive(object)) + for (i in seq_along(object)) + object[i] <- list(renv_json_read_remap(object[[i]], patterns)) + + # return remapped object + object } +renv_json_read_default <- function(file = NULL, text = NULL) { + + # read json text + text <- paste(text %||% readLines(file, warn = FALSE), collapse = "\n") + + # convert into something the R parser will understand + patterns <- renv_json_read_patterns() + transformed <- text + for (pattern in patterns) + transformed <- gsub(pattern[[1L]], pattern[[2L]], transformed, fixed = TRUE) + + # parse it + rfile <- tempfile("renv-json-", fileext = ".R") + on.exit(unlink(rfile), add = TRUE) + writeLines(transformed, con = rfile) + json <- parse(rfile, keep.source = FALSE, srcfile = NULL)[[1L]] + + # evaluate in safe environment + result <- eval(json, envir = renv_json_read_envir()) + + # fix up strings if necessary -- do so only with reversible patterns + patterns <- Filter(function(pattern) pattern[[3L]], patterns) + renv_json_read_remap(result, patterns) + +} + + # json-write.R --------------------------------------------------------------- @@ -14534,9 +16108,9 @@ renv_knitr_options_header_impl <- function(rest) { if (inherits(params, "error")) return(list()) - # inject the label back in + # insert the label back in names(params) <- names(params) %||% rep.int("", length(params)) - if (length(params) > 1 && names(params)[[2L]] == "") + if (length(params) > 1L && identical(names(params)[[2L]], "")) names(params)[[2L]] <- "label" # fix up 'label' if it's a missing value @@ -14688,14 +16262,14 @@ renv_l10n_latin1 <- function() { # libpaths.R ----------------------------------------------------------------- -the$libpaths <- new.env(parent = emptyenv()) +the$default_libpaths <- new.env(parent = emptyenv()) # NOTE: if sandboxing is used then these symbols will be clobbered; # save them so we can properly restore them later if so required renv_libpaths_init <- function() { - assign(".libPaths()", .libPaths(), envir = the$libpaths) - assign(".Library", .Library, envir = the$libpaths) - assign(".Library.site", .Library.site, envir = the$libpaths) + assign(".libPaths()", .libPaths(), envir = the$default_libpaths) + assign(".Library", .Library, envir = the$default_libpaths) + assign(".Library.site", .Library.site, envir = the$default_libpaths) } renv_libpaths_active <- function() { @@ -14707,11 +16281,11 @@ renv_libpaths_all <- function() { } renv_libpaths_system <- function() { - get(".Library", envir = the$libpaths) + get(".Library", envir = the$default_libpaths) } renv_libpaths_site <- function() { - get(".Library.site", envir = the$libpaths) + get(".Library.site", envir = the$default_libpaths) } renv_libpaths_external <- function(project) { @@ -14829,7 +16403,7 @@ renv_libpaths_set <- function(libpaths) { } renv_libpaths_default <- function() { - the$libpaths$`.libPaths()` + the$default_libpaths$`.libPaths()` } # NOTE: may return more than one library path! @@ -14869,7 +16443,7 @@ renv_init_libpaths <- function(project) { } renv_libpaths_restore <- function() { - libpaths <- get(".libPaths()", envir = the$libpaths) + libpaths <- get(".libPaths()", envir = the$default_libpaths) renv_libpaths_set(libpaths) } @@ -14914,7 +16488,7 @@ renv_library_diagnose <- function(project, libpath) { # if only some symlinks are broken, report to user if (any(missing)) { - caution_bullets( + bulletin( "The following package(s) are missing entries in the cache:", basename(children[missing]), "These packages will need to be reinstalled." @@ -15009,7 +16583,15 @@ the$load_running <- FALSE #' renv::load() #' #' } -load <- function(project = NULL, quiet = FALSE) { +load <- function(project = NULL, quiet = FALSE, profile = NULL, ...) { + + # forward to base::load() if it looks like that was the intention + base <- renv_load_base(sys.call(), envir = parent.frame()) + if (!is.null(base)) + return(invisible(base)) + + # eagerly load package namespaces which we rely on + requireNamespace("compiler", quietly = TRUE) renv_scope_error_handler() @@ -15018,13 +16600,18 @@ load <- function(project = NULL, quiet = FALSE) { mustWork = TRUE ) + if (!is.null(profile)) + renv_profile_set(profile) + action <- renv_load_action(project) if (action[[1L]] == "cancel") { - cancel() + cancel(verbose = !autoloading()) } else if (action[[1L]] == "init") { return(init(project)) } else if (action[[1L]] == "alt") { project <- action[[2L]] + } else if (action[[1L]] == "none") { + return(invisible(project)) } renv_project_lock(project = project) @@ -15035,7 +16622,7 @@ load <- function(project = NULL, quiet = FALSE) { # if load is being called via the autoloader, # then ensure RENV_PROJECT is unset # https://github.com/rstudio/renv/issues/887 - if (identical(getOption("renv.autoloader.running"), TRUE)) + if (autoloading()) renv_project_clear() # if we're loading a project different from the one currently loaded, @@ -15102,27 +16689,29 @@ renv_load_action <- function(project) { if (dir.exists(renv)) return("load") - # if we're running within RStudio at this point, and we're running - # within the auto-loader, we need to defer execution here so that - # the console is able to properly receive user input and update - # https://github.com/rstudio/renv/issues/1650 - autoloading <- getOption("renv.autoloader.running", default = FALSE) - if (autoloading && renv_rstudio_available()) { - setHook("rstudio.sessionInit", function() { - renv::load(project) - }) - } - # check and see if we're being called within a sub-directory path <- renv_file_find(dirname(project), function(parent) { if (file.exists(file.path(parent, "renv"))) return(parent) }) + # the project has not yet been initialized; notify the user and ask + # what they would like to do fmt <- "The project located at %s has not yet been initialized." header <- sprintf(fmt, renv_path_pretty(project)) - title <- paste("", header, "", "What would you like to do?", sep = "\n") + # if we're running the autoloader in RStudio, we cannot ask + # the user for input at this stage -- instead, just notify them + # of the choices available + if (autoloading() && renv_rstudio_available()) { + initmsg <- "- Use `renv::init()` to initialize this project." + loadmsg <- "- Use `renv::load()` to load this project as-is." + caution(c(header, initmsg, loadmsg)) + return("none") + } + + # otherwise, prompt the user and provide them choices to proceed + title <- paste("", header, "", "What would you like to do?", sep = "\n") choices <- c( init = "Initialize this project with `renv::init()`.", load = "Continue loading this project as-is.", @@ -15135,6 +16724,7 @@ renv_load_action <- function(project) { choices <- c(choices, alt = msg) } + selection <- tryCatch( utils::select.list(choices, title = title, graphics = FALSE), interrupt = identity @@ -15438,8 +17028,30 @@ renv_load_python <- function(project, fields) { ) # place python + relevant utilities on the PATH - bindir <- normalizePath(dirname(python), mustWork = FALSE) - renv_envvar_path_add("PATH", bindir) + bindir <- dirname(python) + if (bindir %in% c("/usr/bin", "/usr/local/bin", "/opt/local/bin")) { + + # create a temporary directory to host symlinks + toolspath <- tempfile("python-tools") + ensure_directory(toolspath) + + # symlink common python binaries into that directory + for (binary in c("python", "python3", "pip", "pip3")) { + src <- file.path(bindir, binary) + if (file.exists(src)) { + tgt <- file.path(toolspath, binary) + renv_file_link(src, tgt) + } + } + + # put it on the PATH + renv_envvar_path_add("PATH", normalizePath(toolspath)) + + } else { + bindir <- normalizePath(bindir, mustWork = FALSE) + renv_envvar_path_add("PATH", bindir) + } + # on Windows, for conda environments, we may also have a Scripts directory # which will need to be pre-pended to the PATH @@ -15540,7 +17152,7 @@ renv_load_bioconductor <- function(project, bioconductor) { return() # if we don't have a valid Bioconductor version, bail - version <- bioconductor$Version + version <- bioconductor[["Version"]] if (is.null(version)) return() @@ -15548,8 +17160,10 @@ renv_load_bioconductor <- function(project, bioconductor) { renv_bioconductor_init() # validate version if necessary - validate <- getOption("renv.bioconductor.validate") - if (truthy(validate, default = TRUE)) + # avoid doing this in non-interactive sessions, as it can rely on + # a web request to https://bioconductor.org/config.yaml, which can be slow + validate <- getOption("renv.bioconductor.validate", default = interactive()) + if (truthy(validate, default = FALSE)) renv_load_bioconductor_validate(project, version) # update the R repositories @@ -15562,29 +17176,7 @@ renv_load_bioconductor <- function(project, bioconductor) { } renv_load_bioconductor_validate <- function(project, version) { - - if (!identical(renv_bioconductor_manager(), "BiocManager")) - return() - - BiocManager <- renv_scope_biocmanager() - if (!is.function(BiocManager$.version_validity)) - return() - - # check for valid version of Bioconductor - # https://github.com/rstudio/renv/issues/1148 - status <- catch(BiocManager$.version_validity(version)) - if (!is.character(status)) - return() - - fmt <- lines( - "This project is configured to use Bioconductor %1$s, which is not compatible with R %2$s.", - "Use 'renv::init(bioconductor = \"%1$s\")' to re-initialize this project with the appropriate Bioconductor release.", - if (renv_package_installed("BiocVersion")) - "Please uninstall the 'BiocVersion' package first, with `remove.packages(\"BiocVersion\")`." - ) - - warningf(fmt, version, getRversion()) - + renv_bioconductor_validate(version, prompt = FALSE) } renv_load_switch <- function(project) { @@ -15615,7 +17207,12 @@ renv_load_switch <- function(project) { } # signal that we're unloading now - renv_scope_options(renv.unload.project = project) + # also ensure that the autoloader will be run when we source the active script + # https://github.com/rstudio/renv/issues/1959 + renv_scope_options( + renv.unload.project = project, + renv.config.autoloader.enabled = TRUE + ) # perform the unload unload() @@ -15627,7 +17224,8 @@ renv_load_switch <- function(project) { unloadNamespace("renv") # move to new project directory - renv_scope_wd(project) + owd <- setwd(project) + on.exit(setwd(owd), add = TRUE) # source the activate script source(script) @@ -15635,7 +17233,7 @@ renv_load_switch <- function(project) { # check and see if renv was successfully loaded if (!"renv" %in% loadedNamespaces()) { fmt <- "could not load renv from project %s; reloading previously-loaded renv" - warningf(fmt, renv_path_pretty(project)) + warning(sprintf(fmt, project)) loadNamespace("renv", lib.loc = dirname(path)) Sys.setenv(RENV_PATHS_RENV = renvpath) if (!is.na(pos)) { @@ -15646,8 +17244,26 @@ renv_load_switch <- function(project) { } +renv_load_cache_renvignore <- function(project) { + + if (testing() || checking()) + return() + + if (!renv_cache_config_enabled(project)) + return() + + caches <- renv_paths_cache() + ensure_directory(caches) + renv_renvignore_create( + paths = caches, + create = TRUE + ) + +} + renv_load_cache <- function(project) { + renv_load_cache_renvignore(project) if (!interactive()) return(FALSE) @@ -15682,7 +17298,7 @@ renv_load_check_description <- function(project) { values <- sprintf("[line %i is blank]", bad) - caution_bullets( + bulletin( sprintf("%s contains blank lines:", renv_path_pretty(descpath)), values, c( @@ -15787,7 +17403,12 @@ renv_load_report_synchronized <- function(project = NULL, lockfile = NULL) { if (length(intersect(lockpkgs, libpkgs)) == 0 && length(lockpkgs) > 0L) { caution("- None of the packages recorded in the lockfile are currently installed.") - response <- ask("- Would you like to restore the project library?") + if (autoloading()) { + caution("- Use `renv::restore()` to restore the project library.") + return(FALSE) + } + + response <- ask("Would you like to run `renv::restore()` to restore the project library?", default = FALSE) if (!response) return(FALSE) @@ -15823,6 +17444,38 @@ renv_load_report_synchronized <- function(project = NULL, lockfile = NULL) { } +renv_load_base <- function(call, envir) { + + # if we were called without arguments, assume we should handle it + if (length(call) == 0L) + return(NULL) + + # if the call was namespace-qualified, assume we should handle it + if (renv_call_matches(call[[1L]], names = c("::", ":::"))) + return(NULL) + + # if any of the formals normally associated with base::load + # were provided, then delegate to base::load() + if (any(c("file", "envir") %in% names(call))) + return(renv_load_base_impl(call, envir)) + + # attempt to match the call + matched <- tryCatch(match.call(base::load, call), error = identity) + if (inherits(matched, "error")) + return(NULL) + + # check for a 'file' argument that looks like a file + file <- eval(matched[["file"]], envir = envir) + if (is.character(file) && endswith(file, ".RData")) + return(renv_load_base_impl(call, envir)) + +} + +renv_load_base_impl <- function(call, envir) { + call[[1L]] <- quote(base::load) + eval(call, envir = envir) +} + # lock.R --------------------------------------------------------------------- @@ -15845,8 +17498,8 @@ renv_lock_acquire <- function(path) { # make sure parent directory exists ensure_parent_directory(path) - # make sure warnings are errors here - renv_scope_options(warn = 2L) + # suppress warnings in this scope + renv_scope_options(warn = -1L) # loop until we acquire the lock repeat tryCatch( @@ -15876,7 +17529,7 @@ renv_lock_acquire_impl <- function(path) { } # attempt to create the lock - dir.create(path, mode = "0755") + dir.create(path, mode = "0755", showWarnings = FALSE) } @@ -15897,9 +17550,9 @@ renv_lock_release <- function(path) { } renv_lock_release_impl <- function(path) { - renv_scope_options(warn = -1L) unlink(path, recursive = TRUE, force = TRUE) - rm(list = path, envir = the$lock_registry) + remaining <- intersect(path, ls(envir = the$lock_registry, all.names = TRUE)) + rm(list = remaining, envir = the$lock_registry) renv_watchdog_notify("LockReleased", list(path = path)) } @@ -15999,7 +17652,7 @@ renv_lockfile_api <- function(lockfile = NULL) { } .self$remove <- function(packages) { - records <- renv_lockfile_records(.lockfile) %>% exclude(packages) + records <- renv_lockfile_records(.lockfile) %>% omit(packages) renv_lockfile_records(.lockfile) <<- records invisible(.self) } @@ -16020,6 +17673,9 @@ renv_lockfile_api <- function(lockfile = NULL) { #' Programmatically Create and Modify a Lockfile #' +#' **NOTE: `lockfile()` is now internal, please use the \link{lockfiles} +#' API.** +#' #' This function provides an API for creating and modifying `renv` lockfiles. #' This can be useful when you'd like to programmatically generate or modify #' a lockfile -- for example, because you want to update or change a package @@ -16258,9 +17914,28 @@ renv_lockfile_read_finish_impl <- function(key, val) { } renv_lockfile_read_finish <- function(data) { - data <- enumerate(data, renv_lockfile_read_finish_impl) - class(data) <- "renv_lockfile" - data + + # create lockfile + lockfile <- enumerate(data, renv_lockfile_read_finish_impl) + class(lockfile) <- "renv_lockfile" + + # compute hashes for records if possible + renv_lockfile_records(lockfile) <- + renv_lockfile_records(lockfile) %>% + map(function(record) { + + record$Hash <- record$Hash %||% { + fields <- renv_hash_fields_remotes(record) + if (all(names(record) %in% fields)) + renv_hash_record(record) + } + + record + + }) + + # return lockfile + lockfile } renv_lockfile_read_preflight <- function(contents) { @@ -16282,7 +17957,7 @@ renv_lockfile_read_preflight <- function(contents) { all <- unlist(parts, recursive = TRUE, use.names = FALSE) - caution_bullets( + bulletin( "The lockfile contains one or more merge conflict markers:", head(all, n = -1L), "You will need to resolve these merge conflicts before the file can be read." @@ -16316,6 +17991,91 @@ renv_lockfile_read <- function(file = NULL, text = NULL) { } +# lockfile-validate.R -------------------------------------------------------- + + +#' Validate an renv lockfile against a schema +#' +#' @description +#' `renv::lockfile_validate()` can be used to validate your `renv.lock` +#' against a default or custom schema. It can be used to automate checks, +#' check for obvious errors, and ensure that any custom fields you add fit +#' your specific needs. +#' +#' @details +#' See the [JSON Schema docs](https://json-schema.org/) for more information +#' on JSON schemas, their use in validation, and how to write your own schema. +#' +#' `renv::lockfile_validate()` wraps ROpenSci's +#' [`jsonvalidate`](https://docs.ropensci.org/jsonvalidate/) package, passing +#' many of its parameters to that package's `json_validate()` function. Use +#' `?jsonvalidate::json_validate` for more information. +#' +#' @inheritParams renv-params +#' +#' @param lockfile Contents of the lockfile, or a filename containing one. +#' If not provided, it defaults to the project's lockfile. +#' +#' @param schema Contents of a renv schema, or a filename containing a schema. +#' If not provided, renv's default schema is used. +#' +#' @param greedy Boolean. Continue after first error? +#' +#' @param error Boolean. Throw an error on parse failure? +#' +#' @param verbose Boolean. If `TRUE`, then an attribute `errors` will list +#' validation failures as a `data.frame`. +#' +#' @param strict Boolean. Set whether the schema should be parsed strictly or +#' not. If in strict mode schemas will error to "prevent any unexpected +#' behaviours or silently ignored mistakes in user schema". For example it +#' will error if encounters unknown formats or unknown keywords. See +#' https://ajv.js.org/strict-mode.html for details. +#' +#' @return Boolean. `TRUE` if validation passes. `FALSE` if validation fails. +#' +#' @examples +#' \dontrun{ +#' +#' # validate the project's lockfile +#' renv::lockfile_validate() +#' +#' # validate the project's lockfile using a non-default schema +#' renv::lockfile_validate(schema = "/path/to/your/custom/schema.json") +#' +#' # validate a lockfile using its path +#' renv::lockfile_validate(lockfile = "/path/to/your/renv.lock") +#' } +#' +#' @keywords internal +#' @export +lockfile_validate <- function(project = NULL, + lockfile = NULL, # Use default project lockfile if not provided + schema = NULL, # Use default schema if not provided + greedy = FALSE, + error = FALSE, + verbose = FALSE, + strict = FALSE) +{ + + project <- renv_project_resolve(project) + lockfile <- lockfile %||% renv_lockfile_path(project = project) + schema <- schema %||% system.file("schema", + "draft-07.renv.lock.schema.json", + package = "renv", + mustWork = TRUE) + + # "ajv" engine required for schema specifications later than draft-04 + jsonvalidate::json_validate(lockfile, + schema, + engine = "ajv", + greedy = greedy, + error = error, + verbose = verbose, + strict = strict) +} + + # lockfile-write.R ----------------------------------------------------------- @@ -16346,21 +18106,18 @@ renv_lockfile_write_preflight <- function(old, new) { enumerate(packages, function(package, changes) { - # avoid spurious changes between CRAN and RSPM - spurious <- - identical(changes, list(Repository = list(before = "CRAN", after = "RSPM"))) || - identical(changes, list(Repository = list(before = "RSPM", after = "CRAN"))) + # avoid spurious changes + lhs <- "CRAN" + for (rhs in c("RSPM", "PPM", "P3M")) { - if (spurious) - new$Packages[[package]]$Repository <<- old$Packages[[package]]$Repository + spurious <- + identical(changes, list(Repository = list(before = lhs, after = rhs))) || + identical(changes, list(Repository = list(before = rhs, after = lhs))) - # avoid spurious changes between CRAN and PPM - spurious <- - identical(changes, list(Repository = list(before = "CRAN", after = "PPM"))) || - identical(changes, list(Repository = list(before = "PPM", after = "CRAN"))) + if (spurious) + new$Packages[[package]]$Repository <<- old$Packages[[package]]$Repository - if (spurious) - new$Packages[[package]]$Repository <<- old$Packages[[package]]$Repository + } }) @@ -16413,8 +18170,9 @@ renv_lockfile_write_json <- function(lockfile, file = stdout()) { prepared <- enumerate(lockfile, renv_lockfile_write_json_prepare) - box <- c("Depends", "Imports", "Suggests", "LinkingTo", "Requirements") + box <- c("Requirements") config <- list(box = box) + json <- renv_json_convert(prepared, config) if (is.null(file)) return(json) @@ -16516,24 +18274,17 @@ renv_lockfile_init_r_version <- function(project) { } -renv_lockfile_init_r_repos <- function(project) { - - repos <- getOption("repos") - - # save names - nms <- names(repos) - - # force as character - repos <- as.character(repos) +renv_lockfile_init_r_repos <- function(project, repos = getOption("repos")) { - # clear RStudio attribute + # unset the RStudio attribute if it was set attr(repos, "RStudio") <- NULL - # set a default URL - repos[repos == "@CRAN@"] <- getOption( - "renv.repos.cran", - "https://cloud.r-project.org" - ) + # make sure it's a character vector in this scope + repos <- convert(repos, "character") + + # make sure a CRAN repository is set + cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") + repos[repos == "@CRAN@"] <- cran # remove PPM bits from URL if (renv_ppm_enabled()) { @@ -16541,13 +18292,8 @@ renv_lockfile_init_r_repos <- function(project) { repos <- sub(pattern, "/", repos) } - # force as list - repos <- as.list(repos) - - # ensure names - names(repos) <- nms - - repos + # all done; return as list + convert(repos, "list") } @@ -16625,7 +18371,7 @@ renv_lockfile_save <- function(lockfile, project) { } renv_lockfile_load <- function(project, strict = FALSE) { - + path <- renv_lockfile_path(project) if (file.exists(path)) return(renv_lockfile_read(path)) @@ -16637,6 +18383,13 @@ renv_lockfile_load <- function(project, strict = FALSE) { )) } + manifest <- file.path(project, "manifest.json") + if (file.exists(manifest)) { + caution("No lockfile found; creating from `manifest.json`.") + renv_lockfile_from_manifest(manifest, path) + return(renv_lockfile_read(path)) + } + renv_lockfile_init(project = project) } @@ -16749,9 +18502,9 @@ renv_lockfile_compact <- function(lockfile) { records <- renv_lockfile_records(lockfile) remotes <- map_chr(records, renv_record_format_remote) - remotes <- csort(remotes) + remotes <- remotes[sort(names(remotes))] - formatted <- sprintf(" \"%s\"", remotes) + formatted <- sprintf(" %s = \"%s\"", format(names(remotes)), remotes) joined <- paste(formatted, collapse = ",\n") all <- c("renv::use(", joined, ")") @@ -17022,15 +18775,15 @@ renv_log_impl <- function(level, scope, fmt, ...) { } -renv_log_init <- function() { - the$log_level <- renv_log_level() - the$log_file <- renv_log_file() - the$log_scopes <- renv_log_scopes() +renv_log_init <- function(level = NULL, file = NULL, scopes = NULL) { + the$log_level <- renv_log_level(level) + the$log_file <- renv_log_file(file) + the$log_scopes <- renv_log_scopes(scopes) } -renv_log_level <- function() { +renv_log_level <- function(level = NULL) { - level <- Sys.getenv("RENV_LOG_LEVEL", unset = NA) + level <- level %||% Sys.getenv("RENV_LOG_LEVEL", unset = NA) if (is.na(level)) return(4L) @@ -17047,10 +18800,10 @@ renv_log_level <- function() { } -renv_log_file <- function() { +renv_log_file <- function(file = NULL) { # check for log file - file <- Sys.getenv("RENV_LOG_FILE", unset = NA) + file <- file %||% Sys.getenv("RENV_LOG_FILE", unset = NA) if (!is.na(file)) return(file) @@ -17059,9 +18812,9 @@ renv_log_file <- function() { } -renv_log_scopes <- function() { +renv_log_scopes <- function(scopes = NULL) { - scopes <- Sys.getenv("RENV_LOG_SCOPES", unset = NA) + scopes <- scopes %||% Sys.getenv("RENV_LOG_SCOPES", unset = NA) if (is.na(scopes)) return(NULL) @@ -17076,6 +18829,7 @@ renv_log_scopes <- function() { #' Generate `renv.lock` from an RStudio Connect `manifest.json` #' +#' @description #' Use `renv_lockfile_from_manifest()` to convert a `manifest.json` file from #' an RStudio Connect content bundle into an `renv.lock` lockfile. #' @@ -17095,18 +18849,11 @@ renv_log_scopes <- function() { #' object; otherwise, the lockfile will be written to the path specified by #' `lockfile`. #' -#' @details -#' By default the `lockfile` argument is set to `NA`. This will not create a new -#' `renv.lock` file. Rather, it will return a lockfile object (see `?lockfile`) -#' that can be used to create a new `renv.lock` file. If `lockfile` is set to a -#' character string, a new file will be created with that path -- e.g. -#' `renv.lock` -- and the lockfile object will be returned. -#' #' @return #' An renv lockfile. #' #' @keywords internal -renv_lockfile_from_manifest <- function(manifest, +renv_lockfile_from_manifest <- function(manifest = "manifest.json", lockfile = NA, project = NULL) { @@ -17154,16 +18901,45 @@ renv_lockfile_from_manifest <- function(manifest, if (is.na(lockfile)) return(lock) - # otherwise, write to file and report for user + # otherwise, write to file renv_lockfile_write(lock, file = lockfile) - fmt <- "- Lockfile written to %s." - writef(fmt, renv_path_pretty(lockfile)) invisible(lock) } +# mapping.R ------------------------------------------------------------------ + + +# basically just a mutable R list +mapping <- function() { + + .data <- vector("list", 0L) + + list( + + get = function(key) { + .data[[key]] + }, + + contains = function(key) { + key %in% names(.data) + }, + + insert = function(key, value) { + .data[[key]] <<- value + }, + + data = function() { + .data + } + + ) + +} + + # mask.R --------------------------------------------------------------------- @@ -17175,10 +18951,20 @@ numeric_version <- function(x, strict = TRUE) { } sprintf <- function(fmt, ...) { - if (nargs() == 1L) - fmt - else - base::sprintf(fmt, ...) + message <- if (nargs() == 1L) fmt else base::sprintf(fmt, ...) + ansify(message) +} + +substring <- function(text, first, last = .Machine$integer.max) { + + n <- length(text) + if (n == 0L) + return(text) + + m <- max(n, length(first), length(last)) + text <- rep_len(as.character(text), length.out = m) + substr(text, first, last) + } unique <- function(x) { @@ -17211,6 +18997,51 @@ untar <- function(tarfile, result } +# prefer writing files as UTF-8 +writeLines <- function(text, con = stdout(), sep = "\n", useBytes = FALSE) { + if (is.character(con) && missing(useBytes)) + base::writeLines(enc2utf8(text), con = con, sep = sep, useBytes = TRUE) + else + base::writeLines(text, con, sep, useBytes) +} + + +# md5sum.R ------------------------------------------------------------------- + + +renv_md5sum_old <- function(text) { + + tempfile <- tempfile("renv-md5sum-") + con <- file(tempfile, open = "wb") + writeLines(enc2utf8(text), con = con, useBytes = TRUE) + flush(con) + close(con) + + hash <- unname(md5sum(tempfile)) + unlink(tempfile) + + hash + +} + +renv_md5sum_new <- function(text) { + + # The old implementation worked by writing a string out to a file using + # writeLines(), which would ensure a trailing newline was included in + # the generated output. We append a newline here to preserve that behavior. + newline <- as.raw(0x0a) + bytes <- c(charToRaw(enc2utf8(text)), newline) + + # silence R CMD check warning -- this only gets invoked for R >= 4.5.0 + (md5sum)(bytes = bytes) + +} + +md5 <- if (getRversion() < "4.5.0") { + renv_md5sum_old +} else { + renv_md5sum_new +} # memoize.R ------------------------------------------------------------------ @@ -17260,9 +19091,20 @@ renv_metadata_version <- function() { } renv_metadata_version_create <- function(record) { + + # get package version version <- record[["Version"]] - attr(version, "sha") <- record[["RemoteSha"]] + + # tag with md5 + attr(version, "md5") <- record[["Hash"]] %||% renv_hash_record(record) + + # tag with RemoteSha if renv was installed from GitHub + if ("github" %in% record[["RemoteType"]]) + attr(version, "sha") <- record[["RemoteSha"]] + + # return version version + } renv_metadata_remote <- function(metadata = the$metadata) { @@ -17344,7 +19186,7 @@ renv_methods_init <- function() { # determine appropriate lookup key for finding alternative key <- if (renv_platform_windows()) "win32" else "unix" alts <- map(methods, `[[`, key) - + # update methods in namespace envir <- renv_envir_self() enumerate(alts, function(name, alt) { @@ -17686,7 +19528,7 @@ renv_migrate_packrat_cache_impl <- function(targets) { if (nrow(bad) == 0) return(TRUE) - caution_bullets( + bulletin( "The following packages could not be copied from the Packrat cache:", with(bad, sprintf("%s [%s]", format(source), reason)), "These packages may need to be reinstalled and re-cached." @@ -17825,24 +19667,164 @@ renv_modify_fini <- function(lockfile) { } -# mran.R --------------------------------------------------------------------- +# namespace.R ---------------------------------------------------------------- + + +renv_namespace_spec <- function(package) { + namespace <- asNamespace(package) + .getNamespaceInfo(namespace, "spec") +} + +renv_namespace_version <- function(package) { + spec <- renv_namespace_spec(package) + spec[["version"]] +} + +renv_namespace_path <- function(package) { + namespace <- asNamespace(package) + .getNamespaceInfo(namespace, "path") +} + +renv_namespace_load <- function(package) { + suppressPackageStartupMessages(getNamespace(package)) +} + +renv_namespace_unload <- function(package) { + unloadNamespace(package) +} + +renv_namespace_parse <- function(package) { + + parseNamespaceFile( + package = package, + package.lib = dirname(renv_package_find(package)), + mustExist = TRUE + ) + +} + + +# new.R ---------------------------------------------------------------------- + + +new <- function(expr) { + + private <- new.env(parent = renv_envir_self()) + public <- new.env(parent = private) + + for (expr in as.list(substitute(expr))[-1L]) { + + assigning <- renv_call_matches(expr, names = c("=", "<-")) + if (!assigning) + return(eval(expr, envir = public)) + + hidden <- + is.symbol(expr[[2L]]) && + substring(as.character(expr[[2L]]), 1L, 1L) == "." + + eval(expr, envir = if (hidden) private else public) + + } + + public + +} + + +# nexus.R -------------------------------------------------------------------- + + +renv_nexus_enabled <- function(repo) { + + # first, check a global option + enabled <- getOption("renv.nexus.enabled", default = FALSE) + if (enabled) + return(TRUE) + + # otherwise, check cached repository information + info <- renv_repos_info(repo) + identical(info$nexus, TRUE) + +} + + +# once.R --------------------------------------------------------------------- + + +# mechanism for running a block of code only once +the$once <- new.env(parent = emptyenv()) + +once <- function() { + + call <- sys.call(sys.parent())[[1L]] + id <- as.character(call) + + once <- the$once[[id]] %||% TRUE + the$once[[id]] <- FALSE + + once + +} + + +# options.R ------------------------------------------------------------------ + + +renv_options_set <- function(key, value) { + data <- list(value) + names(data) <- key + do.call(base::options, data) +} + +renv_options_resolve <- function(value, arguments) { + + if (is.function(value)) + return(do.call(value, arguments)) + + value + +} + +renv_options_override <- function(scope, key, default = NULL, extra = NULL) { + + # first, check for scoped option + value <- getOption(paste(scope, key, sep = ".")) + if (!is.null(value)) + return(renv_options_resolve(value, list(extra))) + + # next, check for unscoped option + value <- getOption(scope) + if (key %in% names(value)) + return(renv_options_resolve(value[[key]], list(extra))) + + # check for functional value + if (is.function(value)) + return(renv_options_resolve(value, list(key, extra))) + + # nothing found; use default + default + +} + + +# p3m.R ---------------------------------------------------------------------- -renv_mran_enabled <- function() { - !identical(getOption("pkgType"), "source") && config$mran.enabled() +renv_p3m_enabled <- function() { + !identical(getOption("pkgType"), "source") && config$ppm.enabled() } -renv_mran_database_path <- function() { - renv_paths_mran("packages.rds") +renv_p3m_database_path <- function() { + renv_paths_p3m("packages.rds") } -renv_mran_database_encode <- function(database) { +renv_p3m_database_encode <- function(database) { database <- as.list(database) - encoded <- lapply(database, renv_mran_database_encode_impl) + encoded <- lapply(database, renv_p3m_database_encode_impl) encoded[order(names(encoded))] } -renv_mran_database_encode_impl <- function(entry) { +renv_p3m_database_encode_impl <- function(entry) { entry <- as.list(entry) keys <- names(entry) @@ -17866,12 +19848,12 @@ renv_mran_database_encode_impl <- function(entry) { } -renv_mran_database_decode <- function(encoded) { - decoded <- lapply(encoded, renv_mran_database_decode_impl) +renv_p3m_database_decode <- function(encoded) { + decoded <- lapply(encoded, renv_p3m_database_decode_impl) list2env(decoded, parent = emptyenv()) } -renv_mran_database_decode_impl <- function(entry) { +renv_p3m_database_decode_impl <- function(entry) { entry$Package <- as.character(entry$Package) entry$Version <- as.character(entry$Version) @@ -17887,12 +19869,12 @@ renv_mran_database_decode_impl <- function(entry) { } -renv_mran_database_save <- function(database, path = NULL) { +renv_p3m_database_save <- function(database, path = NULL) { - path <- path %||% renv_mran_database_path() + path <- path %||% renv_p3m_database_path() ensure_parent_directory(path) - encoded <- renv_mran_database_encode(database) + encoded <- renv_p3m_database_encode(database) conn <- xzfile(path) defer(close(conn)) @@ -17900,22 +19882,22 @@ renv_mran_database_save <- function(database, path = NULL) { } -renv_mran_database_load <- function(path = NULL) { +renv_p3m_database_load <- function(path = NULL) { filebacked( - context = "renv_mran_database_load", - path = path %||% renv_mran_database_path(), - callback = renv_mran_database_load_impl + context = "renv_p3m_database_load", + path = path %||% renv_p3m_database_path(), + callback = renv_p3m_database_load_impl ) } -renv_mran_database_load_impl <- function(path) { +renv_p3m_database_load_impl <- function(path) { # read from database file if it exists if (file.exists(path)) { encoded <- readRDS(path) - return(renv_mran_database_decode(encoded)) + return(renv_p3m_database_decode(encoded)) } # otherwise, initialize a new database @@ -17923,7 +19905,7 @@ renv_mran_database_load_impl <- function(path) { } -renv_mran_database_dates <- function(version, all = TRUE) { +renv_p3m_database_dates <- function(version, all = TRUE) { # release dates for old versions of R releases <- c( @@ -17935,8 +19917,10 @@ renv_mran_database_dates <- function(version, all = TRUE) { "4.0" = "2020-04-24", "4.1" = "2021-05-18", "4.2" = "2022-04-22", - "4.3" = "2023-05-18", # a guess - "4.4" = "2024-05-18", # a guess + "4.3" = "2023-04-21", + "4.4" = "2024-04-24", + "4.5" = "2025-05-18", # a guess + "4.6" = "2026-05-18", # a guess NULL ) @@ -17962,29 +19946,29 @@ renv_mran_database_dates <- function(version, all = TRUE) { } -renv_mran_database_key <- function(platform, version) { +renv_p3m_database_key <- function(platform, version) { sprintf("/bin/%s/contrib/%s", platform, version) } -renv_mran_database_update <- function(platform, version, dates = NULL) { +renv_p3m_database_update <- function(platform, version, dates = NULL) { # load database - database <- renv_mran_database_load() + database <- renv_p3m_database_load() # get reference to entry in database (initialize if not yet created) - suffix <- renv_mran_database_key(platform, version) + suffix <- renv_p3m_database_key(platform, version) database[[suffix]] <- database[[suffix]] %||% new.env(parent = emptyenv()) entry <- database[[suffix]] # rough release dates for R releases - dates <- as.list(dates %||% renv_mran_database_dates(version)) + dates <- as.list(dates %||% renv_p3m_database_dates(version)) for (date in dates) { # attempt to update our database entry for this date - url <- renv_mran_url(date, suffix) + url <- renv_p3m_url(date, suffix) tryCatch( - renv_mran_database_update_impl(date, url, entry), + renv_p3m_database_update_impl(date, url, entry), error = warnify ) @@ -17992,21 +19976,21 @@ renv_mran_database_update <- function(platform, version, dates = NULL) { # save at end printf("[%s]: saving database ... ", date) - renv_mran_database_save(database) + renv_p3m_database_save(database) writef("DONE") } -renv_mran_database_update_impl <- function(date, url, entry) { +renv_p3m_database_update_impl <- function(date, url, entry) { - printf("[%s]: reading package database ... ", date) + printf("[%s]: updating package database ... ", date) # get date as number of days since epoch idate <- as.integer(date) # retrieve available packages errors <- new.env(parent = emptyenv()) - db <- renv_available_packages_query_impl(url, errors) + db <- renv_available_packages_query_impl(url, "binary", errors) if (is.null(db)) { writef("ERROR") return(FALSE) @@ -18030,41 +20014,42 @@ renv_mran_database_update_impl <- function(date, url, entry) { } -renv_mran_url <- function(date, suffix) { - root <- Sys.getenv("RENV_MRAN_URL", unset = "https://mran.microsoft.com/snapshot") +renv_p3m_url <- function(date, suffix) { + default <- "https://packagemanager.posit.co/cran" + root <- Sys.getenv("RENV_MRAN_URL", unset = default) snapshot <- file.path(root, date) paste(snapshot, suffix, sep = "") } -renv_mran_database_url <- function() { - default <- "https://rstudio-buildtools.s3.amazonaws.com/renv/mran/packages.rds" +renv_p3m_database_url <- function() { + default <- "https://rstudio-buildtools.s3.amazonaws.com/renv/package-manager/packages.rds" Sys.getenv("RENV_MRAN_DATABASE_URL", unset = default) } -renv_mran_database_refresh <- function(explicit = TRUE) { +renv_p3m_database_refresh <- function(explicit = TRUE) { - if (explicit || renv_mran_database_refresh_required()) - renv_mran_database_refresh_impl() + if (explicit || renv_p3m_database_refresh_required()) + renv_p3m_database_refresh_impl() } -renv_mran_database_refresh_required <- function() { +renv_p3m_database_refresh_required <- function() { dynamic( key = list(), - value = renv_mran_database_refresh_required_impl() + value = renv_p3m_database_refresh_required_impl() ) } -renv_mran_database_refresh_required_impl <- function() { +renv_p3m_database_refresh_required_impl <- function() { # if the cache doesn't exist, we must refresh - path <- renv_mran_database_path() + path <- renv_p3m_database_path() if (!file.exists(path)) return(TRUE) # if we're using an older version of R, but we have newer package # versions available in the cache, we don't need to refresh - db <- tryCatch(renv_mran_database_load(), error = identity) + db <- tryCatch(renv_p3m_database_load(), error = identity) if (!inherits(db, "error")) { keys <- names(db) versions <- unique(basename(keys)) @@ -18082,10 +20067,10 @@ renv_mran_database_refresh_required_impl <- function() { } -renv_mran_database_refresh_impl <- function() { +renv_p3m_database_refresh_impl <- function() { - url <- renv_mran_database_url() - path <- renv_mran_database_path() + url <- renv_p3m_database_url() + path <- renv_p3m_database_path() if (nzchar(url) && nzchar(path)) { ensure_parent_directory(path) @@ -18094,13 +20079,13 @@ renv_mran_database_refresh_impl <- function() { } -renv_mran_database_sync <- function(platform, version) { +renv_p3m_database_sync <- function(platform, version) { # read database - database <- renv_mran_database_load() + database <- renv_p3m_database_load() # read entry for this platform + version combo - key <- renv_mran_database_key(platform, version) + key <- renv_p3m_database_key(platform, version) entry <- database[[key]] if (is.null(entry)) { database[[key]] <- new.env(parent = emptyenv()) @@ -18110,7 +20095,7 @@ renv_mran_database_sync <- function(platform, version) { # get the last known updated date last <- max(0L, as.integer(as.list(entry))) if (identical(last, 0L)) { - date <- renv_mran_database_dates(version, all = FALSE) + date <- renv_p3m_database_dates(version, all = FALSE) last <- as.integer(date) } @@ -18118,7 +20103,7 @@ renv_mran_database_sync <- function(platform, version) { now <- as.integer(as.Date(Sys.time(), tz = "UTC")) - 1L # sync up to the last version's release date - dates <- as.integer(renv_mran_database_dates(version)) + dates <- as.integer(renv_p3m_database_dates(version)) now <- min(now, max(dates)) # if we've already in sync, nothing to do @@ -18126,192 +20111,73 @@ renv_mran_database_sync <- function(platform, version) { return(FALSE) # invoke update for missing dates - writef("==> Synchronizing MRAN database (%s/%s)", platform, version) + writef("==> Synchronizing database (%s/%s)", platform, version) dates <- as.Date(seq(last + 1L, now, by = 1L), origin = "1970-01-01") - renv_mran_database_update(platform, version, dates) - writef("Finished synchronizing MRAN database (%s/%s)", platform, version) + renv_p3m_database_update(platform, version, dates) + writef("Finished synchronizing database (%s/%s)", platform, version) # return TRUE to indicate update occurred return(TRUE) } -renv_mran_database_sync_all <- function() { +renv_p3m_database_sync_all <- function() { - # NOTE: this needs to be manually updated since the binary URL for - # packages can change from version to version, especially on macOS - - # R 3.2 - renv_mran_database_sync("windows", "3.2") - renv_mran_database_sync("macosx/mavericks", "3.2") - - # R 3.3 - renv_mran_database_sync("windows", "3.3") - renv_mran_database_sync("macosx/mavericks", "3.3") - - # R 3.4 - renv_mran_database_sync("windows", "3.4") - renv_mran_database_sync("macosx/el-capitan", "3.4") - - # R 3.5 - renv_mran_database_sync("windows", "3.5") - renv_mran_database_sync("macosx/el-capitan", "3.5") - - # R 3.6 - renv_mran_database_sync("windows", "3.6") - renv_mran_database_sync("macosx/el-capitan", "3.6") - - # R 4.0 - renv_mran_database_sync("windows", "4.0") - renv_mran_database_sync("macosx", "4.0") - - # R 4.1 - renv_mran_database_sync("windows", "4.1") - renv_mran_database_sync("macosx", "4.1") - renv_mran_database_sync("macosx/big-sur-arm64", "4.1") - - - -} - - -# namespace.R ---------------------------------------------------------------- - - -renv_namespace_spec <- function(package) { - namespace <- asNamespace(package) - .getNamespaceInfo(namespace, "spec") -} - -renv_namespace_version <- function(package) { - spec <- renv_namespace_spec(package) - spec[["version"]] -} - -renv_namespace_path <- function(package) { - namespace <- asNamespace(package) - .getNamespaceInfo(namespace, "path") -} - -renv_namespace_load <- function(package) { - suppressPackageStartupMessages(getNamespace(package)) -} - -renv_namespace_unload <- function(package) { - unloadNamespace(package) -} - -renv_namespace_parse <- function(package) { - - parseNamespaceFile( - package = package, - package.lib = dirname(renv_package_find(package)), - mustExist = TRUE + tryCatch( + renv_p3m_database_sync_all_impl(), + interrupt = identity ) } +renv_p3m_database_sync_all_impl <- function() { -# new.R ---------------------------------------------------------------------- - - -new <- function(expr) { - - private <- new.env(parent = renv_envir_self()) - public <- new.env(parent = private) - - for (expr in as.list(substitute(expr))[-1L]) { - - assigning <- renv_call_matches(expr, name = c("=", "<-")) - - if (!assigning) - return(eval(expr, envir = public)) - - hidden <- - is.symbol(expr[[2L]]) && - substring(as.character(expr[[2L]]), 1L, 1L) == "." - - eval(expr, envir = if (hidden) private else public) - - } - - public - -} - - -# nexus.R -------------------------------------------------------------------- - - -renv_nexus_enabled <- function(repo) { - - # first, check a global option - enabled <- getOption("renv.nexus.enabled", default = FALSE) - if (enabled) - return(TRUE) - - # otherwise, check cached repository information - info <- renv_repos_info(repo) - identical(info$nexus, TRUE) - -} - - -# once.R --------------------------------------------------------------------- - - -# mechanism for running a block of code only once -the$once <- new.env(parent = emptyenv()) - -once <- function() { - - call <- sys.call(sys.parent())[[1L]] - id <- as.character(call) - - once <- the$once[[id]] %||% TRUE - the$once[[id]] <- FALSE - - once - -} - - -# options.R ------------------------------------------------------------------ - + # NOTE: this needs to be manually updated since the binary URL for + # packages can change from version to version, especially on macOS -renv_options_set <- function(key, value) { - data <- list(value) - names(data) <- key - do.call(base::options, data) -} +# # R 3.2 +# renv_p3m_database_sync("windows", "3.2") +# renv_p3m_database_sync("macosx/mavericks", "3.2") +# +# # R 3.3 +# renv_p3m_database_sync("windows", "3.3") +# renv_p3m_database_sync("macosx/mavericks", "3.3") +# +# # R 3.4 +# renv_p3m_database_sync("windows", "3.4") +# renv_p3m_database_sync("macosx/el-capitan", "3.4") +# +# # R 3.5 +# renv_p3m_database_sync("windows", "3.5") +# renv_p3m_database_sync("macosx/el-capitan", "3.5") +# +# # R 3.6 +# renv_p3m_database_sync("windows", "3.6") +# renv_p3m_database_sync("macosx/el-capitan", "3.6") +# +# # R 4.0 +# renv_p3m_database_sync("windows", "4.0") +# renv_p3m_database_sync("macosx", "4.0") -renv_options_resolve <- function(value, arguments) { + # R 4.1 + renv_p3m_database_sync("windows", "4.1") + renv_p3m_database_sync("macosx", "4.1") + renv_p3m_database_sync("macosx/big-sur-arm64", "4.1") - if (is.function(value)) - return(do.call(value, arguments)) + # R 4.2 + renv_p3m_database_sync("windows", "4.2") + renv_p3m_database_sync("macosx", "4.2") + renv_p3m_database_sync("macosx/big-sur-arm64", "4.2") - value - -} - -renv_options_override <- function(scope, key, default = NULL, extra = NULL) { - - # first, check for scoped option - value <- getOption(paste(scope, key, sep = ".")) - if (!is.null(value)) - return(renv_options_resolve(value, list(extra))) - - # next, check for unscoped option - value <- getOption(scope) - if (key %in% names(value)) - return(renv_options_resolve(value[[key]], list(extra))) - - # resolve option value - if (!is.null(value)) - return(renv_options_resolve(value, list(key, extra))) - - # nothing found; use default - default + # R 4.3 + renv_p3m_database_sync("windows", "4.3") + renv_p3m_database_sync("macosx", "4.3") + renv_p3m_database_sync("macosx/big-sur-arm64", "4.3") + + # R 4.4 + renv_p3m_database_sync("windows", "4.4") + renv_p3m_database_sync("macosx", "4.4") + renv_p3m_database_sync("macosx/big-sur-arm64", "4.4") } @@ -18319,29 +20185,22 @@ renv_options_override <- function(scope, key, default = NULL, extra = NULL) { # package.R ------------------------------------------------------------------ -# NOTE: intentionally checks library paths before checking loaded namespaces -renv_package_find <- function(package, - lib.loc = renv_libpaths_all(), - check.loaded = TRUE) -{ - map_chr( - package, - renv_package_find_impl, - lib.loc = lib.loc, - check.loaded = check.loaded - ) +# NOTE: When lib.loc is NULL, renv will also check to see if a package matching +# the provided name is currently loaded. This function will also intentionally +# check the library paths before checking loaded namespaces. +# This differs from the behavior of `find.package()`. +renv_package_find <- function(package, lib.loc = NULL) { + map_chr(package, renv_package_find_impl, lib.loc = lib.loc) } -renv_package_find_impl <- function(package, - lib.loc = renv_libpaths_all(), - check.loaded = TRUE) -{ +renv_package_find_impl <- function(package, lib.loc = NULL) { + # if we've been given the path to an existing package, use it as-is if (grepl("/", package) && file.exists(file.path(package, "DESCRIPTION"))) return(renv_path_normalize(package, mustWork = TRUE)) # first, look in the library paths - for (libpath in lib.loc) { + for (libpath in (lib.loc %||% .libPaths())) { pkgpath <- file.path(libpath, package) descpath <- file.path(pkgpath, "DESCRIPTION") if (file.exists(descpath)) @@ -18349,7 +20208,7 @@ renv_package_find_impl <- function(package, } # if that failed, check to see if it's loaded and use the associated path - if (check.loaded && package %in% loadedNamespaces()) { + if (is.null(lib.loc) && package %in% loadedNamespaces()) { path <- renv_namespace_path(package) if (file.exists(path)) return(path) @@ -18359,8 +20218,8 @@ renv_package_find_impl <- function(package, "" } -renv_package_installed <- function(package, lib.loc = renv_libpaths_all()) { - paths <- renv_package_find(package, lib.loc, check.loaded = FALSE) +renv_package_installed <- function(package, lib.loc = NULL) { + paths <- renv_package_find(package, lib.loc = lib.loc %||% renv_libpaths_all()) nzchar(paths) } @@ -18373,9 +20232,14 @@ renv_package_version <- function(package) { } renv_package_description_field <- function(package, field) { + path <- renv_package_find(package) + if (!nzchar(path)) + return(NULL) + desc <- renv_description_read(path) desc[[field]] + } renv_package_type <- function(path, quiet = FALSE, default = "source") { @@ -18474,8 +20338,58 @@ renv_package_pkgtypes <- function() { } +renv_package_augment_standard <- function(path, record) { + + # check whether we tagged a url + type for this package + url <- attr(record, "url", exact = TRUE) + type <- attr(record, "type", exact = TRUE) + name <- attr(record, "name", exact = TRUE) + if (is.null(url) || is.null(type)) + return(record) + + # skip if this isn't a repository remote + if (!identical(record$Source, "Repository")) + return(record) + + # skip if the DESCRIPTION file already has Remote fields + # (mainly relevant for r-universe) + descpath <- file.path(path, "DESCRIPTION") + desc <- renv_description_read(descpath) + if (any(grepl("^Remote", names(desc)))) + return(record) + + # figure out base of repository URL + pattern <- "/(?:bin|src)/" + index <- regexpr(pattern, url, perl = TRUE) + repos <- substring(url, 1L, index - 1L) + + # figure out the platform + platform <- if (identical(type, "binary")) R.version$platform else "source" + + # build pak-compatible standard remote reference + remotes <- list( + RemoteType = "standard", + RemoteRef = record$Package, + RemotePkgRef = record$Package, + RemoteRepos = repos, + RemoteReposName = name, + RemotePkgPlatform = platform, + RemoteSha = record$Version + ) + + # if the repository value and name are identical, then exclude the name + if (identical(repos, name)) + remotes$RemoteReposName <- NULL + + overlay(record, remotes) + +} + renv_package_augment <- function(installpath, record) { + # figure out if we should write this as a 'standard' remote + record <- renv_package_augment_standard(installpath, record) + # check for remotes fields remotes <- record[grep("^Remote", names(record))] if (empty(remotes)) @@ -18549,8 +20463,8 @@ renv_package_augment_metadata <- function(path, remotes) { # find recursive dependencies of a package. note that this routine # doesn't farm out to CRAN; it relies on the package and its dependencies # all being installed locally. returns a named vector mapping package names -# to the path where they were discovered, or NA if those packages are not -# installed +# to the path where they were discovered, or an empty string if those packages +# are not installed renv_package_dependencies <- function(packages, libpaths = NULL, fields = NULL, @@ -18730,15 +20644,6 @@ renv_package_unpack <- function(package, path, subdir = "", force = FALSE) { # find DESCRIPTION files in the archive descpaths <- renv_archive_find(path, "(?:^|/)DESCRIPTION$") - # check for a top-level DESCRIPTION file - # this is done in case the archive has been already been re-packed, so that a - # package originally located within a sub-directory is now at the top level - if (!force) { - descpath <- grep("^[^/]+/DESCRIPTION$", descpaths, perl = TRUE, value = TRUE) - if (length(descpath)) - return(path) - } - # try to resolve the path to the DESCRIPTION file in the archive descpath <- if (nzchar(subdir)) { pattern <- sprintf("(?:^|/)\\Q%s\\E/DESCRIPTION$", subdir) @@ -18748,7 +20653,16 @@ renv_package_unpack <- function(package, path, subdir = "", force = FALSE) { descpaths[n == min(n)] } - # if this failed, error + # if this failed, check for a top-level DESCRIPTION file + # this is done in case the archive has been already been re-packed, so that a + # package originally located within a sub-directory is now at the top level + if (!force && length(descpath) != 1L) { + descpath <- grep("^[^/]+/DESCRIPTION$", descpaths, perl = TRUE, value = TRUE) + if (length(descpath)) + return(path) + } + + # if this still failed, error if (length(descpath) != 1L) { fmt <- "internal error: couldn't find DESCRIPTION file for package '%s' in archive '%s'" stopf(fmt, package, path) @@ -18765,13 +20679,32 @@ renv_package_unpack <- function(package, path, subdir = "", force = FALSE) { # rename (without sub-directory) oldpath <- file.path(old, dirname(descpath)) newpath <- file.path(new, package) - file.rename(oldpath, newpath) - # use newpath - newpath + # https://github.com/rstudio/renv/issues/2156 + status <- tryCatch(file.rename(oldpath, newpath), condition = identity) + if (identical(status, TRUE)) + return(newpath) + + fmt <- "file.rename() failed while unpacking package %s; retrying..." + dlog("package", fmt, package) + + for (i in 1:60) { + Sys.sleep(1) + status <- tryCatch(file.rename(oldpath, newpath), condition = identity) + if (identical(status, TRUE)) + return(newpath) + } + + stop(status) } +renv_package_libsdir <- function(package, arch = NULL) { + package <- renv_package_find(package) + arch <- arch %||% if (nzchar(.Platform$r_arch)) .Platform$r_arch + paste(c(package, "libs", arch), collapse = "/") +} + # packages.R ----------------------------------------------------------------- @@ -18802,13 +20735,14 @@ renv_packages_recommended <- function() { # the minimum-required version of 'pak' for renv integration -the$pak_minver <- numeric_version("0.5.1") +the$pak_minver <- numeric_version("0.9.0") renv_pak_init <- function(stream = NULL, force = FALSE) { - stream <- stream %||% renv_pak_stream() - if (force || !renv_pak_available()) + if (force || !renv_pak_available()) { + stream <- stream %||% renv_pak_stream() renv_pak_init_impl(stream) + } renv_namespace_load("pak") @@ -18852,8 +20786,11 @@ renv_pak_repos <- function(stream) { renv_pak_init_impl <- function(stream) { - repos <- c("r-lib" = renv_pak_repos(stream)) - renv_scope_options(renv.config.pak.enabled = FALSE, repos = repos) + renv_scope_options( + renv.config.pak.enabled = FALSE, + renv.config.ppm.enabled = FALSE, + repos = c("r-lib" = renv_pak_repos(stream)) + ) library <- renv_libpaths_active() install("pak", library = library) @@ -18861,10 +20798,51 @@ renv_pak_init_impl <- function(stream) { } -renv_pak_install <- function(packages, library, project) { +renv_pak_update <- function(project, library, prompt) { + + pak <- renv_namespace_load("pak") + # if this project contains a DESCRIPTION file, use it when + # determining which packages to update + if (file.exists(file.path(project, "DESCRIPTION"))) { + + result <- pak$local_install_dev_deps( + root = project, + lib = library[[1L]], + ask = prompt + ) + + return(result) + } + + # read description files for all installed packages + # TODO: do we want to also update packages in other library paths, + # or just packages installed in the project library? + records <- renv_snapshot_libpaths(library[[1L]], project = project) + remotes <- map_chr(records, renv_record_format_remote, versioned = FALSE, pak = TRUE) + if (length(remotes) == 0L) { + caution("- There are no packages to update.") + return(invisible(NULL)) + } + + # update those packages + pak$pkg_install( + pkg = unname(remotes), + lib = library[[1L]], + upgrade = TRUE, + ask = prompt + ) + +} + +renv_pak_install <- function(packages, + library, + type, + rebuild, + prompt, + project) +{ pak <- renv_namespace_load("pak") - lib <- library[[1L]] # transform repositories if (renv_ppm_enabled()) { @@ -18884,20 +20862,44 @@ renv_pak_install <- function(packages, library, project) { else as.character(packages) + # if no packages were specified, treat this as a request to + # install / update packages used in the project if (length(packages) == 0L) - return(pak$local_install_dev_deps(root = project, lib = lib)) + return(renv_pak_update(project, library, prompt)) + + # pak doesn't support ':' as a sub-directory separator, so try to + # repair that here + # https://github.com/rstudio/renv/issues/2011 + pattern <- "(? 1) + if (cores > 1L) parallel::mclapply(data, callback, mc.cores = cores) else lapply(data, callback) @@ -19299,7 +21308,8 @@ renv_path_normalize_unix <- function(path, winslash = "/", mustWork = FALSE) { - # force paths to be absolute + # force paths to be absolute -- this ensures that path prefixes + # are prepended even if the path does not exist bad <- !map_lgl(path, renv_path_absolute) if (any(bad)) { prefix <- normalizePath(".", winslash = winslash) @@ -19400,7 +21410,7 @@ renv_path_pretty <- function(path) { } renv_path_relative <- function(path, root) { - within <- startswith(path, root) + within <- startsWith(path, root) path[within] <- substring(path[within], nchar(root) + 2L) path } @@ -19477,7 +21487,7 @@ renv_paths_lockfile <- function(project = NULL) { return(override) } - # otherwise, use default location (location location relative to renv folder) + # otherwise, use default location (location relative to renv folder) project <- renv_project_resolve(project) renv <- renv_paths_renv(project = project) file.path(dirname(renv), "renv.lock") @@ -19537,6 +21547,7 @@ renv_paths_cache <- function(..., version = NULL) { renv_paths_common("cache", c(version, platform), ...) } + renv_paths_rtools <- function() { root <- renv_paths_override("rtools") @@ -19552,8 +21563,8 @@ renv_paths_extsoft <- function(...) { renv_paths_common("extsoft", c(), ...) } -renv_paths_mran <- function(...) { - renv_paths_common("mran", c(), ...) +renv_paths_p3m <- function(...) { + renv_paths_common("p3m", c(), ...) } renv_paths_index <- function(...) { @@ -19694,7 +21705,6 @@ renv_paths_root_default_tempdir <- function() { #' \code{RENV_PATHS_RENV} \tab The path to the project's renv folder. For advanced users only. \cr #' \code{RENV_PATHS_RTOOLS} \tab (Windows only) The path to [Rtools](https://cran.r-project.org/bin/windows/Rtools/). \cr #' \code{RENV_PATHS_EXTSOFT} \tab (Windows only) The path containing external software needed for compilation of Windows source packages. \cr -#' \code{RENV_PATHS_MRAN} \tab The path containing MRAN-related metadata. See `vignette("mran", package = "renv")` for more details. \cr #' } #' #' (If you want these settings to persist in your project, it is recommended that @@ -19753,11 +21763,12 @@ renv_paths_root_default_tempdir <- function() { #' ``` #' #' The prefix will be constructed based on fields within the system's -#' `/etc/os-release` file. +#' `/etc/os-release` file. Note that this is the default behavior with +#' `renv 1.0.6` when using R 4.4.0 or later. #' #' # Package cellar #' -#' If your project depends on one or \R packages that are not available in any +#' If your project depends on one or more \R packages that are not available in any #' remote location, you can still provide a locally-available tarball for renv #' to use during restore. By default, these packages should be made available in #' the folder as specified by the `RENV_PATHS_CELLAR` environment variable. The @@ -19813,26 +21824,41 @@ paths <- list( pip_freeze <- function(..., python = NULL) { + python <- python %||% renv_python_active() + hook <- getOption("renv.hooks.pip_freeze") + if (is.function(hook)) + return(hook(python = python)) + renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1") python <- renv_path_canonicalize(python) args <- c("-m", "pip", "freeze") action <- "invoking pip freeze" renv_system_exec(python, args, action, ...) + } pip_install <- function(modules, ..., python = NULL) { + python <- python %||% renv_python_active() + hook <- getOption("renv.hooks.pip_install") + if (is.function(hook)) + return(hook(modules = modules, python = python)) + renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1") python <- renv_path_canonicalize(python) args <- c("-m", "pip", "install", "--upgrade", modules) action <- paste("installing", paste(shQuote(modules), collapse = ", ")) renv_system_exec(python, args, action, ...) + } pip_install_requirements <- function(requirements, ..., python = NULL) { python <- python %||% renv_python_active() + hook <- getOption("renv.hooks.pip_install_requirements") + if (is.function(hook)) + return(hook(requirements = requirements, python = python)) file <- renv_scope_tempfile("renv-requirements-", fileext = ".txt") writeLines(requirements, con = file) @@ -19848,6 +21874,9 @@ pip_install_requirements <- function(requirements, ..., python = NULL) { pip_uninstall <- function(modules, ..., python = NULL) { python <- python %||% renv_python_active() + hook <- getOption("renv.hooks.pip_uninstall") + if (is.function(hook)) + return(hook(modules = modules, python = python)) renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1") python <- renv_path_canonicalize(python) @@ -19863,10 +21892,34 @@ pip_uninstall <- function(modules, ..., python = NULL) { # platform.R ----------------------------------------------------------------- -the$sysinfo <- NULL +the$distro <- NULL +the$os <- NULL +the$platform <- NULL +the$prefix <- NULL +the$sysinfo <- NULL renv_platform_init <- function() { - the$sysinfo <- Sys.info() + + the$sysinfo <- as.list(Sys.info()) + + the$platform <- if (file.exists("/etc/os-release")) { + renv_properties_read( + path = "/etc/os-release", + delimiter = "=", + dequote = TRUE, + trim = TRUE + ) + } + + the$os <- tolower(the$sysinfo$sysname) + + # NOTE: This is chosen to be compatible with the distribution field + # used within r-system-requirements. + if (the$os == "linux") { + aliases <- list(rhel = "redhat") + the$distro <- alias(the$platform$ID, aliases) + } + } renv_platform_unix <- function() { @@ -19905,7 +21958,7 @@ renv_platform_wsl <- function() { } renv_platform_prefix <- function() { - renv_bootstrap_platform_prefix() + (the$prefix <- the$prefix %||% renv_bootstrap_platform_prefix()) } renv_platform_os <- function() { @@ -19920,10 +21973,44 @@ renv_platform_machine <- function() { # ppm.R ---------------------------------------------------------------------- +renv_ppm_parse <- function(url) { + + pattern <- paste0( + "^", # start of url + "(?", # start of root of url + "(?[^:]+)://", # scheme + "(?[^/]+)", # authority + ")/", # end of root of url + "(?[^/]+)/", # repository name + "(?:", # begin optional binary parts + "(?__[^_]+__)/", # binary prefix + "(?[^/]+)/", # platform for binaries + ")?", # end optional binary parts + "(?[^/]+)", # snapshot + "$" + ) + + matches <- gregexpr(pattern, url, perl = TRUE)[[1]] + starts <- attr(matches, "capture.start") + ends <- starts + attr(matches, "capture.length") - 1 + strings <- substring(url, starts, ends) + names(strings) <- attr(matches, "capture.names") + + if (length(strings) == 0L || !any(nzchar(strings))) + return(NULL) + + as.list(c(url = url, strings)) + +} + renv_ppm_normalize <- function(url) { sub("/__[^_]+__/[^/]+/", "/", url) } +renv_ppm_is_manylinux <- function(url) { + grepl("/__linux__/manylinux_\\d+_\\d+/", url) +} + renv_ppm_transform <- function(repos = getOption("repos")) { map_chr(repos, function(url) { tryCatch( @@ -19954,6 +22041,10 @@ renv_ppm_transform_impl <- function(url) { if (!grepl("^https?://", url)) return(url) + # manylinux URLs are already in the desired format + if (renv_ppm_is_manylinux(url)) + return(url) + # if this already appears to be a binary URL, then avoid # transforming it if (grepl("/__[^_]+__/", url)) @@ -19976,15 +22067,11 @@ renv_ppm_transform_impl <- function(url) { # check if this is an 'ignored' URL; that is, a repository which we # know is not a PPM URL - mirrors <- catch(getCRANmirrors(local.only = TRUE)) + mirrors <- renv_cran_mirrors() ignored <- c( getOption("renv.ppm.ignoredUrls", default = character()), settings$ppm.ignored.urls(), - mirrors$URL, - "http://cran.rstudio.com", - "http://cran.rstudio.org", - "https://cran.rstudio.com", - "https://cran.rstudio.org" + mirrors ) if (sub("/+$", "", url) %in% sub("/+$", "", ignored)) @@ -19996,14 +22083,14 @@ renv_ppm_transform_impl <- function(url) { getOption("renv.ppm.repos", default = NULL) ) - if (any(startswith(url, known))) { + if (any(startsWith(url, known))) { parts <- c(dirname(url), "__linux__", platform, basename(url)) binurl <- paste(parts, collapse = "/") return(binurl) } - # try to query the status endpoint - # TODO: this could fail if the URL is a proxy back to PPM? + # try to query the status endpoint -- if this fails, + # assume the repository is not a ppm URL base <- dirname(dirname(url)) status <- catch(renv_ppm_status(base)) if (inherits(status, "error")) @@ -20086,6 +22173,12 @@ renv_ppm_platform_impl <- function(file = "/etc/os-release") { id <- properties$ID %||% "" + # handle distros based on Ubuntu + if ("UBUNTU_CODENAME" %in% names(properties)) { + id <- "ubuntu" + properties$VERSION_CODENAME <- properties$UBUNTU_CODENAME + } + case( identical(id, "ubuntu") ~ renv_ppm_platform_ubuntu(properties), identical(id, "centos") ~ renv_ppm_platform_centos(properties), @@ -20127,9 +22220,10 @@ renv_ppm_platform_rhel <- function(properties) { id <- properties$VERSION_ID if (is.null(id)) return(NULL) - rhel_version <- ifelse(numeric_version(id) < "9", "centos", "rhel") - paste0(rhel_version, substring(id, 1L, 1L)) + name <- ifelse(numeric_version(id) < "9", "centos", "rhel") + version <- strsplit(id, ".", fixed = TRUE)[[1L]][[1L]] + paste0(name, version) } @@ -20138,9 +22232,9 @@ renv_ppm_platform_rocky <- function(properties) { id <- properties$VERSION_ID if (is.null(id)) return(NULL) - rhel_version <- ifelse(numeric_version(id) < "9", "centos", "rhel") - paste0(rhel_version, substring(id, 1L, 1L)) + version <- ifelse(numeric_version(id) < "9", "centos", "rhel") + paste0(version, substring(id, 1L, 1L)) } @@ -20149,9 +22243,9 @@ renv_ppm_platform_alma <- function(properties) { id <- properties$VERSION_ID if (is.null(id)) return(NULL) - rhel_version <- ifelse(numeric_version(id) < "9", "centos", "rhel") - paste0(rhel_version, substring(id, 1L, 1L)) + version <- ifelse(numeric_version(id) < "9", "centos", "rhel") + paste0(version, substring(id, 1L, 1L)) } @@ -20407,10 +22501,10 @@ renv_pretty_print_records <- function(preamble, records, postamble = NULL) { } renv_pretty_print_records_pair <- function(preamble, - old, - new, - postamble = NULL, - formatter = NULL) + old, + new, + postamble = NULL, + formatter = NULL) { formatter <- formatter %||% renv_record_format_pair @@ -20582,21 +22676,25 @@ renv_project_get <- function(default = NULL) { the$project_path %||% default } -# NOTE: RENV_PROJECT kept for backwards compatibility with RStudio +# NOTE: 'RENV_PROJECT' kept for backwards compatibility with RStudio renv_project_set <- function(project) { the$project_path <- project + # https://github.com/rstudio/renv/issues/2036 + options(renv.project.path = project) Sys.setenv(RENV_PROJECT = project) } # NOTE: 'RENV_PROJECT' kept for backwards compatibility with RStudio renv_project_clear <- function() { the$project_path <- NULL + # https://github.com/rstudio/renv/issues/2036 + options(renv.project.path = NULL) Sys.unsetenv("RENV_PROJECT") } renv_project_resolve <- function(project = NULL, default = getwd()) { project <- project %||% renv_project_get(default = default) - renv_path_normalize(project) + if (is.null(project)) project else renv_path_normalize(project) } renv_project_initialized <- function(project) { @@ -20652,16 +22750,13 @@ renv_project_type_impl <- function(path) { } -renv_project_remotes <- function(project, fields = NULL) { +renv_project_remotes <- function(project, filter = NULL, resolve = FALSE) { descpath <- file.path(project, "DESCRIPTION") if (!file.exists(descpath)) return(NULL) - # first, parse remotes (if any) - remotes <- renv_description_remotes(descpath) - - # next, find packages mentioned in the DESCRIPTION file + # find packages mentioned in the DESCRIPTION file deps <- renv_dependencies_discover_description( path = descpath, project = project @@ -20690,29 +22785,45 @@ renv_project_remotes <- function(project, fields = NULL) { } } + # parse remotes if available + remotes <- renv_description_remotes(descpath) + + # apply filter + if (!is.null(filter)) + specs <- filter(specs, remotes) + # now, try to resolve the packages records <- enumerate(specs, function(package, spec) { - # use remote if supplied - if (!is.null(remotes[[package]])) - return(remotes[[package]]) - - # check for explicit version requirement - explicit <- spec[spec$Require == "==", ] - if (nrow(explicit) == 0) - return(renv_remotes_resolve(package)) + # return a function here, so we can lazily resolve these as needed + # https://github.com/rstudio/renv/issues/1755 + function() { + + # use remote if supplied + if (!is.null(remotes[[package]])) + return(remotes[[package]]) + + # check for explicit version requirement + explicit <- spec[spec$Require == "==", ] + if (nrow(explicit)) { + version <- explicit$Version[[1L]] + if (nzchar(version)) { + entry <- paste(package, version, sep = "@") + return(renv_remotes_resolve(entry)) + } + } - version <- spec$Version[[1]] - if (!nzchar(version)) - return(renv_remotes_resolve(package)) + # check if we're being invoked during restore or install + # if so, we may want to re-use an already-existing package + # https://github.com/rstudio/renv/issues/2071 + packages <- renv_restore_state(key = "packages") + renv_remotes_resolve(package, infer = !package %in% packages) - entry <- paste(package, version, sep = "@") - renv_remotes_resolve(entry) + } }) - # return records - records + if (resolve) map(records, resolve) else records } @@ -20841,6 +22952,12 @@ renv_properties_read <- function(path = NULL, # split into key / value pairs index <- regexpr(delimiter, parts, fixed = TRUE) + + # if we couldn't match a delimiter, treat the whole thing as a key + missed <- index == -1 + index[missed] <- nchar(parts)[missed] + 1L + + # perform the subsetting keys <- substring(parts, 1L, index - 1L) vals <- substring(parts, index + 1L) @@ -20957,7 +23074,7 @@ renv_purge_impl <- function(package, missing <- !file.exists(paths) if (any(missing)) { - caution_bullets( + bulletin( "The following entries were not found in the cache:", paths[missing], "They will be ignored." @@ -20970,7 +23087,7 @@ renv_purge_impl <- function(package, # nocov start if (prompt || renv_verbose()) { - caution_bullets( + bulletin( "The following packages will be purged from the cache:", renv_cache_format_path(paths) ) @@ -21206,7 +23323,7 @@ renv_python_virtualenv_snapshot <- function(project, prompt, python) { return(FALSE) } - caution_bullets("The following will be written to requirements.txt:", after) + bulletin("The following will be written to requirements.txt:", after) cancel_if(prompt && !proceed()) @@ -21226,19 +23343,18 @@ renv_python_virtualenv_restore <- function(project, prompt, python) { if (!file.exists(path)) return(FALSE) - before <- readLines(path, warn = FALSE) - after <- pip_freeze(python = python) - diff <- renv_vector_diff(before, after) + saved <- readLines(path, warn = FALSE) + current <- pip_freeze(python = python) + diff <- renv_vector_diff(saved, current) if (empty(diff)) { writef("- The Python library is already up to date.") return(FALSE) } - caution_bullets("The following Python packages will be restored:", diff) - + bulletin("The following Python packages will be restored:", diff) cancel_if(prompt && !proceed()) - pip_install_requirements(diff, python = python, stream = TRUE) + pip_install_requirements(saved, python = python, stream = TRUE) TRUE } @@ -21337,7 +23453,7 @@ renv_python_exe <- function(path) { # if this already looks like a Python executable, use it directly info <- renv_file_info(path) - if (identical(info$isdir, FALSE) && startswith(basename(path), "python")) + if (identical(info$isdir, FALSE) && startsWith(basename(path), "python")) return(renv_path_canonicalize(path)) # otherwise, attempt to infer the Python executable type @@ -21696,6 +23812,10 @@ r <- function(args, ...) { # ensure Rtools is on the PATH for Windows renv_scope_rtools() + # use the same tar for installation as currently configured + tar <- Sys.getenv("R_INSTALL_TAR", unset = renv_tar_exe(default = "internal")) + renv_scope_envvars(R_INSTALL_TAR = tar) + # invoke r suppressWarnings(system2(R(), args, ...)) @@ -22184,12 +24304,11 @@ renv_record_normalize <- function(record) { # normalize source source <- record$Source %||% "unknown" - if (source %in% c("CRAN", "PPM", "RSPM")) + if (source %in% c("CRAN", "P3M", "PPM", "RSPM")) record$Source <- "Repository" # drop remotes from records with a repository source - if (identical(record$Source, "Repository") || - identical(record$RemoteType, "standard")) + if (renv_record_cranlike(record)) record <- record[grep("^Remote", names(record), invert = TRUE)] # keep only specific records for comparison @@ -22202,6 +24321,32 @@ renv_record_normalize <- function(record) { } +renv_record_tag <- function(record, type, url, name) { + + attr(record, "url") <- url + attr(record, "type") <- type + attr(record, "name") <- name + + record + +} + +renv_record_tagged <- function(record) { + attrs <- attributes(record) + all(c("url", "type") %in% names(attrs)) +} + +# abstracted out in case we want to use a different sigil in the future, +# like `_`, ``, or something else +renv_record_placeholder <- function() { + "*" +} + +renv_record_cranlike <- function(record) { + type <- record[["RemoteType"]] + is.null(type) || tolower(type) %in% c("cran", "repository", "standard") +} + # records.R ------------------------------------------------------------------ @@ -22300,21 +24445,130 @@ renv_record_validate <- function(package, record) { } -renv_record_format_remote <- function(record) { +renv_record_format_remote <- function(record, + compact = FALSE, + versioned = TRUE, + pak = FALSE) +{ + # if we have a pkgref, we can use that directly + pkgref <- record$RemotePkgRef + if (!is.null(pkgref)) + return(pkgref) - remotes <- c("RemoteUsername", "RemoteRepo") - if (all(remotes %in% names(record))) - return(renv_record_format_short_remote(record)) + # extract some of the commonly used fields up-front + source <- renv_record_source(record, normalize = TRUE) + package <- record[["Package"]] + version <- record[["Version"]] + + # handle repository remotes + if (source %in% c("cran", "repository", "standard")) { + parts <- c(package, if (versioned) version) + remote <- paste(parts, collapse = "@") + return(remote) + } + + # handle bioconductor remotes + if (source %in% "bioconductor") { + parts <- c(package, if (versioned) version) + suffix <- paste(parts, collapse = "@") + remote <- paste("bioc", suffix, sep = "::") + return(remote) + } - paste(record$Package, record$Version, sep = "@") + # handle git, svn remotes + if (source %in% c("git", "svn")) { + url <- record[["RemoteUrl"]] + remote <- sprintf("%s::%s", source, url) + return(remote) + } + + # handle local, url remotes + if (source %in% c("local", "url")) { + url <- record[["RemoteUrl"]] %||% sub("[^:]+::", "", record[["RemotePkgRef"]]) + remote <- sprintf("%s=%s::%s", package, source, url) + return(remote) + } + + # handle other remotes; assumed to be a github-like remote + host <- record[["RemoteHost"]] + user <- record[["RemoteUsername"]] + repo <- record[["RemoteRepo"]] + type <- record[["RemoteType"]] + ref <- record[["RemoteRef"]] + sha <- record[["RemoteSha"]] + subdir <- record[["RemoteSubdir"]] + subdirsep <- if (pak) "/" else ":" + + # skip type and host if they're defaults + if (identical(type, "github")) { + if (is.null(host) || identical(host, "api.github.com")) { + type <- NULL + host <- NULL + } + } + # omit gitlab host as well for default host + if (identical(type, "gitlab")) { + if (identical(host, "gitlab.com")) { + host <- NULL + } + } + + # skip 'boring' refs for compact display + if (compact) { + if (length(ref) && ref %in% c("HEAD", "main", "master")) { + ref <- NULL + sha <- NULL + } + } + + # start building the remote specification + stk <- stack(mode = "character") + + if (!identical(package, repo)) + stk$push(package, "=") + + if (!is.null(type)) { + stk$push(type) + if (!is.null(host) && nzchar(host)) + stk$push("@", host) + stk$push("::") + } + + stk$push(user, "/", repo) + + if (!is.null(subdir) && nzchar(subdir)) + stk$push(subdirsep, subdir) + + if (versioned) { + + if (pak) { + stk$push("@", sha %||% ref %||% "HEAD") + } else if (length(sha)) { + stk$push("@", if (compact) substring(sha, 1L, 8L) else sha) + } else if (length(ref)) { + stk$push("@", ref) + } + + } else { + + if (length(ref)) + stk$push("@", ref) + + } + + remote <- paste(stk$data(), collapse = "") + return(remote) } renv_record_format_short <- function(record, versioned = FALSE) { + if (is.null(record)) + return(renv_record_placeholder()) + remotes <- c("RemoteUsername", "RemoteRepo") if (all(remotes %in% names(record))) { - remote <- renv_record_format_short_remote(record) + remote <- renv_record_format_remote(record, compact = TRUE) if (versioned) remote <- sprintf("%s [%s]", record$Version %||% "", remote) return(remote) @@ -22324,34 +24578,16 @@ renv_record_format_short <- function(record, versioned = FALSE) { } -renv_record_format_short_remote <- function(record) { - - text <- paste(record$RemoteUsername, record$RemoteRepo, sep = "/") +renv_record_format_pair <- function(lhs, rhs, separator = "->") { - subdir <- record$RemoteSubdir %||% "" - if (nzchar(subdir)) - text <- paste(text, subdir, sep = ":") - - if (!is.null(record$RemoteRef)) { - ref <- record$RemoteRef - if (!identical(ref, "master")) - text <- paste(text, record$RemoteRef, sep = "@") - } else if (!is.null(record$RemoteSha)) { - sha <- substring(record$RemoteSha, 1L, 8L) - text <- paste(text, sha, sep = "@") - } - - text - -} - -renv_record_format_pair <- function(lhs, rhs) { + placeholder <- renv_record_placeholder() # check for install / remove - if (is.null(lhs)) - return(sprintf("[* -> %s]", renv_record_format_short(rhs))) - else if (is.null(rhs)) - return(sprintf("[%s -> *]", renv_record_format_short(lhs))) + if (is.null(lhs) || is.null(rhs)) { + lhs <- renv_record_format_short(lhs) + rhs <- renv_record_format_short(rhs) + return(sprintf("[%s %s %s]", lhs, separator, rhs)) + } map <- list( Source = "src", @@ -22390,10 +24626,10 @@ renv_record_format_pair <- function(lhs, rhs) { identical(lhs$Repository, rhs$Repository) if (isrepo) { - fmt <- "[%s -> %s]" + fmt <- "[%s %s %s]" lhsf <- renv_record_format_short(lhs) rhsf <- renv_record_format_short(rhs) - return(sprintf(fmt, lhsf, rhsf)) + return(sprintf(fmt, lhsf, separator, rhsf)) } # check for only sha changed @@ -22403,60 +24639,60 @@ renv_record_format_pair <- function(lhs, rhs) { if (usesha) { - user <- lhs$RemoteUsername %||% "*" - repo <- lhs$RemoteRepo %||% "*" + user <- lhs$RemoteUsername %||% placeholder + repo <- lhs$RemoteRepo %||% placeholder spec <- paste(user, repo, sep = "/") - ref <- lhs$RemoteRef %||% "*" - if (!ref %in% c("master", "*")) + ref <- lhs$RemoteRef %||% placeholder + if (!ref %in% c("main", "master", "*")) spec <- paste(spec, ref, sep = "@") - fmt <- "[%s: %s -> %s]" - lsha <- substring(lhs$RemoteSha %||% "*", 1L, 8L) - rsha <- substring(rhs$RemoteSha %||% "*", 1L, 8L) + fmt <- "[%s: %s %s %s]" + lsha <- substring(lhs$RemoteSha %||% placeholder, 1L, 8L) + rsha <- substring(rhs$RemoteSha %||% placeholder, 1L, 8L) - return(sprintf(fmt, spec, lsha, rsha)) + return(sprintf(fmt, spec, lsha, separator, rsha)) } # check for only source change if (setequal(changed, "Source")) { - fmt <- "[%s: %s -> %s]" - ver <- lhs$Version %||% "*" - lhsf <- lhs$Source %||% "*" - rhsf <- rhs$Source %||% "*" - return(sprintf(fmt, ver, lhsf, rhsf)) + fmt <- "[%s: %s %s %s]" + ver <- lhs$Version %||% placeholder + lhsf <- lhs$Source %||% placeholder + rhsf <- rhs$Source %||% placeholder + return(sprintf(fmt, ver, lhsf, separator, rhsf)) } # check only version changed if (setequal(changed, "Version")) { - fmt <- "[%s -> %s]" - lhsf <- lhs$Version %||% "*" - rhsf <- rhs$Version %||% "*" - return(sprintf(fmt, lhsf, rhsf)) + fmt <- "[%s %s %s]" + lhsf <- lhs$Version %||% placeholder + rhsf <- rhs$Version %||% placeholder + return(sprintf(fmt, lhsf, separator, rhsf)) } # if the source has changed, highlight that if ("Source" %in% changed) { - fmt <- "[%s -> %s]" + fmt <- "[%s %s %s]" lhsf <- renv_record_format_short(lhs) rhsf <- renv_record_format_short(rhs) - return(sprintf(fmt, lhsf, rhsf)) + return(sprintf(fmt, lhsf, separator, rhsf)) } # otherwise, report each diff individually diffs <- map_chr(changed, function(field) { - lhsf <- lhs[[field]] %||% "*" - rhsf <- rhs[[field]] %||% "*" + lhsf <- lhs[[field]] %||% placeholder + rhsf <- rhs[[field]] %||% placeholder if (field == "RemoteSha") { lhsf <- substring(lhsf, 1L, 8L) rhsf <- substring(rhsf, 1L, 8L) } - fmt <- "%s: %s -> %s" - sprintf(fmt, map[[field]], lhsf, rhsf) + fmt <- "%s: %s %s %s" + sprintf(fmt, map[[field]], lhsf, separator, rhsf) }) sprintf("[%s]", paste(diffs, collapse = "; ")) @@ -22499,30 +24735,10 @@ renv_records_resolve <- function(records, latest = FALSE) { recurse <- function(object, callback, ...) { - renv_recurse_impl(list(), object, callback, ...) -} - -renv_recurse_impl <- function(stack, object, callback, ...) { - - # ignore missing values - if (missing(object) || identical(object, quote(expr = ))) - return(FALSE) - - # push node on to stack - stack[[length(stack) + 1]] <- object - - # invoke callback - result <- callback(object, stack, ...) - if (is.call(result)) - object <- result - else if (identical(result, FALSE)) - return(FALSE) - - # recurse + callback(object, ...) if (is.recursive(object)) for (i in seq_along(object)) - renv_recurse_impl(stack, object[[i]], callback, ...) - + recurse(object[[i]], callback, ...) } @@ -22658,7 +24874,7 @@ renv_rehash_cache <- function(cache, prompt, action, label) { packages <- basename(old)[changed] oldhash <- renv_path_component(old[changed], 2L) newhash <- renv_path_component(new[changed], 2L) - caution_bullets( + bulletin( "The following packages will be re-cached:", sprintf(fmt, format(packages), format(oldhash), format(newhash)), sprintf("Packages will be %s to their new locations in the cache.", label) @@ -22736,16 +24952,31 @@ remote <- function(spec) { # take a short-form remotes spec, parse that into a remote, # and generate a corresponding package record -renv_remotes_resolve <- function(spec, latest = FALSE) { +renv_remotes_resolve <- function(spec, latest = FALSE, infer = FALSE) { # check for already-resolved specs if (is.null(spec) || is.list(spec)) return(spec) + # check for a package name prefix and remove it + regexps <- .standard_regexps() + pattern <- sprintf("^%s=", regexps$valid_package_name) + spec <- sub(pattern, "", spec) + # remove a trailing slash # https://github.com/rstudio/renv/issues/1135 spec <- gsub("/+$", "", spec, perl = TRUE) + # check if we should infer the package version + # from a locally-installed copy of the package + infer <- + infer && + grepl(renv_regexps_package_name(), spec) && + renv_package_installed(spec) + + if (infer) + spec <- paste(spec, renv_package_version(spec), sep = "@") + # check for archive URLs -- this is a bit hacky if (grepl("^(?:file|https?)://", spec)) { for (suffix in c(".zip", ".tar.gz", ".tgz", "/tarball")) @@ -22766,6 +24997,25 @@ renv_remotes_resolve <- function(spec, latest = FALSE) { return(record) } + # check for explicit local remotes + if (grepl("^local::", spec)) { + spec <- substring(spec, 8L) + record <- catch(renv_remotes_resolve_path(spec)) + if (!inherits(record, "error")) + return(record) + } + + # check for requests to install local packages -- note that depending on how + # the R package was built / generated, it's possible that it might not adhere + # to the "typical" R package names, so we try to be a bit flexible here + ext <- "(?:\\.tar\\.gz|\\.tgz|\\.zip)$" + if (grepl(ext, spec, perl = TRUE)) { + pathlike <- tryCatch(file.exists(spec), condition = identity) + if (identical(pathlike, TRUE)) { + return(renv_remotes_resolve_path(spec)) + } + } + # define error handler (tag error with extra context when possible) error <- function(e) { @@ -22799,6 +25049,12 @@ renv_remotes_resolve_impl <- function(spec, latest = FALSE) { if (isbioc) remote$type <- "bioc" + # treat HEAD refs as an implicit request to use the default branch + # of the associated remote repository + # https://github.com/rstudio/renv/issues/2040 + if (identical(remote$ref, "HEAD")) + remote$ref <- NULL + resolved <- switch( remote$type, bioc = renv_remotes_resolve_bioc(remote), @@ -22820,9 +25076,9 @@ renv_remotes_resolve_impl <- function(spec, latest = FALSE) { } -renv_remotes_parse_impl <- function(spec, pattern, fields, perl = FALSE) { +renv_remotes_parse_impl <- function(spec, pattern, fields) { - matches <- regexec(pattern, spec, perl = perl) + matches <- regexec(pattern, spec, perl = TRUE) strings <- regmatches(spec, matches)[[1]] if (empty(strings)) stopf("'%s' is not a valid remote", spec) @@ -22858,10 +25114,10 @@ renv_remotes_parse_remote <- function(spec) { "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?", # optional package name "(?:([^@:]+)(?:@([^:]+))?::)?", # optional prefix, providing type + host "([^/#@:]+)", # a username - "(?:/([^@#:]+))?", # a repository (allow sub-repositories) - "(?::([^@#:]+))?", # optional subdirectory - "(?:#([^@#:]+))?", # optional hash (e.g. pull request) - "(?:@([^@#:]+))?", # optional ref (e.g. branch or commit) + "(?:[/]([^@#:]+))?", # a repository (allow sub-repositories) + "(?:[:]([^@#]+))?", # optional subdirectory + "(?:[#]([^@]+))?", # optional hash (e.g. pull request) + "(?:[@](.+))?", # optional ref (e.g. branch or commit) "$" ) @@ -22902,7 +25158,7 @@ renv_remotes_parse_gitssh <- function(spec) { "subdir", "pull", "ref" ) - remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE) + remote <- renv_remotes_parse_impl(spec, pattern, fields) if (!nzchar(remote$repo)) stopf("'%s' is not a valid remote", spec) @@ -22945,7 +25201,7 @@ renv_remotes_parse_git <- function(spec) { "subdir", "pull", "ref" ) - remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE) + remote <- renv_remotes_parse_impl(spec, pattern, fields) if (!nzchar(remote$repo)) stopf("'%s' is not a valid remote", spec) @@ -22973,7 +25229,7 @@ renv_remotes_parse_url <- function(spec) { ) fields <- c("spec", "package", "type", "url", "protocol", "path", "subdir") - remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE) + remote <- renv_remotes_parse_impl(spec, pattern, fields) if (!nzchar(remote$url)) stopf("'%s' is not a valid remote", spec) @@ -23153,6 +25409,7 @@ renv_remotes_resolve_repository <- function(remote, latest) { if (latest && is.null(version)) { remote <- renv_available_packages_latest(package) version <- remote$Version + repository <- remote$Repository } list( @@ -23200,8 +25457,9 @@ renv_remotes_resolve_github_sha_ref <- function(host, user, repo, ref) { # build url for github commits endpoint fmt <- "%s/repos/%s/%s/commits/%s" origin <- renv_retrieve_origin(host) - ref <- ref %||% getOption("renv.github.default_branch", default = "master") - url <- sprintf(fmt, origin, user, repo, ref %||% "master") + + ref <- ref %||% renv_remotes_resolve_github_ref(host, user, repo) + url <- sprintf(fmt, origin, user, repo, ref %||% "main") # prepare headers headers <- c(Accept = "application/vnd.github.sha") @@ -23262,7 +25520,7 @@ renv_remotes_resolve_github_modules <- function(host, user, repo, subdir, sha) { } -renv_remotes_resolve_github_description <- function(host, user, repo, subdir, sha) { +renv_remotes_resolve_github_description <- function(url, host, user, repo, subdir, sha) { # form DESCRIPTION path subdir <- subdir %||% "" @@ -23279,7 +25537,7 @@ renv_remotes_resolve_github_description <- function(host, user, repo, subdir, sh # add headers headers <- c( Accept = "application/vnd.github.raw", - renv_download_auth_github() + renv_download_auth_github(url) ) # get the DESCRIPTION contents @@ -23311,7 +25569,7 @@ renv_remotes_resolve_github_ref <- function(host, user, repo) { renv_remotes_resolve_github_ref_impl(host, user, repo), error = function(e) { warning(e) - getOption("renv.github.default_branch", default = "master") + getOption("renv.github.default_branch", default = "main") } ) @@ -23333,7 +25591,7 @@ renv_remotes_resolve_github_ref_impl <- function(host, user, repo) { json <- renv_json_read(jsonfile) # read default branch - json$default_branch %||% getOption("renv.github.default_branch", default = "master") + json$default_branch %||% getOption("renv.github.default_branch", default = "main") } @@ -23361,20 +25619,20 @@ renv_remotes_resolve_github <- function(remote) { ) # if an abbreviated sha was provided as the ref, expand it here - if (nzchar(ref) && startswith(sha, ref)) + if (nzchar(ref) && startsWith(sha, ref)) ref <- sha # check whether the repository has a .gitmodules file; if so, then we'll have # to use a plain 'git' client to retrieve the package modules <- renv_remotes_resolve_github_modules(host, user, repo, subdir, sha) - url <- if (modules) { - origin <- fsub("api.github.com", "github.com", renv_retrieve_origin(host)) - parts <- c(origin, user, repo) - paste(parts, collapse = "/") - } + + # construct full url + origin <- fsub("api.github.com", "github.com", renv_retrieve_origin(host)) + parts <- c(origin, user, repo) + url <- paste(parts, collapse = "/") # read DESCRIPTION - desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha) + desc <- renv_remotes_resolve_github_description(url, host, user, repo, subdir, sha) list( Package = desc$Package, @@ -23508,17 +25766,8 @@ renv_remotes_resolve_git_description <- function(record) { } renv_remotes_resolve_git_pull <- function(pr) { - # to be able to checkout PR 760: - # git fetch origin pull/760/head:pr-760 - # or: - # git fetch origin pull/760/head:pull/760 - - # so format for ref is: - # pull/{ref_number}/head:pr-{ref_number} - fmt <- "pull/%s/head:pull/%s" - - remote_ref <- sprintf(fmt, pr, pr) - remote_ref + fmt <- "pull/%1$s/head:pull/%1$s" + sprintf(fmt, pr) } renv_remotes_resolve_gitlab_ref <- function(host, user, repo) { @@ -23564,11 +25813,11 @@ renv_remotes_resolve_gitlab <- function(remote) { host <- remote$host %||% config$gitlab.host() user <- remote$user repo <- remote$repo - subdir <- remote$subdir %||% "" + subdir <- remote$subdir ref <- remote$ref %||% renv_remotes_resolve_gitlab_ref(host, user, repo) - parts <- c(if (nzchar(subdir)) subdir, "DESCRIPTION") + parts <- c(subdir, "DESCRIPTION") descpath <- URLencode(paste(parts, collapse = "/"), reserved = TRUE) # scope authentication @@ -23613,10 +25862,7 @@ renv_remotes_resolve_gitlab <- function(remote) { renv_remotes_resolve_url <- function(url, quiet = FALSE) { - tempfile <- renv_scope_tempfile("renv-url-") - writeLines(url, con = tempfile) - hash <- tools::md5sum(tempfile) - + hash <- md5(url) ext <- fileext(url, default = ".tar.gz") name <- paste(hash, ext, sep = "") path <- renv_paths_source("url", name) @@ -23776,7 +26022,7 @@ renv_remove_impl <- function(package, library) { #' Each project using renv will share package installations from a global #' cache of packages, helping to avoid wasting disk space on multiple #' installations of a package that might otherwise be shared across projects. -#' +#' "_PACKAGE" @@ -23800,7 +26046,7 @@ renv_renvignore_pattern <- function(path = getwd(), root = path) { # read ignore files parent <- path - while (parent != dirname(parent)) { + repeat { # attempt to read either .renvignore or .gitignore for (file in c(".renvignore", ".gitignore")) { @@ -23815,7 +26061,7 @@ renv_renvignore_pattern <- function(path = getwd(), root = path) { } # stop once we've hit the project root - if (parent == root) + if (parent == root || dirname(parent) == parent) break parent <- dirname(parent) @@ -23841,15 +26087,87 @@ renv_renvignore_pattern <- function(path = getwd(), root = path) { } +renv_renvignore_envir <- function(profile) { + + envir <- new.env(parent = emptyenv()) + + # functions which we want to make available in .renvignore + envir[["c"]] <- base::c + envir[["list"]] <- base::list + envir[["%in%"]] <- base::`%in%` + envir[["if"]] <- base::`if` + envir[["=="]] <- base::`==` + + # also add the profile + envir[["profile"]] <- profile + envir + +} + +renv_renvignore_filter <- function(contents) { + + profile <- renv_profile_get() %||% "default" + + # look for commented lines + matches <- which(startsWith(contents, "#|")) + if (length(matches) == 0L) + return(contents) + + # make evaluation environment up-front if needed + envir <- renv_renvignore_envir(profile) + + # build ranges + starts <- c(1L, matches) + ends <- c(matches - 1L, length(contents)) + ranges <- .mapply(c, list(starts, ends), NULL) + + # for each range, check if the ignore rule applies + # (the first range always applies by default) + keep <- rep.int(TRUE, length(ranges)) + for (i in 2:length(ranges)) { + + # pull out code from header + start <- ranges[[i]][[1L]] + header <- substring(contents[start], 3L) + code <- parse(text = header, keep.source = FALSE)[[1L]] + + # if it's a symbol or a string, match against current profile + if (is.symbol(code) || is.character(code)) { + keep[[i]] <- as.character(code) %in% profile + next + } + + # if it's code, evaluate it within a safe environment + if (is.call(code)) { + keep[[i]] <- eval(code, envir = new.env(parent = envir)) + next + } + + } + + # now pull out the sections which apply + sections <- map(ranges[keep], function(range) { + contents[range[[1L]]:range[[2L]]] + }) + + unlist(sections, use.names = FALSE) + +} + # reads a .gitignore / .renvignore file, and translates the associated # entries into PCREs which can be combined and used during directory traversal renv_renvignore_parse <- function(contents, prefix = "") { + # filter .renvignore contents based on profile + contents <- renv_renvignore_filter(contents) + # read the ignore entries contents <- grep("^\\s*(?:#|$)", contents, value = TRUE, invert = TRUE) if (empty(contents)) return(list()) + # split into regions based on profile comments + # split into inclusion, exclusion patterns negate <- substring(contents, 1L, 1L) == "!" exclude <- contents[!negate] @@ -23876,10 +26194,20 @@ renv_renvignore_parse <- function(contents, prefix = "") { # # The exclusion of 'dir' will take precedence, and dir/matched won't # get a chance to apply. - include <- sort(unique(unlist(map(include, function(rule) { + expanded <- map(include, function(rule) { + + # check for slashes; leave unslashed rules alone idx <- gregexpr("(?:/|$)", rule, perl = TRUE)[[1L]] + if (length(idx) == 1L) + return(rule) + + # otherwise, split into multiple rules for each sub-directory gsub("^/*", "/", substring(rule, 1L, idx)) - })))) + + }) + + # collapse back into a list + include <- unique(unlist(expanded)) # parse patterns separately list( @@ -23928,8 +26256,9 @@ renv_renvignore_parse_impl <- function(entries, prefix = "") { # prepend prefix entries <- sprintf("^\\Q%s/\\E%s", prefix, entries) - # remove \\Q\\E + # remove \\Q\\E, \\E\\Q entries <- gsub("\\Q\\E", "", entries, fixed = TRUE) + entries <- gsub("\\E\\Q", "", entries, fixed = TRUE) # all done! entries @@ -23999,6 +26328,20 @@ renv_renvignore_pattern_extra <- function(key, root) { } +renv_renvignore_create <- function(paths, + create = FALSE, + contents = "*") +{ + for (path in paths) { + if (file.exists(path)) { + ignorefile <- file.path(path, ".renvignore") + if (!file.exists(ignorefile)) + writeLines(contents, con = ignorefile) + } + } +} + + # repair.R ------------------------------------------------------------------- @@ -24096,7 +26439,7 @@ renv_repair_sources <- function(library, lockfile, project) { # ask used renv_scope_options(renv.verbose = TRUE) - caution_bullets( + bulletin( c( "The following package(s) do not have an explicitly-declared remote source.", "However, renv was available to infer remote sources from their DESCRIPTION file." @@ -24134,9 +26477,11 @@ renv_repair_sources <- function(library, lockfile, project) { renv_repair_sources_infer <- function(dcf) { # if this package appears to have a declared remote, use as-is - for (field in c("RemoteType", "Repository", "biocViews")) - if (!is.null(dcf[[field]])) + for (field in c("RemoteType", "Repository", "biocViews")) { + value <- dcf[[field]] + if (nzchar(value %||% "")) return(NULL) + } # ok, this is a package installed from sources that "looks" like # the development version of a package; try to guess its remote @@ -24165,7 +26510,13 @@ renv_repair_sources_infer <- function(dcf) { # report.R ------------------------------------------------------------------- -renv_report_ok <- function(message, elapsed = 0) { +renv_report_ok <- function(message, elapsed = 0, verbose = FALSE) { + + # handle verbose printing first + if (verbose) { + fmt <- "- OK [%s in %s]" + return(writef(fmt, message, renv_difftime_format_short(elapsed))) + } # treat 'quick' times specially if (!testing() && elapsed < 0.1) @@ -24190,23 +26541,36 @@ renv_repos_normalize <- function(repos = getOption("repos")) { cran <- getOption("renv.repos.cran", "https://cloud.r-project.org") repos[repos == "@CRAN@"] <- cran - # if repos is length 1 but has no names, then assume it's CRAN - nms <- names(repos) %||% rep.int("", length(repos)) - if (identical(nms, "")) - nms <- names(repos) <- "CRAN" - # ensure all values are named - unnamed <- !nzchar(nms) - if (any(unnamed)) { - nms[unnamed] <- paste0("V", seq_len(sum(unnamed))) - names(repos) <- nms - } + names(repos) <- renv_repos_names(repos) # return normalized repository repos } +renv_repos_names <- function(repos) { + + result <- enum_chr(repos, function(name, repo) { + + # if we already have a name, use it + if (nzchar(name %||% "")) + return(name) + + # if this repository matches a known CRAN mirror, call it CRAN + mirrors <- renv_cran_mirrors() + if (any(renv_repos_matches(repo, mirrors))) + return("CRAN") + + # otherwise, just use the repository URL as the name + repo + + }) + + unname(result) + +} + renv_repos_validate <- function(repos = getOption("repos")) { # allow empty repository explicitly @@ -24276,6 +26640,12 @@ renv_repos_info_impl <- function(url) { } +renv_repos_matches <- function(url, repos) { + url <- sub("/$", "", as.character(url)) + repos <- sub("/$", "", as.character(repos)) + url %in% repos +} + # restart.R ------------------------------------------------------------------ @@ -24373,22 +26743,43 @@ the$restore_state <- NULL #' Restore project library from a lockfile #' #' Restore a project's dependencies from a lockfile, as previously generated by -#' [snapshot()]. `renv::restore()` compares packages recorded in the lockfile to +#' [snapshot()]. +#' +#' `renv::restore()` compares packages recorded in the lockfile to #' the packages installed in the project library. Where there are differences #' it resolves them by installing the lockfile-recorded package into the #' project library. If `clean = TRUE`, `restore()` will additionally delete any #' packages in the project library that don't appear in the lockfile. #' +#' @section Transactional Restore: +#' +#' By default, `renv::restore()` will perform a 'transactional' restore, wherein the +#' project library is mutated only if all packages within the lockfile are successfully +#' restored. The intention here is to prevent the private library from entering +#' an inconsistent state, if some subset of packages were to install successfully +#' but some other subset of packages did not. `renv::restore(transactional = FALSE)` +#' can be useful if you're attempting to restore packages from a lockfile, but would +#' like to update or change certain packages piece-meal if they fail to install. +#' +#' The term 'transactional' here borrows from the parlance of a 'database transaction', +#' where the failure of any intermediate step implies that the whole transaction +#' will be rolled back, so that the state of the database before the transaction +#' was initiated can be preserved. See +#' for more details. +#' #' @inherit renv-params #' -#' @param library The library paths to be used during restore. See **Library** -#' for details. +#' @param library The library paths to be used during restore. #' #' @param packages A subset of packages recorded in the lockfile to restore. #' When `NULL` (the default), all packages available in the lockfile will be #' restored. Any required recursive dependencies of the requested packages #' will be restored as well. #' +#' @param transactional Whether or not to use a 'transactional' restore. +#' See **Transactional Restore** for more details. When `NULL` (the default), +#' the value of the `install.transactional` [`config`] option will be used. +#' #' @param exclude A subset of packages to be excluded during restore. This can #' be useful for when you'd like to restore all but a subset of packages from #' a lockfile. Note that if you attempt to exclude a package which is required @@ -24402,16 +26793,17 @@ the$restore_state <- NULL #' @export #' #' @example examples/examples-init.R -restore <- function(project = NULL, +restore <- function(project = NULL, ..., - library = NULL, - lockfile = NULL, - packages = NULL, - exclude = NULL, - rebuild = FALSE, - repos = NULL, - clean = FALSE, - prompt = interactive()) + library = NULL, + lockfile = NULL, + packages = NULL, + exclude = NULL, + rebuild = FALSE, + repos = NULL, + clean = FALSE, + transactional = NULL, + prompt = interactive()) { renv_consent_check() renv_scope_error_handler() @@ -24427,6 +26819,13 @@ restore <- function(project = NULL, libpaths <- renv_libpaths_resolve(library) lockfile <- lockfile %||% renv_lockfile_load(project = project, strict = TRUE) + # set up .renvignore defensively + renv_load_cache_renvignore(project = project) + + # set up transactional param + transactional <- transactional %||% config$install.transactional() + renv_scope_options(renv.config.install.transactional = transactional) + # check and ask user if they need to activate first renv_activate_prompt("restore", library, prompt, project) @@ -24439,12 +26838,19 @@ restore <- function(project = NULL, if (is.character(lockfile)) lockfile <- renv_lockfile_read(lockfile) - # inject overrides (if any) + # insert overrides (if any) lockfile <- renv_lockfile_override(lockfile) # repair potential issues in the lockfile lockfile <- renv_lockfile_repair(lockfile) + # check for system requirements from these packages + if (config$sysreqs.check(default = renv_platform_linux())) { + records <- renv_lockfile_records(lockfile) + sysreqs <- map(records, `[[`, "SystemRequirements") + renv_sysreqs_check(sysreqs, prompt = prompt) + } + # override repositories if requested repos <- repos %||% config$repos.override() %||% lockfile$R$Repositories @@ -24457,13 +26863,18 @@ restore <- function(project = NULL, # if users have requested the use of pak, delegate there if (config$pak.enabled() && !recursing()) { + renv_pak_init() - renv_pak_restore( + records <- renv_pak_restore( lockfile = lockfile, packages = packages, exclude = exclude, + prompt = prompt, project = project ) + + return(renv_restore_successful(records, prompt, project)) + } # set up Bioconductor version + repositories @@ -24487,11 +26898,11 @@ restore <- function(project = NULL, diff <- renv_vector_diff(diff, if (!clean) "remove") # only remove packages from the project library - is_package <- map_lgl(names(diff), function(package) { + ispkg <- map_lgl(names(diff), function(package) { path <- find.package(package, lib.loc = libpaths, quiet = TRUE) identical(dirname(path), library) }) - diff <- diff[!(diff == "remove" & !is_package)] + diff <- diff[!(diff == "remove" & !ispkg)] # don't take any actions with ignored packages ignored <- renv_project_ignored_packages(project = project) @@ -24507,6 +26918,11 @@ restore <- function(project = NULL, return(renv_restore_successful(diff, prompt, project)) } + # transform binary repository URLs into source repository URLs + current <- renv_restore_normalize(current) + lockfile <- renv_restore_normalize(lockfile) + + # TODO: should we avoid double-prompting here? # we prompt once here for the preflight check, and then again below based # on the actions we'll perform. @@ -24546,7 +26962,7 @@ renv_restore_run_actions <- function(project, actions, current, lockfile, rebuil packages <- names(installs) # perform the install - records <- retrieve(packages) + records <- renv_retrieve_impl(packages) renv_install_impl(records) # detect dependency tree repair @@ -24630,7 +27046,7 @@ renv_restore_begin <- function(project = NULL, retrieved = new.env(parent = emptyenv()), # packages which need to be installed - install = stack(), + install = mapping(), # a collection of the requirements imposed on dependent packages # as they are discovered @@ -24751,16 +27167,130 @@ renv_restore_successful <- function(records, prompt, project) { } +renv_restore_normalize <- function(lockfile) { + records <- renv_lockfile_records(lockfile) + renv_lockfile_records(lockfile) <- map(records, renv_restore_normalize_impl) + lockfile +} + +renv_restore_normalize_impl <- function(record) { + + # transform binary repository URLs into source URLs + if (config$ppm.enabled()) { + repository <- record[["Repository"]] %||% "" + if (nzchar(repository)) { + srcurl <- renv_ppm_normalize(repository) + binurl <- renv_ppm_transform(srcurl) + record[["Repository"]] <- binurl + } + } + + # apply override if set + override <- config$repos.override() + if (length(override)) { + record[["Repository"]] <- NULL + } + + # return potentially mutated record + record + +} + # retrieve.R ----------------------------------------------------------------- -the$repos_archive <- new.env(parent = emptyenv()) +#' Retrieve packages +#' +#' Retrieve (download) one or more packages from external sources. +#' Using `renv::retrieve()` can be useful in CI / CD workflows, where +#' you might want to download all packages listed in a lockfile +#' before later invoking [renv::restore()]. Packages will be downloaded +#' to an internal path within `renv`'s local state directories -- see +#' [paths] for more details. +#' +#' If `destdir` is `NULL` and the requested package is already available +#' within the `renv` cache, `renv` will return the path to that package +#' directory in the cache. +#' +#' @inheritParams renv-params +#' +#' @param lockfile The path to an `renv` lockfile. When set, `renv` +#' will retrieve the packages as defined within that lockfile. +#' If `packages` is also non-`NULL`, then only those packages will +#' be retrieved. +#' +#' @param destdir The directory where packages should be downloaded. +#' When `NULL` (the default), the default internal storage locations +#' (normally used by e.g. [renv::install()] or [renv::restore()]) will +#' be used. +#' +#' @returns A named vector, mapping package names to the paths where +#' those packages were downloaded. +#' +#' @export +#' +#' @examples +#' \dontrun{ +#' +#' # retrieve package + versions as defined in the lockfile +#' # normally used as a pre-flight step to renv::restore() +#' renv::retrieve() +#' +#' # download one or more packages locally +#' renv::retrieve("rlang", destdir = ".") +#' +#' } +retrieve <- function(packages = NULL, + ..., + lockfile = NULL, + destdir = NULL, + project = NULL) +{ + renv_consent_check() + renv_scope_error_handler() + renv_dots_check(...) + + project <- renv_project_resolve(project) + renv_project_lock(project = project) + + # set destdir if available + if (!is.null(destdir)) { + renv_scope_options(renv.config.cache.enabled = FALSE) + renv_scope_binding(the, "destdir", destdir) + } + + # figure out which records we want to retrieve + if (is.null(packages) && is.null(lockfile)) { + lockfile <- renv_lockfile_load(project = project) + records <- renv_lockfile_records(lockfile) + packages <- names(records) + } else if (is.null(lockfile)) { + records <- map(packages, renv_remotes_resolve, latest = TRUE) + packages <- map_chr(records, `[[`, "Package") + names(records) <- packages + } else if (is.character(lockfile)) { + lockfile <- renv_lockfile_read(lockfile) + records <- renv_lockfile_records(lockfile) + packages <- packages %||% names(records) + } + + # overlay project remotes + records <- overlay(renv_project_remotes(project), records) -# this routine retrieves a package + its dependencies, and as a side -# effect populates the restore state's `retrieved` member with a -# list of package records which can later be used for install -retrieve <- function(packages) { + # perform the retrieval + renv_scope_restore( + project = project, + library = library, + packages = packages, + records = records + ) + + result <- renv_retrieve_impl(packages) + map_chr(result, `[[`, "Path") +} + +renv_retrieve_impl <- function(packages) { # confirm that we have restore state set up state <- renv_restore_state() @@ -24787,7 +27317,7 @@ retrieve <- function(packages) { before <- Sys.time() handler <- state$handler for (package in packages) - handler(package, renv_retrieve_impl(package)) + handler(package, renv_retrieve_impl_one(package)) after <- Sys.time() state <- renv_restore_state() @@ -24798,13 +27328,11 @@ retrieve <- function(packages) { writef("") } - data <- state$install$data() - names(data) <- extract_chr(data, "Package") - data + state$install$data() } -renv_retrieve_impl <- function(package) { +renv_retrieve_impl_one <- function(package) { # skip packages with 'base' priority if (package %in% renv_packages_base()) @@ -24812,13 +27340,23 @@ renv_retrieve_impl <- function(package) { # if we've already attempted retrieval of this package, skip state <- renv_restore_state() - if (visited(package, envir = state$retrieved)) + if (!is.null(state$retrieved[[package]])) return() + # insert a dummy value just to avoid infinite recursions + # (this will get updated on a successful installation later) + state$retrieved[[package]] <- NA + # extract record for package records <- state$records record <- records[[package]] %||% renv_retrieve_resolve(package) + # resolve lazy records + if (is.function(record)) { + state$records[[package]] <- resolve(record) + record <- state$records[[package]] + } + # normalize the record source source <- renv_record_source(record, normalize = TRUE) @@ -24895,7 +27433,8 @@ renv_retrieve_impl <- function(package) { } - if (!renv_restore_rebuild_required(record)) { + rebuild <- renv_restore_rebuild_required(record) + if (!rebuild) { # if we have an installed package matching the requested record, finish early path <- renv_restore_find(package, record) @@ -24916,6 +27455,7 @@ renv_retrieve_impl <- function(package) { path <- renv_cache_find(record) if (nzchar(path) && renv_cache_package_validate(path)) return(renv_retrieve_successful(record, path)) + } } @@ -24951,22 +27491,21 @@ renv_retrieve_impl <- function(package) { } - if (!renv_restore_rebuild_required(record)) { - - # try some early shortcut methods - shortcuts <- c( - renv_retrieve_explicit, - renv_retrieve_cellar, - if (!renv_tests_running() && config$install.shortcuts()) - renv_retrieve_libpaths - ) - for (shortcut in shortcuts) { - retrieved <- catch(shortcut(record)) - if (identical(retrieved, TRUE)) - return(TRUE) - } + # try some early shortcut methods + shortcuts <- if (rebuild) c( + renv_retrieve_cellar + ) else c( + renv_retrieve_explicit, + renv_retrieve_cellar, + if (!renv_tests_running() && config$install.shortcuts()) + renv_retrieve_libpaths + ) + for (shortcut in shortcuts) { + retrieved <- catch(shortcut(record)) + if (identical(retrieved, TRUE)) + return(TRUE) } state$downloaded <- state$downloaded + 1L @@ -24999,10 +27538,14 @@ renv_retrieve_path <- function(record, type = "source", ext = NULL) { # extract relevant record information package <- record$Package name <- renv_retrieve_name(record, type, ext) - source <- renv_record_source(record) + + # if we have a destdir override, use this + if (!is.null(the$destdir)) + return(file.path(the$destdir, name)) # check for packages from an PPM binary URL, and # update the package type if known + source <- renv_record_source(record) if (renv_ppm_enabled()) { url <- attr(record, "url") if (is.character(url) && grepl("/__[^_]+__/", url)) @@ -25322,16 +27865,19 @@ renv_retrieve_repos <- function(record) { # if this record is tagged with a type + url, we can # use that directly for retrieval - if (all(c("type", "url") %in% names(attributes(record)))) + if (renv_record_tagged(record)) return(renv_retrieve_repos_impl(record)) # figure out what package sources are okay to use here pkgtype <- getOption("pkgType", default = "source") - srcok <- pkgtype %in% c("both", "source") || + srcok <- + pkgtype %in% c("both", "source") || getOption("install.packages.check.source", default = "yes") %in% "yes" - binok <- pkgtype %in% c("both") || grepl("binary", pkgtype, fixed = TRUE) + binok <- + pkgtype %in% c("both", "binary") || + grepl("binary", pkgtype, fixed = TRUE) # collect list of 'methods' for retrieval methods <- stack(mode = "list") @@ -25345,9 +27891,9 @@ renv_retrieve_repos <- function(record) { # also try fallback binary locations (for Nexus) methods$push(renv_retrieve_repos_binary_fallback) - # if MRAN is enabled, check those binaries as well - if (renv_mran_enabled()) - methods$push(renv_retrieve_repos_mran) + # if p3m is enabled, check those binaries as well + if (renv_p3m_enabled()) + methods$push(renv_retrieve_repos_p3m) } @@ -25362,7 +27908,7 @@ renv_retrieve_repos <- function(record) { # if this is a package from r-universe, try restoring from github # (currently inferred from presence for RemoteUrl field) - unifields <- c("RemoteUrl", "RemoteRef", "RemoteSha") + unifields <- c("RemoteUrl", "RemoteSha") if (all(unifields %in% names(record))) methods$push(renv_retrieve_git) else @@ -25401,12 +27947,13 @@ renv_retrieve_repos <- function(record) { # if we couldn't download the package, report the errors we saw local({ - renv_scope_options(warn = 1) + renv_scope_options(warn = 1L) for (error in errors$data()) warning(error) }) - stopf("failed to retrieve package '%s'", renv_record_format_remote(record)) + remote <- renv_record_format_remote(record, compact = TRUE) + stopf("failed to retrieve package '%s'", remote) } @@ -25426,7 +27973,7 @@ renv_retrieve_repos_error_report <- function(record, errors) { fmt <- "The following error(s) occurred while retrieving '%s':" preamble <- sprintf(fmt, record$Package) - caution_bullets( + bulletin( preamble = preamble, values = paste("-", messages) ) @@ -25436,18 +27983,26 @@ renv_retrieve_repos_error_report <- function(record, errors) { } -renv_retrieve_url <- function(record) { +renv_retrieve_url_resolve <- function(record) { - if (is.null(record$RemoteUrl)) { - fmt <- "package '%s' has no recorded RemoteUrl" - stopf(fmt, record$Package) + # https://github.com/rstudio/renv/issues/2060 + pkgref <- record$RemotePkgRef + if (!is.null(pkgref)) { + remote <- renv_remotes_parse(pkgref) + if (identical(remote$type, "url")) + return(remote$url) } - resolved <- renv_remotes_resolve_url(record$RemoteUrl, quiet = FALSE) - renv_retrieve_successful(record, resolved$Path) + record$RemoteUrl } +renv_retrieve_url <- function(record) { + url <- renv_retrieve_url_resolve(record) + resolved <- renv_remotes_resolve_url(url, quiet = FALSE) + renv_retrieve_successful(record, resolved$Path) +} + renv_retrieve_repos_archive_name <- function(record, type = "source") { file <- record$File @@ -25459,22 +28014,22 @@ renv_retrieve_repos_archive_name <- function(record, type = "source") { } -renv_retrieve_repos_mran <- function(record) { +renv_retrieve_repos_p3m <- function(record) { - # MRAN does not make binaries available on Linux + # TODO: support Linux if (renv_platform_linux()) return(FALSE) - # ensure local MRAN database is up-to-date - renv_mran_database_refresh(explicit = FALSE) + # ensure local database is up-to-date + renv_p3m_database_refresh(explicit = FALSE) # check that we have an available database - path <- renv_mran_database_path() + path <- renv_p3m_database_path() if (!file.exists(path)) return(FALSE) # attempt to read it - database <- catch(renv_mran_database_load()) + database <- catch(renv_p3m_database_load()) if (inherits(database, "error")) { warning(database) return(FALSE) @@ -25496,13 +28051,19 @@ renv_retrieve_repos_mran <- function(record) { date <- as.Date(idate, origin = "1970-01-01") # form url to binary package - base <- renv_mran_url(date, suffix) + base <- renv_p3m_url(date, suffix) name <- renv_retrieve_name(record, type = "binary") url <- file.path(base, name) # form path to saved file path <- renv_retrieve_path(record, "binary") + # tag record with repository name + record <- overlay(record, list( + Source = "Repository", + Repository = "P3M" + )) + # attempt to retrieve renv_retrieve_package(record, url, path) @@ -25548,16 +28109,37 @@ renv_retrieve_repos_source_fallback <- function(record, repo) { renv_retrieve_repos_archive <- function(record) { - for (repo in getOption("repos")) { + # get the current repositories + repos <- getOption("repos") + + # if this record has a repository recorded, use or prefer it + repository <- record[["Repository"]] + if (is.character(repository)) { + names(repository) <- names(repository) %||% repository + if (grepl("://", repository, fixed = TRUE)) { + repos <- c(repository, repos) + } else if (repository %in% names(repos)) { + matches <- names(repos) == repository + repos <- c(repos[matches], repos[!matches]) + } + } + + for (repo in repos) { # try to determine path to package in archive - url <- renv_retrieve_repos_archive_path(repo, record) - if (is.null(url)) + root <- renv_retrieve_repos_archive_root(repo, record) + if (is.null(root)) next - # attempt download + # attempt download; report errors via condition handler name <- renv_retrieve_repos_archive_name(record, type = "source") - status <- catch(renv_retrieve_repos_impl(record, "source", name, url)) + status <- catch(renv_retrieve_repos_impl(record, "source", name, root)) + if (inherits(status, "error")) { + attr(status, "record") <- record + renv_condition_signal("renv.retrieve.error", status) + } + + # exit now if we had success if (identical(status, TRUE)) return(TRUE) @@ -25567,7 +28149,7 @@ renv_retrieve_repos_archive <- function(record) { } -renv_retrieve_repos_archive_path <- function(repo, record) { +renv_retrieve_repos_archive_root <- function(url, record) { # allow users to provide a custom archive path for a record, # in case they're using a repository that happens to archive @@ -25575,50 +28157,66 @@ renv_retrieve_repos_archive_path <- function(repo, record) { # https://github.com/rstudio/renv/issues/602 override <- getOption("renv.retrieve.repos.archive.path") if (is.function(override)) { - result <- override(repo, record) + result <- override(url, record) if (!is.null(result)) return(result) } - # if we already know the format of the repository, use that - if (exists(repo, envir = the$repos_archive)) { - formatter <- get(repo, envir = the$repos_archive) - root <- formatter(repo, record) - return(root) - } + # retrieve the appropriate formatter for this repository url + formatter <- memoize( + key = url, + value = renv_retrieve_repos_archive_formatter(url) + ) + + # use it + formatter(url, record) + +} - # otherwise, try determining the archive paths with a couple - # custom locations, and cache the version that works for the - # associated repository +renv_retrieve_repos_archive_formatter <- function(url) { + + # list of known formatters formatters <- list( # default CRAN format - function(repo, record) { + cran = function(repo, record) { with(record, file.path(repo, "src/contrib/Archive", Package)) }, - # format used by Artifactory + # format used by older releases of Artifactory # https://github.com/rstudio/renv/issues/602 - function(repo, record) { + # https://github.com/rstudio/renv/issues/1996 + artifactory = function(repo, record) { with(record, file.path(repo, "src/contrib/Archive", Package, Version)) }, # format used by Nexus # https://github.com/rstudio/renv/issues/595 - function(repo, record) { + nexus = function(repo, record) { with(record, file.path(repo, "src/contrib")) } ) - name <- renv_retrieve_repos_archive_name(record, "source") - for (formatter in formatters) { - root <- formatter(repo, record) - url <- file.path(root, name) - if (renv_download_available(url)) { - assign(repo, formatter, envir = the$repos_archive) - return(root) - } + # check for an override + override <- getOption("renv.repos.formatters") + if (!is.null(override)) { + formatter <- formatters[[override[[url]] %||% ""]] + if (!is.null(formatter)) + return(formatter) + } + + # build URL to PACKAGES file in src/contrib + pkgurl <- file.path(url, "src/contrib/PACKAGES") + headers <- renv_download_headers(pkgurl) + + # use the headers to infer the repository type + if ("x-artifactory-id" %in% names(headers)) { + formatters[["cran"]] + } else if (grepl("Nexus", headers[["server"]] %||% "")) { + formatters[["nexus"]] + } else { + formatters[["cran"]] } } @@ -25713,13 +28311,20 @@ renv_retrieve_package <- function(record, url, path) { renv_retrieve_package_preamble <- function(record, url) { - message <- sprintf( - "- Downloading %s from %s ... ", - record$Package, - record$Repository %||% record$Source - ) + package <- record[["Package"]] + version <- record[["Version"]] + + source <- record[["Repository"]] %||% record[["Source"]] + if (identical(source, "Repository")) + source <- record[["RemoteReposName"]] + + parts <- c(package, version, if (length(source)) c("from", source)) + body <- paste(parts, collapse = " ") + + fmt <- "- Downloading %s ... " + msg <- sprintf(fmt, body) - format(message, width = the$install_step_width) + format(msg, width = the$install_step_width) } @@ -25774,26 +28379,34 @@ renv_retrieve_successful <- function(record, path, install = TRUE) { # update the record's package name, version # TODO: should we warn if they didn't match for some reason? - record$Package <- desc$Package + package <- record$Package <- desc$Package record$Version <- desc$Version # add in path information to record (used later during install) record$Path <- path - # record this package's requirements + # add information on the retrieved record state <- renv_restore_state() + state$retrieved[[package]] <- record + + # record this package's requirements requirements <- state$requirements # figure out the dependency fields to use -- if the user explicitly requested # this package be installed, but also provided a 'dependencies' argument in - # the call to 'install()', then we want to use those - fields <- if (record$Package %in% state$packages) the$install_dependency_fields else "strong" + # the call to 'install()', then we want to install those as well. + # + # however, those packages need to be installed at a lower priority, since it's + # common for there to be circular-ish dependency relationships, where one + # package A imports package B, but package B suggests package A in turn. + fields <- if (package %in% state$packages) the$install_dependency_fields else "strong" deps <- renv_dependencies_discover_description(path, subdir = subdir, fields = fields) if (length(deps$Source)) deps$Source <- record$Package + # set up package requirements for 'strong' dependencies rowapply(deps, function(dep) { - package <- dep$Package + package <- dep[["Package"]] requirements[[package]] <- requirements[[package]] %||% stack() requirements[[package]]$push(dep) }) @@ -25803,32 +28416,90 @@ renv_retrieve_successful <- function(record, path, install = TRUE) { if (length(remotes) && config$install.remotes()) renv_retrieve_remotes(remotes) - # ensure its dependencies are retrieved as well - if (state$recursive) local({ - repos <- if (is.null(desc$biocViews)) getOption("repos") else renv_bioconductor_repos() - renv_scope_options(repos = repos) - renv_retrieve_successful_recurse(deps) + # split into strong + weak dependencies + strong <- deps$Type %in% c("Depends", "Imports", "LinkingTo") + strongdeps <- rows(deps, strong) + weakdeps <- rows(deps, !strong) + + # recursively install strong dependencies first + if (state$recursive && nrow(strongdeps)) local({ + + # make sure bioconductor repositories are active before install if necessary + if (nzchar(desc[["biocViews"]] %||% "")) { + repos <- renv_bioconductor_repos() + renv_scope_options(repos = repos) + } + + # now recurse + renv_retrieve_successful_recurse(strongdeps) + }) # mark package as requiring install if needed - if (install) - state$install$push(record) + if (install && !state$install$contains(package)) + state$install$insert(package, record) + + # now recursively retrieve weak dependencies + if (state$recursive && nrow(weakdeps)) local({ + + # make sure bioconductor repositories are active before install if necessary + if (nzchar(desc[["biocViews"]] %||% "")) { + repos <- renv_bioconductor_repos() + renv_scope_options(repos = repos) + } + + # now recursive + renv_retrieve_successful_recurse(weakdeps) + + }) TRUE } renv_retrieve_successful_recurse <- function(deps) { - remotes <- unique(deps$Package) + remotes <- setdiff(unique(deps$Package), renv_packages_base()) for (remote in remotes) renv_retrieve_successful_recurse_impl(remote) } +renv_retrieve_successful_recurse_impl_check <- function(remote) { + + # only done for package names + if (!grepl(renv_regexps_package_name(), remote)) + return(FALSE) + + # check whether this package has been retrieved yet + state <- renv_restore_state() + record <- state$retrieved[[remote]] + if (is.null(record) || identical(record, NA)) + return(FALSE) + + # check the current requirements for this package + incompat <- renv_retrieve_incompatible(remote, record) + if (NROW(incompat) == 0L) + return(FALSE) + + # we have an incompatible record; ensure it gets retrieved + state$retrieved[[remote]] <- NULL + TRUE + +} + renv_retrieve_successful_recurse_impl <- function(remote) { + # if remote is a plain package name that we've already retrieved, + # we may need to retrieve it again if the version of that package + # required is greater than the previously-obtained version + # + # TODO: implement a proper solver so we can stop doing these hacks... + # if this is a 'plain' package remote, retrieve it + force <- renv_retrieve_successful_recurse_impl_check(remote) + dynamic( key = list(remote = remote), - value = renv_retrieve_successful_recurse_impl_one(remote) + value = renv_retrieve_successful_recurse_impl_one(remote), + force = force ) } @@ -25842,14 +28513,14 @@ renv_retrieve_successful_recurse_impl_one <- function(remote) { # if this is a 'plain' package remote, retrieve it if (grepl(renv_regexps_package_name(), remote)) { - renv_retrieve_impl(remote) + renv_retrieve_impl_one(remote) return(list()) } # otherwise, handle custom remotes record <- renv_retrieve_remotes_impl(remote) if (length(record)) { - renv_retrieve_impl(record$Package) + renv_retrieve_impl_one(record$Package) return(list()) } @@ -25919,7 +28590,7 @@ renv_retrieve_remotes_impl_one <- function(remote) { state$records[[package]] <- resolved # mark the record as needing retrieval - state$retrieved[[package]] <- FALSE + state$retrieved[[package]] <- NULL # return new record invisible(resolved) @@ -26021,7 +28692,7 @@ renv_retrieve_incompatible_report <- function(package, record, replacement, comp postamble <- with(replacement, sprintf(fmt, Package, Version)) if (!renv_tests_running()) { - caution_bullets( + bulletin( preamble = preamble, values = values, postamble = postamble @@ -26043,6 +28714,140 @@ renv_retrieve_origin <- function(host) { } +# revdeps.R ------------------------------------------------------------------ + + +renv_revdeps_check <- function(project = NULL) { + + project <- renv_project_resolve(project) + renv_scope_wd(project) + renv_scope_options(repos = c(renv_bioconductor_repos(project))) + + case( + + startsWith(R.version$platform, "aarch64-apple-darwin") ~ { + renv_scope_envvars( + CPPFLAGS = "-I/opt/homebrew/include", + LDFLAGS = "-L/opt/homebrew/lib", + LIBS = "-L/opt/homebrew/lib" + ) + } + + ) + + package <- renv_description_read("DESCRIPTION", field = "Package") + + renv_infrastructure_write_entry_impl( + add = "revdeps", + remove = character(), + file = file.path(project, ".gitignore"), + create = FALSE + ) + + blueprints <- list( + list(package = project, root = "revdeps/develop"), + list(package = package, root = "revdeps/current") + ) + + zmap(blueprints, function(package, root) { + writef(header("Installing %s [%s]", package, root)) + renv_revdeps_check_preflight(package, "revdeps/develop", project) + writef() + }) + + revdeps <- package_dependencies(package, reverse = TRUE)[[1L]] + result <- zmap(blueprints, function(package, root) { + map(revdeps, function(revdep) { + writef(header("Checking %s [%s]", revdep, root)) + result <- catch(renv_revdeps_check_impl(revdep, root, project)) + if (inherits(result, "error")) { + message <- paste("Error:", conditionMessage(result)) + writef(message, con = stderr()) + } + writef() + result + }) + }) + +} + +renv_revdeps_check_preflight <- function(package, root, project) { + + dir.create(root, recursive = TRUE, showWarnings = FALSE) + renv_scope_wd(root) + + dir.create("library.noindex", showWarnings = FALSE) + dir.create("results.noindex", showWarnings = FALSE) + dir.create("sources.noindex", showWarnings = FALSE) + dir.create("cache.noindex", showWarnings = FALSE) + + renv_scope_envvars(RENV_PATHS_CACHE = "cache.noindex") + renv_scope_libpaths("library.noindex") + + install(package, project = project) + + job(function() { + renv::install("BiocManager") + renv::install("bioc::BiocVersion") + }) + +} + +renv_revdeps_check_impl <- function(revdep, root, project) { + + ensure_directory(root) + root <- normalizePath(root, winslash = "/") + renv_scope_envvars(RENV_PATHS_SOURCE = file.path(root, "sources.noindex")) + renv_scope_envvars(RENV_PATHS_CACHE = file.path(root, "cache.noindex")) + renv_scope_libpaths(file.path(root, "library.noindex")) + + checkpath <- sprintf("%s/results.noindex/%s.Rcheck/00check.log", root, revdep) + if (file.exists(checkpath)) { + contents <- readLines(checkpath, warn = FALSE) + if (startsWith(tail(contents, 1L), "Status:")) { + writef("- Package was already checked; skipping") + return() + } + } + + record <- renv_remotes_resolve(revdep, latest = TRUE) + path <- renv_retrieve_path(record) + + job(function() { + + Sys.setenv(RENV_LOG_LEVEL = "error") + options(renv.cache.linkable = TRUE) + setwd(!!file.path(root, "results.noindex")) + + result <- install(!!revdep, type = "source", dependencies = "all") + system2(!!R(), c("CMD", "check", !!path)) + + }) + +} + +renv_revdeps_status <- function(packages, root) { + + develop <- map_chr(packages, function(package) { + + checkdir <- sprintf("revdeps/develop/results.noindex/%s.Rcheck", package) + + installfile <- file.path(checkdir, "00install.out") + if (!file.exists(installfile)) + return(list(failed = TRUE)) + + checkfile <- file.path(checkdir, "00check.log") + if (!file.exists(checkfile)) + return(list(failed = TRUE)) + + contents <- readLines(checkfile) + tail(contents, n = 1L) + + }) + +} + + # robocopy.R ----------------------------------------------------------------- @@ -26061,7 +28866,7 @@ renv_robocopy_exec <- function(source, target, flags = NULL) { command = "robocopy", args = c(flags, renv_shell_path(source), renv_shell_path(target)), action = "copying directory", - success = 0:8, + success = 0:7, quiet = TRUE ) @@ -26109,16 +28914,17 @@ renv_robocopy_move <- function(source, target) { #' #' @param repos The repositories to use when restoring packages installed #' from CRAN or a CRAN-like repository. By default, the repositories recorded -#' in the lockfile will be, ensuring that (e.g.) CRAN packages are +#' in the lockfile will be used, ensuring that (e.g.) CRAN packages are #' re-installed from the same CRAN mirror. #' #' Use `repos = getOption("repos")` to override with the repositories set #' in the current session, or see the `repos.override` option in [config] for #' an alternate way override. #' -#' @param profile The profile to be activated. When `NULL`, the default -#' profile is activated instead. See `vignette("profiles", package = "renv")` -#' for more information. +#' @param profile The profile to be activated. See +#' `vignette("profiles", package = "renv")` for more information. +#' When `NULL` (the default), the profile is not changed. Use +#' `profile = "default"` to revert to the default `renv` profile. #' #' @param dependencies A vector of DESCRIPTION field names that should be used #' for package dependency resolution. When `NULL` (the default), the value @@ -26126,6 +28932,24 @@ renv_robocopy_move <- function(source, target) { #' "strong", "most", and "all" are also supported. #' See [tools::package_dependencies()] for more details. #' +#' @param packages Either `NULL` (the default) to install all packages required +#' by the project, or a character vector of packages to install. renv +#' supports a subset of the remotes syntax used for package installation, +#' e.g: +#' +#' * `pkg`: install latest version of `pkg` from CRAN. +#' * `pkg@version`: install specified version of `pkg` from CRAN. +#' * `username/repo`: install package from GitHub +#' * `bioc::pkg`: install `pkg` from Bioconductor. +#' +#' See and the examples +#' below for more details. +#' +#' renv deviates from the remotes spec in one important way: subdirectories +#' are separated from the main repository specification with a `:`, not `/`. +#' So to install from the `subdir` subdirectory of GitHub package +#' `username/repo` you'd use `"username/repo:subdir`. +#' #' @return The project directory, invisibly. Note that this function is normally #' called for its side effects. #' @@ -26236,6 +29060,8 @@ renv_rtools_list <- function() { renv_rtools_registry(), + Sys.getenv("RTOOLS45_HOME", unset = file.path(drive, "rtools45")), + Sys.getenv("RTOOLS44_HOME", unset = file.path(drive, "rtools44")), Sys.getenv("RTOOLS43_HOME", unset = file.path(drive, "rtools43")), Sys.getenv("RTOOLS42_HOME", unset = file.path(drive, "rtools42")), Sys.getenv("RTOOLS40_HOME", unset = file.path(drive, "rtools40")), @@ -26304,7 +29130,9 @@ renv_rtools_compatible <- function(spec) { return(FALSE) ranges <- list( - "4.3" = c("4.3.0", "9.9.9"), + "4.5" = c("4.5.0", "9.9.9"), + "4.4" = c("4.4.0", "9.9.9"), + "4.3" = c("4.3.0", "4.4.0"), "4.2" = c("4.2.0", "4.3.0"), "4.0" = c("4.0.0", "4.2.0"), "3.5" = c("3.3.0", "4.0.0"), @@ -26350,20 +29178,21 @@ renv_rtools_envvars <- function(root) { renv_rtools_envvars_rtools40(root) else if (version < "4.3") renv_rtools_envvars_rtools42(root) - else + else if (version < "4.4") renv_rtools_envvars_rtools43(root) + else + renv_rtools_envvars_default(root) } renv_rtools_envvars_default <- function(root) { # add Rtools utilities to path - bin <- normalizePath(file.path(root, "bin"), mustWork = FALSE) + bin <- normalizePath(file.path(root, "usr/bin"), mustWork = FALSE) path <- paste(bin, Sys.getenv("PATH"), sep = .Platform$path.sep) - # set BINPREF (note: trailing slash is required) - # file.path drops trailing separators on Windows, so we use paste - binpref <- paste(renv_path_normalize(root), "mingw_$(WIN)/bin/", sep = "/") + # set BINPREF + binpref <- "" list(PATH = path, BINPREF = binpref) @@ -26429,14 +29258,23 @@ renv_rtools_envvars_rtools40 <- function(root) { #' #' @param name The name to associate with the job, for scripts run as a job. #' +#' @param args description A character vector of command line arguments to be +#' passed to the launched job. These parameters can be accessed via +#' `commandArgs(trailingOnly = FALSE)`. +#' #' @param project The path to the renv project. This project will be loaded #' before the requested script is executed. When `NULL` (the default), renv #' will automatically determine the project root for the associated script #' if possible. #' #' @export -run <- function(script, ..., job = NULL, name = NULL, project = NULL) { - +run <- function(script, + ..., + job = NULL, + name = NULL, + args = NULL, + project = NULL) +{ renv_scope_error_handler() renv_dots_check(...) @@ -26473,24 +29311,41 @@ run <- function(script, ..., job = NULL, name = NULL, project = NULL) { stopf("cannot run script as job: required versions of RStudio + rstudioapi not available") if (jobbable) - renv_run_job(script = script, name = name, project = project) + renv_run_job(script = script, name = name, args = args, project = project) else - renv_run_impl(script = script, name = name, project = project) - + renv_run_impl(script = script, name = name, args = args, project = project) } -renv_run_job <- function(script, name, project) { +renv_run_job <- function(script, name, args, project) { activate <- renv_paths_activate(project = project) - jobscript <- tempfile("renv-job-", fileext = ".R") + exprs <- expr({ + + # insert a shim for commandArg + local({ + + # unlock binding temporarily + base <- .BaseNamespaceEnv + base$unlockBinding("commandArgs", base) + on.exit(base$lockBinding("commandArgs", base), add = TRUE) + + # insert our shim + cargs <- commandArgs(trailingOnly = FALSE) + base$commandArgs <- function(trailingOnly = FALSE) { + result <- !!args + if (trailingOnly) result else union(cargs, result) + } + + }) + + # run the script + source(!!activate) + source(!!script) - exprs <- substitute(local({ - defer(unlink(jobscript)) - source(activate) - source(script) - }), list(activate = activate, script = script, jobscript = jobscript)) + }) code <- deparse(exprs) + jobscript <- tempfile("renv-job-", fileext = ".R") writeLines(code, con = jobscript) rstudioapi::jobRunScript( @@ -26501,9 +29356,12 @@ renv_run_job <- function(script, name, project) { } -renv_run_impl <- function(script, name, project) { +renv_run_impl <- function(script, name, args, project) { renv_scope_wd(project) - system2(R(), c("-s", "-f", renv_shell_path(script))) + system2(R(), c( + "-s", "-f", renv_shell_path(script), + if (length(args)) c("--args", args) + ), wait = FALSE) } @@ -26624,10 +29482,7 @@ renv_sandbox_activate_check <- function(libs) { envir <- globalenv() - danger <- - exists(".First", envir = envir, inherits = FALSE) && - identical(getOption("renv.autoloader.running"), TRUE) - + danger <- exists(".First", envir = envir, inherits = FALSE) && autoloading() if (!danger) return(FALSE) @@ -26658,9 +29513,9 @@ renv_sandbox_activate_check <- function(libs) { renv_sandbox_generate <- function(sandbox) { # make the library temporarily writable - lock <- getOption("renv.sandbox.locking_enabled", default = TRUE) + lockable <- renv_sandbox_lockable() - if (lock) { + if (lockable) { dlog("sandbox", "unlocking sandbox") renv_sandbox_unlock(sandbox) } @@ -26690,7 +29545,7 @@ renv_sandbox_generate <- function(sandbox) { Sys.setFileTime(sandbox, time = Sys.time()) # make the library unwritable again - if (lock) { + if (lockable) { dlog("sandbox", "locking sandbox") renv_sandbox_lock(sandbox) } @@ -26749,20 +29604,25 @@ renv_sandbox_path <- function(project = NULL) { renv_paths_sandbox(project = project) } +renv_sandbox_lockable <- function(sandbox = NULL) { + getOption("renv.sandbox.locking_enabled", default = TRUE) +} + renv_sandbox_lock <- function(sandbox = NULL, project = NULL) { sandbox <- sandbox %||% renv_sandbox_path(project = project) - Sys.chmod(sandbox, mode = "0555") + mode <- file.mode(sandbox) & "577" + Sys.chmod(sandbox, mode = mode) } renv_sandbox_locked <- function(sandbox = NULL, project = NULL) { sandbox <- sandbox %||% renv_sandbox_path(project = project) - mode <- suppressWarnings(file.mode(sandbox)) - mode == 365L # as.integer(as.octmode("0555")) + file.exists(sandbox) && file.access(sandbox, mode = 7L) != 0L } renv_sandbox_unlock <- function(sandbox = NULL, project = NULL) { sandbox <- sandbox %||% renv_sandbox_path(project = project) - Sys.chmod(sandbox, mode = "0755") + mode <- file.mode(sandbox) | "200" + Sys.chmod(sandbox, mode = mode) } #' The default library sandbox @@ -27083,15 +29943,22 @@ renv_scope_install_macos <- function(scope = parent.frame()) { # R CMD config, as this might fail otherwise if (once()) { if (!renv_xcode_available()) { + message("") message("- macOS is reporting that command line tools (CLT) are not installed.") message("- Run 'xcode-select --install' to install command line tools.") message("- Without CLT, attempts to install packages from sources may fail.") + message("") } } # get the current compiler args <- c("CMD", "config", "CC") - cc <- system2(R(), args, stdout = TRUE, stderr = TRUE) + cc <- renv_system_exec(command = R(), args = args, action = "executing R CMD config CC") + + # just in case + cc <- tail(cc, n = 1L) + if (is.null(cc) || !nzchar(cc)) + cc <- "clang" # check to see if we're using the system toolchain # (need to be careful since users might put e.g. ccache or other flags @@ -27744,10 +30611,10 @@ renv_settings_impl <- function(name, default, scalar, validate, coerce, update) #' #' ## `package.dependency.fields` #' -#' When explicitly installing a package with `install()`, what fields -#' should be used to determine that packages dependencies? The default -#' uses `Imports`, `Depends` and `LinkingTo` fields, but you also want -#' to install `Suggests` dependencies for a package, you can set this to +#' When installing a package with `install()`, what `DESCRIPTION` fields should +#' be used to determine that package's dependencies? The default uses +#' `c("Imports", "Depends", "LinkingTo")`, but if you also want to install +#' `Suggests` dependencies for a package, you can set this to #' `c("Imports", "Depends", "LinkingTo", "Suggests")`. #' #' ## `ppm.enabled` @@ -27781,6 +30648,13 @@ renv_settings_impl <- function(name, default, scalar, validate, coerce, update) #' The type of snapshot to perform by default. See [snapshot] for more #' details. #' +#' ## `snapshot.dev` +#' +#' Whether to include development dependencies by default when calling +#' `renv::snapshot()` or `renv::status()`. When `TRUE`, development +#' dependencies (e.g., packages listed in `Suggests` or development tools +#' like `devtools`) will be included. Defaults to `FALSE`. +#' #' ## `use.cache` #' #' Enable the renv package cache with this project. When active, renv will @@ -27800,8 +30674,8 @@ renv_settings_impl <- function(name, default, scalar, validate, coerce, update) #' ## `vcs.ignore.cellar` #' #' Set whether packages within a project-local package cellar are excluded -#' from version control. See `vignette("cellar", package = "renv")` for -#' more information. +#' from version control. See `vignette("package-sources", package = "renv")` +#' for more information. #' #' ## `vcs.ignore.library` #' @@ -27890,7 +30764,7 @@ settings <- list( scalar = TRUE, validate = is.logical, coerce = as.logical, - update = FALSE + update = NULL ), ppm.ignored.urls = renv_settings_impl( @@ -27920,6 +30794,15 @@ settings <- list( update = NULL ), + snapshot.dev = renv_settings_impl( + name = "snapshot.dev", + default = FALSE, + scalar = TRUE, + validate = is.logical, + coerce = as.logical, + update = NULL + ), + use.cache = renv_settings_impl( name = "use.cache", default = TRUE, @@ -27987,20 +30870,48 @@ renv_shell_path <- function(x) { the$shims <- new.env(parent = emptyenv()) +# determine whether we can safely handle a call to install.packages() +renv_shim_install_packages_compatible <- function(matched) { + + # check if the user has only specified arguments which we know how to handle + ok <- c("", "dependencies", "pkgs", "lib", "repos", "type") + unhandled <- setdiff(names(matched), ok) + if (length(unhandled) != 0L) + return(FALSE) + + # if 'repos' is explicitly NULL, assume this is a request for local install + if ("repos" %in% names(matched) && is.null(matched[["repos"]])) + return(FALSE) + + # ok, we can handle it + TRUE + +} + renv_shim_install_packages <- function(pkgs, ...) { # place Rtools on PATH renv_scope_rtools() - # currently we only handle the case where only 'pkgs' was specified - if (missing(pkgs) || nargs() != 1) { + # check for compatible calls + matched <- match.call(utils::install.packages) + if (!renv_shim_install_packages_compatible(matched)) { call <- sys.call() call[[1L]] <- quote(utils::install.packages) return(eval(call, envir = parent.frame())) } - # otherwise, we get to handle it - install(pkgs) + # otherwise, invoke our own installer + call <- sys.call() + call[[1L]] <- quote(renv::install) + + # fix up names + aliases <- list(lib = "library") + idx <- omit_if(match(names(aliases), names(call)), is.na) + names(call)[idx] <- aliases[idx] + + # evaluate call + eval(call, envir = parent.frame()) } @@ -28118,6 +31029,9 @@ renv_snapshot_auto_impl <- function(project) { renv.verbose = FALSE ) + # file.info() can warn in some cases; silence those + renv_scope_options(warn = -1L) + # get current lockfile state lockfile <- renv_paths_lockfile(project) old <- file.info(lockfile, extra_cols = FALSE)$mtime @@ -28127,7 +31041,7 @@ renv_snapshot_auto_impl <- function(project) { # check for change in lockfile new <- file.info(lockfile, extra_cols = FALSE)$mtime - old != new + !identical(old, new) } @@ -28206,8 +31120,8 @@ renv_snapshot_task <- function() { if (the$auto_snapshot_failed) return(FALSE) - # treat warnings as errors in this scope - renv_scope_options(warn = 2L) + # silence warnings in this scope + renv_scope_options(warn = -1L) # attempt automatic snapshot, but disable on failure tryCatch( @@ -28234,7 +31148,11 @@ renv_snapshot_task_impl <- function() { return(invisible(FALSE)) # library has updated; perform auto snapshot - renv_snapshot_auto(project = project) + status <- renv_snapshot_auto(project = project) + ok <- identical(status, TRUE) + + # return invisibly for snapshot tests + invisible(ok) } @@ -28255,10 +31173,6 @@ renv_snapshot_auto_suppress_next <- function() { # snapshot.R ----------------------------------------------------------------- -# controls whether hashes are computed when computing a snapshot -# can be scoped to FALSE when hashing is not necessary -the$auto_snapshot_hash <- TRUE - #' Record current state of the project library in the lockfile #' #' @description @@ -28272,12 +31186,12 @@ the$auto_snapshot_hash <- TRUE #' providing lightweight portability and reproducibility without isolation. #' #' If you want to automatically snapshot after each change, you can -#' set `config$config$auto.snapshot(TRUE)`, see `?config` for more details. +#' set `config$config$auto.snapshot(TRUE)` -- see `?config` for more details. #' #' # Snapshot types #' -#' Depending on how you prefer to manage dependencies, you might prefer -#' selecting a different snapshot mode. The modes available are as follows: +#' Depending on how you prefer to manage your \R package dependencies, you may +#' want to enable an alternate snapshot type.. The types available are as follows: #' #' \describe{ #' @@ -28294,7 +31208,10 @@ the$auto_snapshot_hash <- TRUE #' \item{`"explicit"`}{ #' Only capture packages which are explicitly listed in the project #' `DESCRIPTION` file. This workflow is recommended for users who wish to -#' manage their project's \R package dependencies directly. +#' manage their project's \R package dependencies directly, and can be used +#' for both package and non-package \R projects. Packages used in this manner +#' should be recorded in either the `Depends` or `Imports` field of the +#' `DESCRIPTION` file. #' } #' #' \item{`"all"`}{ @@ -28336,12 +31253,12 @@ the$auto_snapshot_hash <- TRUE #' directly instead. #' #' @param type The type of snapshot to perform: -#' * `"implict"`, (the default), uses all packages captured by [dependencies()]. +#' * `"implicit"`, (the default), uses all packages captured by [dependencies()]. #' * `"explicit"` uses packages recorded in `DESCRIPTION`. #' * `"all"` uses all packages in the project library. #' * `"custom"` uses a custom filter. #' -#' See **Snapshot type** below for more details. +#' See **Snapshot types** below for more details. #' #' @inheritParams dependencies #' @@ -28367,7 +31284,7 @@ the$auto_snapshot_hash <- TRUE #' validation checks have failed? #' #' @param reprex Boolean; generate output appropriate for embedding the lockfile -#' as part of a [reprex](https://www.tidyverse.org/help/#reprex)? +#' as part of a [reprex](https://tidyverse.org/help/#reprex)? #' #' @return The generated lockfile, as an \R object (invisibly). Note that #' this function is normally called for its side effects. @@ -28384,7 +31301,7 @@ snapshot <- function(project = NULL, library = NULL, lockfile = paths$lockfile(project = project), type = settings$snapshot.type(project = project), - dev = FALSE, + dev = NULL, repos = getOption("repos"), packages = NULL, exclude = NULL, @@ -28403,9 +31320,16 @@ snapshot <- function(project = NULL, renv_project_lock(project = project) renv_scope_verbose_if(prompt) + # use setting as default if dev not explicitly provided + if (is.null(dev)) + dev <- settings$snapshot.dev(project = project) + repos <- renv_repos_validate(repos) renv_scope_options(repos = repos) + # set up .renvignore defensively + renv_load_cache_renvignore(project = project) + if (!is.null(lockfile)) renv_activate_prompt("snapshot", library, prompt, project) @@ -28450,12 +31374,18 @@ snapshot <- function(project = NULL, valid <- renv_snapshot_validate(project, new, libpaths) renv_snapshot_validate_report(valid, prompt, force) - # get prior lockfile state - old <- list() - if (file.exists(lockfile)) { + # get prior lockfile state; be robust against invalid lockfiles + old <- tryCatch( + if (file.exists(lockfile)) renv_lockfile_read(lockfile), + error = function(cnd) { + extra <- "The report below will omit lockfile package versions." + message <- paste(conditionMessage(cnd), extra, sep = "\n") + warning(message, call. = FALSE) + list() + } + ) - # read a pre-existing lockfile (if any) - old <- renv_lockfile_read(lockfile) + if (length(old)) { # preserve records from alternate OSes in lockfile alt <- renv_snapshot_preserve(old, new) @@ -28590,6 +31520,12 @@ renv_snapshot_validate_report <- function(valid, prompt, force) { return(TRUE) } + # if we were called during init, ignore failures + if (the$init_running) { + dlog("snapshot", "called during init; ignoring error in pre-flight validation checks") + return(TRUE) + } + # in interactive sessions, if 'prompt' is set, then ask the user # if they would like to proceed if (interactive() && !testing() && prompt) { @@ -28668,7 +31604,7 @@ renv_snapshot_validate_bioconductor <- function(project, lockfile, libpaths) { fmt <- "%s [installed %s != latest %s]" msg <- sprintf(fmt, format(bad$Package), format(bad$Version), bad$Latest) - caution_bullets( + bulletin( "The following Bioconductor packages appear to be from a separate Bioconductor release:", msg, c( @@ -28726,7 +31662,7 @@ renv_snapshot_validate_dependencies_available <- function(project, lockfile, lib }) - caution_bullets( + bulletin( "The following required packages are not installed:", sprintf("%s [required by %s]", format(missing), usedby), "Consider reinstalling these packages before snapshotting the lockfile." @@ -28790,7 +31726,7 @@ renv_snapshot_validate_dependencies_compatible <- function(project, lockfile, li fmt <- "%s requires %s, but version %s is installed" txt <- sprintf(fmt, format(package), format(requires), format(request)) - caution_bullets( + bulletin( "The following package(s) have unsatisfied dependencies:", txt, "Consider updating the required dependencies as appropriate." @@ -28850,7 +31786,7 @@ renv_snapshot_library <- function(library = NULL, paths <- paths[grep(pattern, basename(paths))] # validate the remaining set of packages - valid <- renv_snapshot_library_diagnose(library, paths) + valid <- renv_snapshot_check(paths) # remove duplicates (so only first package entry discovered in library wins) duplicated <- duplicated(basename(valid)) @@ -28871,7 +31807,7 @@ renv_snapshot_library <- function(library = NULL, messages <- map_chr(broken, conditionMessage) text <- sprintf("'%s': %s", names(broken), messages) - caution_bullets( + bulletin( "renv was unable to snapshot the following packages:", text, "These packages will likely need to be repaired and / or reinstalled." @@ -28887,23 +31823,23 @@ renv_snapshot_library <- function(library = NULL, } -renv_snapshot_library_diagnose <- function(library, paths) { +renv_snapshot_check <- function(paths) { paths <- grep("00LOCK", paths, invert = TRUE, value = TRUE) - paths <- renv_snapshot_library_diagnose_broken_link(library, paths) - paths <- renv_snapshot_library_diagnose_tempfile(library, paths) - paths <- renv_snapshot_library_diagnose_missing_description(library, paths) + paths <- renv_snapshot_check_broken_link(paths) + paths <- renv_snapshot_check_tempfile(paths) + paths <- renv_snapshot_check_missing_description(paths) paths } -renv_snapshot_library_diagnose_broken_link <- function(library, paths) { +renv_snapshot_check_broken_link <- function(paths) { broken <- !file.exists(paths) if (!any(broken)) return(paths) - caution_bullets( + bulletin( "The following package(s) have broken symlinks into the cache:", basename(paths)[broken], "Use `renv::repair()` to try and reinstall these packages." @@ -28913,14 +31849,14 @@ renv_snapshot_library_diagnose_broken_link <- function(library, paths) { } -renv_snapshot_library_diagnose_tempfile <- function(library, paths) { +renv_snapshot_check_tempfile <- function(paths) { names <- basename(paths) missing <- grepl("^file(?:\\w){12}", names) if (!any(missing)) return(paths) - caution_bullets( + bulletin( "The following folder(s) appear to be left-over temporary directories:", map_chr(paths[missing], renv_path_pretty), "Consider removing these folders from your R library." @@ -28930,14 +31866,14 @@ renv_snapshot_library_diagnose_tempfile <- function(library, paths) { } -renv_snapshot_library_diagnose_missing_description <- function(library, paths) { +renv_snapshot_check_missing_description <- function(paths) { desc <- file.path(paths, "DESCRIPTION") missing <- !file.exists(desc) if (!any(missing)) return(paths) - caution_bullets( + bulletin( "The following package(s) are missing their DESCRIPTION files:", sprintf("%s [%s]", format(basename(paths[missing])), paths[missing]), c( @@ -28953,11 +31889,9 @@ renv_snapshot_library_diagnose_missing_description <- function(library, paths) { renv_snapshot_description <- function(path = NULL, package = NULL) { # resolve path - path <- path %||% { - path <- renv_package_find(package) - if (!nzchar(path)) - stopf("package '%s' is not installed", package) - } + path <- path %||% renv_package_find(package, lib.loc = renv_libpaths_all()) + if (!nzchar(path)) + stopf("package '%s' is not installed", package) # read and snapshot DESCRIPTION file dcf <- renv_description_read(path, package) @@ -28967,6 +31901,21 @@ renv_snapshot_description <- function(path = NULL, package = NULL) { renv_snapshot_description_impl <- function(dcf, path = NULL) { + version <- + getOption("renv.lockfile.version") %||% + Sys.getenv("RENV_LOCKFILE_VERSION", unset = 2L) + + if (version == 1L) + renv_snapshot_description_impl_v1(dcf, path) + else if (version == 2L) + renv_snapshot_description_impl_v2(dcf, path) + else + stopf("unsupported lockfile version '%s'", format(version)) + +} + +renv_snapshot_description_impl_v1 <- function(dcf, path = NULL) { + # figure out the package source source <- renv_snapshot_description_source(dcf) dcf[names(source)] <- source @@ -28979,14 +31928,23 @@ renv_snapshot_description_impl <- function(dcf, path = NULL) { stopf(fmt, paste(shQuote(missing), collapse = ", "), path %||% "") } - # generate a hash if we can - dcf[["Hash"]] <- if (the$auto_snapshot_hash) { - if (is.null(path)) - renv_hash_description_impl(dcf) - else - renv_hash_description(path) + # if this is a standard remote for a bioconductor package, + # remove the other remote fields + bioc <- + nzchar(dcf[["biocViews"]] %||% "") && + identical(dcf[["RemoteType"]], "standard") + + if (bioc) { + fields <- grep("^Remote(?!s)", names(dcf), perl = TRUE, invert = TRUE) + dcf <- dcf[fields] } + # generate a hash if we can + dcf[["Hash"]] <- if (is.null(path)) + renv_hash_record(dcf) + else + renv_hash_description(path) + # generate a Requirements field -- primarily for use by 'pak' fields <- c("Depends", "Imports", "LinkingTo") deps <- bind(map(dcf[fields], renv_description_parse_field)) @@ -28994,20 +31952,33 @@ renv_snapshot_description_impl <- function(dcf, path = NULL) { dcf[["Requirements"]] <- all # get remotes fields - git <- grep("^git", names(dcf), value = TRUE) - remotes <- grep("^Remote", names(dcf), value = TRUE) + remotes <- local({ + + # if this seems to be a cran-like record, only keep remotes + # when RemoteSha appears to be a hash (e.g. for r-universe) + # note that RemoteSha may be a package version when installed + # by e.g. pak + if (renv_record_cranlike(dcf)) { + sha <- dcf[["RemoteSha"]] + if (is.null(sha) || nchar(sha) < 40L) + return(character()) + } - is_repo <- - is.null(dcf[["RemoteType"]]) || - identical(dcf[["RemoteType"]], "standard") + # grab the relevant remotes + git <- grep("^git", names(dcf), value = TRUE) + remotes <- grep("^Remote(?!s)", names(dcf), perl = TRUE, value = TRUE) + + # don't include 'RemoteRef' if it's a non-informative remote + if (identical(dcf[["RemoteRef"]], "HEAD")) + remotes <- setdiff(remotes, "RemoteRef") + + c(git, remotes) + + }) # only keep relevant fields extra <- c("Repository", "OS_type") - all <- c( - required, extra, - if (!is_repo) c(remotes, git), - "Requirements", "Hash" - ) + all <- c(required, extra, remotes, "Requirements", "Hash") keep <- renv_vector_intersect(all, names(dcf)) # return as list @@ -29015,24 +31986,136 @@ renv_snapshot_description_impl <- function(dcf, path = NULL) { } -renv_snapshot_description_source <- function(dcf) { +renv_snapshot_description_impl_v2 <- function(dcf, path) { + + # figure out the package source + source <- renv_snapshot_description_source(dcf) + dcf[names(source)] <- source + + # check for required fields + required <- c("Package", "Version", "Source") + missing <- renv_vector_diff(required, names(dcf)) + if (length(missing)) { + fmt <- "required fields %s missing from DESCRIPTION at path '%s'" + stopf(fmt, paste(shQuote(missing), collapse = ", "), path %||% "") + } - # first, check for a declared remote type - # treat 'standard' remotes as packages installed from a repository - # https://github.com/rstudio/renv/issues/998 - type <- dcf[["RemoteType"]] + # if this is a standard remote for a bioconductor package, + # remove the other remote fields + bioc <- + nzchar(dcf[["biocViews"]] %||% "") && + identical(dcf[["RemoteType"]], "standard") + + if (bioc) { + fields <- grep("^Remote(?!s)", names(dcf), perl = TRUE, invert = TRUE) + dcf <- dcf[fields] + } + + # drop fields that normally only appear in binary packages, + # or fields which might differ from user to user, or might + # differ depending on the mirror used for publication + ignore <- c("Archs", "Built", "Date/Publication", "File", "MD5sum", "Packaged") + dcf[ignore] <- NULL + + # drop remote fields for cranlike remotes + if (renv_record_cranlike(dcf)) { + sha <- dcf[["RemoteSha"]] + if (is.null(sha) || nchar(sha) < 40L) { + remotes <- grep("^Remote", names(dcf), perl = TRUE, value = TRUE) + dcf[remotes] <- NULL + } + } + + # drop the old Github remote fields + github <- grepl("^Github", names(dcf), perl = TRUE) + dcf <- dcf[!github] + + # split fields which are normally declared as lists of packages + depfields <- c("Depends", "Imports", "Suggests", "LinkingTo", "Enhances") + for (depfield in depfields) { + if (!is.null(dcf[[depfield]])) { + fields <- strsplit(dcf[[depfield]], ",", fixed = TRUE) + dcf[[depfield]] <- as.list(trimws(fields[[1L]])) + } + } + + # reorganize fields a bit + dcf <- dcf[c(required, setdiff(names(dcf), required))] + + # return as list + as.list(dcf) + +} + +renv_snapshot_description_source_custom <- function(dcf) { + + # only proceed for cranlike remotes + if (!renv_record_cranlike(dcf)) + return(NULL) + + # check for a declared repository URL + remoterepos <- dcf[["RemoteRepos"]] + if (is.null(remoterepos)) + return(NULL) + + # if this package appears to be installed from Bioconductor, skip + if (nzchar(dcf[["biocViews"]] %||% "")) + return(NULL) + + # if the declared repository appears to be a CRAN mirror, skip it + mirrors <- renv_cran_mirrors() + if (any(renv_repos_matches(remoterepos, mirrors))) + return(NULL) + + # if this package appears to have been installed from a + # repository which we have knowledge of, skip + repos <- as.list(getOption("repos")) repository <- dcf[["Repository"]] - if (identical(type, "standard") && !is.null(repository)) - return(list(Source = "Repository", Repository = repository)) - else if (!is.null(type)) + if (!is.null(repository) && repository %in% names(repos)) + return(NULL) + + # check whether the declared repository matches one of the + # repositories that are currently in use; if so, skip it + # + # we explicitly ignore 'CRAN' as a repository name here, since older + # versions of renv may have erroneously marked packages installed from + # other package repositories as 'CRAN' + # + # https://github.com/rstudio/renv/issues/2104 + name <- dcf[["RemoteReposName"]] + declared <- if (is.null(name) || identical(name, "CRAN")) + renv_repos_matches(remoterepos, repos) + else + name %in% names(repos) + + if (declared) + return(NULL) + + list(Source = "Repository", Repository = remoterepos) + +} + +renv_snapshot_description_source <- function(dcf) { + + # check for packages installed from a repository not currently + # encoded as part of the user's repository option, and include if required + source <- renv_snapshot_description_source_custom(dcf) + if (!is.null(source)) + return(source) + + # check for a custom declared remote type + if (!renv_record_cranlike(dcf)) { + type <- dcf[["RemoteType"]] %||% "standard" return(list(Source = alias(type))) + } # packages from Bioconductor are normally tagged with a 'biocViews' entry; # use that to infer a Bioconductor source - if (!is.null(dcf[["biocViews"]])) + if (nzchar(dcf[["biocViews"]] %||% "")) return(list(Source = "Bioconductor")) # check for a declared repository + repository <- dcf[["RemoteReposName"]] %||% dcf[["Repository"]] if (!is.null(repository)) return(list(Source = "Repository", Repository = repository)) @@ -29046,6 +32129,23 @@ renv_snapshot_description_source <- function(dcf) { if (the$project_synchronized_check_running) return(list(Source = "unknown")) + # check to see if this is a base / recommended package; if so, assume that + # the package was installed from CRAN at this point + # + # normally these would be caught by the 'Repository' check above, but it + # seems like, in some cases, base / recommended packages might be installed + # without those available + # + # https://github.com/rstudio/renv/issues/1948#issuecomment-2245134768 + pkgs <- installed_packages( + lib.loc = c(.Library, .Library.site), + priority = c("base", "recommended"), + field = "Package" + ) + + if (package %in% pkgs) + return(list(Source = "Repository", Repository = "CRAN")) + # NOTE: this is sort of a hack that allows renv to declare packages which # appear to be installed from sources, but are actually available on the # active R package repositories, as though they were retrieved from that @@ -29113,7 +32213,8 @@ renv_snapshot_report_actions <- function(actions, old, new) { if (rdiff != 0L) { n <- max(nchar(names(actions)), 0) fmt <- paste("-", format("R", width = n), " ", "[%s -> %s]") - msg <- sprintf(fmt, oldr %||% "*", newr %||% "*") + placeholder <- renv_record_placeholder() + msg <- sprintf(fmt, oldr %||% placeholder, newr %||% placeholder) writef( c("The version of R recorded in the lockfile will be updated:", msg, "") ) @@ -29162,6 +32263,13 @@ renv_snapshot_dependencies_impl <- function(project, type = NULL, dev = FALSE) { } ) + # avoid errors when the project directory, or DESCRIPTION file, + # does not exist (imply no dependencies) + # + # https://github.com/rstudio/renv/issues/1949 + if (!file.exists(path)) + return(character()) + # count the number of files in each directory, so we can report # to the user if we scanned a folder containing many files count <- integer() @@ -29258,17 +32366,13 @@ renv_snapshot_packages <- function(packages, libpaths, project) { ) # keep only packages with known locations - paths <- convert(filter(paths, is.character), "character") + paths <- paths %>% filter(is.character) %>% filter(nzchar) # diagnose issues with the scanned packages - paths <- uapply(libpaths, function(library) { - renv_snapshot_library_diagnose( - library = library, - paths = filter(paths, startswith, prefix = library)) - }) + paths <- renv_snapshot_check(paths) # now, snapshot the remaining packages - records <- map(paths, renv_snapshot_description) + map(paths, renv_snapshot_description) } @@ -29288,7 +32392,7 @@ renv_snapshot_report_missing <- function(missing, type) { "Use `renv::dependencies()` to see where this package is used in your project." ) - caution_bullets( + bulletin( preamble = preamble, values = sort(unique(missing)), postamble = postamble @@ -29310,7 +32414,7 @@ renv_snapshot_report_missing <- function(missing, type) { if (choice == "snapshot") { # do nothing } else if (choice == "install") { - install(missing, prompt = FALSE) + install(include = missing, prompt = FALSE) invokeRestart(restart) } else { cancel() @@ -29535,7 +32639,7 @@ the$status_running <- FALSE #' @description #' `renv::status()` reports issues caused by inconsistencies across the project #' lockfile, library, and [dependencies()]. In general, you should strive to -#' ensure that `status()` reports no issues, as this maximises your chances of +#' ensure that `status()` reports no issues, as this maximizes your chances of #' successfully `restore()`ing the project in the future or on another machine. #' #' `renv::load()` will report if any issues are detected when starting an @@ -29601,6 +32705,23 @@ the$status_running <- FALSE #' `renv::snapshot()`. If you want to rollback to an earlier known good #' status, see [renv::history()] and [renv::revert()]. #' +#' # Different R Version +#' +#' renv will also notify you if the version of R used when the lockfile was +#' generated, and the version of R currently in use, do not match. In this +#' scenario, you'll need to consider: +#' +#' - Is the version of R recorded in the lockfile correct? If so, you'll want +#' to ensure that version of R is installed and used when working in this +#' project. +#' +#' - Otherwise, you can call `renv::snapshot()` to update the version of R +#' recorded in the lockfile, to match the version of R currently in use. +#' +#' If you'd like to set the version of R recorded in a lockfile independently +#' of the version of R currently in use, you can set the `r.version` project +#' setting -- see [settings] for more details. +#' #' @inherit renv-params #' #' @param library The library paths. By default, the library paths associated @@ -29633,7 +32754,7 @@ status <- function(project = NULL, lockfile = NULL, sources = TRUE, cache = FALSE, - dev = FALSE) + dev = NULL) { renv_scope_error_handler() renv_dots_check(...) @@ -29647,6 +32768,10 @@ status <- function(project = NULL, project <- renv_project_resolve(project) renv_project_lock(project = project) + # use setting as default if dev not explicitly provided + if (is.null(dev)) + dev <- settings$snapshot.dev(project = project) + # check to see if we've initialized this project if (!renv_status_check_initialized(project, library, lockfile)) { result <- list( @@ -29688,12 +32813,14 @@ status <- function(project = NULL, ) packages <- setdiff(packages, ignored) - renv_lockfile_records(lockfile) <- exclude(renv_lockfile_records(lockfile), ignored) - renv_lockfile_records(library) <- exclude(renv_lockfile_records(library), ignored) + renv_lockfile_records(lockfile) <- omit(renv_lockfile_records(lockfile), ignored) + renv_lockfile_records(library) <- omit(renv_lockfile_records(library), ignored) - synchronized <- - renv_status_check_consistent(lockfile, library, packages) && - renv_status_check_synchronized(lockfile, library) + synchronized <- all( + renv_status_check_consistent(lockfile, library, packages), + renv_status_check_synchronized(lockfile, library), + renv_status_check_version(lockfile) + ) if (sources) { synchronized <- synchronized && @@ -29706,7 +32833,7 @@ status <- function(project = NULL, if (synchronized) writef("No issues found -- the project is in a consistent state.") else - writef(c("", "See ?renv::status() for advice on resolving these issues.")) + writef("See `?renv::status` for advice on resolving these issues.") result <- list( library = library, @@ -29729,43 +32856,78 @@ renv_status_check_consistent <- function(lockfile, library, used) { packages <- sort(unique(c(names(library), names(lockfile), used))) - status <- data.frame( - package = packages, + status <- data_frame( + package = packages, installed = packages %in% names(library), - recorded = packages %in% names(lockfile), - used = packages %in% used + recorded = packages %in% names(lockfile), + used = packages %in% used ) ok <- status$installed & (status$used == status$recorded) if (all(ok)) return(TRUE) - if (renv_verbose()) { - # If any packages are not installed, we don't know for sure what's used - # because our dependency graph is incomplete - issues <- status[!ok, , drop = FALSE] - missing <- !issues$installed - issues$installed <- ifelse(issues$installed, "y", "n") - issues$recorded <- ifelse(issues$recorded, "y", "n") - issues$used <- ifelse(issues$used, "y", if (any(missing)) "?" else "n") - - if (any(missing)) { - msg <- "The following package(s) are missing:" - issues <- issues[missing, ] - } else { - msg <- "The following package(s) are in an inconsistent state:" - } - writef(msg) - writef() - print(issues, row.names = FALSE, right = FALSE) + if (!renv_verbose()) + return(FALSE) + + issues <- status[!ok, , drop = FALSE] + missing <- issues$used & !issues$installed + if (all(missing)) { + + bulletin( + preamble = "The following package(s) are used in this project, but are not installed:", + values = issues$package[missing] + ) + + return(FALSE) + } + issues$installed <- ifelse(issues$installed, "y", "n") + issues$recorded <- ifelse(issues$recorded, "y", "n") + issues$used <- ifelse(issues$used, "y", if (any(missing)) "?" else "n") + + preamble <- "The following package(s) are in an inconsistent state:" + + writef(preamble) + writef() + print(issues, row.names = FALSE, right = FALSE) + writef() + FALSE } +renv_status_check_enabled <- function(parent) { + + # get the name of the calling function + ok <- is.call(parent) && length(parent) && is.symbol(parent[[1L]]) + if (!ok) + return(TRUE) + + invoker <- as.character(parent[[1L]]) + parts <- strsplit(invoker, "_", fixed = TRUE)[[1L]] + if (length(parts) < 3L) + return(TRUE) + + # check the relevant config option + scope <- parts[[2L]] + name <- paste(tail(parts, n = -2L), collapse = "_") + value <- renv_config_get( + name = name, + scope = scope, + default = TRUE + ) + + truthy(value, default = TRUE) + +} + renv_status_check_initialized <- function(project, library = NULL, lockfile = NULL) { + if (!renv_status_check_enabled(sys.call())) + return(TRUE) + # only done if library and lockfile are NULL; that is, if the user # is calling `renv::status()` without arguments if (!is.null(library) || !is.null(lockfile)) @@ -29807,27 +32969,50 @@ renv_status_check_initialized <- function(project, library = NULL, lockfile = NU renv_status_check_synchronized <- function(lockfile, library) { + if (!renv_status_check_enabled(sys.call())) + return(TRUE) + lockfile <- renv_lockfile_records(lockfile) library <- renv_lockfile_records(library) actions <- renv_lockfile_diff_packages(lockfile, library) rest <- c("upgrade", "downgrade", "crossgrade") - if (all(!rest %in% actions)) { + if (all(!rest %in% actions)) return(TRUE) - } pkgs <- names(actions[actions %in% rest]) + formatter <- function(lhs, rhs) + renv_record_format_pair(lhs, rhs, separator = "!=") + renv_pretty_print_records_pair( - preamble = "The following package(s) are out of sync [lockfile -> library]:", - lockfile[pkgs], - library[pkgs], + preamble = "The following package(s) are out of sync [lockfile != library]:", + old = lockfile[pkgs], + new = library[pkgs], + formatter = formatter ) FALSE } +renv_status_check_version <- function(lockfile) { + + if (!renv_status_check_enabled(sys.call())) + return(TRUE) + + version <- lockfile$R$Version + if (renv_version_eq(version, getRversion(), n = 2L)) + return(TRUE) + + fmt <- "The lockfile was generated with R %s, but you're using R %s." + writef(fmt, version, getRversion()) + writef() + + FALSE + +} + renv_status_check_cache <- function(project) { if (renv_cache_config_enabled(project = project)) @@ -29837,6 +33022,461 @@ renv_status_check_cache <- function(project) { +# sysreqs.R ------------------------------------------------------------------ + + +the$sysreqs <- NULL + +#' R System Requirements +#' +#' Compute the system requirements (system libraries; operating system packages) +#' required by a set of \R packages. +#' +#' This function relies on the database of package system requirements +#' maintained by Posit at , +#' as well as the "meta-CRAN" service at . This +#' service primarily exists to map the (free-form) `SystemRequirements` field +#' used by \R packages to the system packages made available by a particular +#' operating system. +#' +#' As an example, the `curl` R package depends on the `libcurl` system library, +#' and declares this with a `SystemRequirements` field of the form: +#' +#' - libcurl (>= 7.62): libcurl-devel (rpm) or libcurl4-openssl-dev (deb) +#' +#' This dependency can be satisfied with the following command line invocations +#' on different systems: +#' +#' - Debian: `sudo apt install libcurl4-openssl-dev` +#' - Redhat: `sudo dnf install libcurl-devel` +#' +#' and so `sysreqs("curl")` would help provide the name of the package +#' whose installation would satisfy the `libcurl` dependency. +#' +#' +#' @inheritParams renv-params +#' +#' @param packages A vector of \R package names. When `NULL` +#' (the default), the project's package dependencies as reported via +#' [renv::dependencies()] are used. +#' +#' @param local Boolean; should `renv` rely on locally-installed copies of +#' packages when resolving system requirements? When `FALSE`, `renv` will +#' use to resolve the system requirements +#' for these packages. +#' +#' @param check Boolean; should `renv` also check whether the requires system +#' packages appear to be installed on the current system? Ignored when +#' `distro` is supplied. +#' +#' @param report Boolean; should `renv` also report the commands which could be +#' used to install all of the requisite package dependencies? +#' +#' @param collapse Boolean; when reporting which packages need to be installed, +#' should the report be collapsed into a single installation command? When +#' `FALSE` (the default), a separate installation line is printed for each +#' required system package. +#' +#' @param distro The name of the Linux distribution for which system requirements +#' should be checked -- typical values are "ubuntu", "debian", and "redhat". +#' These should match the distribution names used by the R system requirements +#' database. A version suffix can be included; for example, "ubuntu:24.04". +#' +#' @examples +#' +#' \dontrun{ +#' +#' # report the required system packages for this system +#' sysreqs() +#' +#' # report the required system packages for a specific OS +#' sysreqs(platform = "ubuntu") +#' +#' } +#' +#' @export +sysreqs <- function(packages = NULL, + ..., + local = FALSE, + check = NULL, + report = TRUE, + distro = NULL, + collapse = FALSE, + project = NULL) +{ + # allow user to provide additional package names as part of '...' + if (!missing(...)) { + dots <- list(...) + names(dots) <- names(dots) %||% rep.int("", length(dots)) + packages <- c(packages, dots[!nzchar(names(dots))]) + } + + # resolve packages + packages <- packages %||% { + project <- renv_project_resolve(project) + deps <- dependencies(project, dev = TRUE) + sort(unique(deps$Package)) + } + + # remove 'base' packages + base <- installed_packages(priority = "base") + packages <- setdiff(packages, base$Package) + names(packages) <- packages + + # resolve check + check <- check %||% is.null(distro) + + # resolve distro + distro <- distro %||% the$distro + if (!identical(distro, the$distro)) { + parts <- strsplit(distro, ":", fixed = TRUE)[[1L]] + distro <- parts[[1L]] + version <- if (length(parts) >= 2L) parts[[2L]] + renv_scope_binding(the, "os", "linux") + renv_scope_binding(the, "distro", parts[[1L]]) + renv_scope_binding(the, "platform", list(VERSION_ID = version)) + } + + # compute package records + if (local) { + lockfile <- renv_lockfile_create(project, dev = TRUE) + records <- renv_lockfile_records(lockfile) + } else { + callback <- renv_progress_callback(renv_sysreqs_crandb, length(packages)) + records <- map(packages, callback) + } + + # extract and resolve the system requirements + sysreqs <- map(records, `[[`, "SystemRequirements") + sysdeps <- map(sysreqs, renv_sysreqs_resolve) + + # check the package status if possible + if (check) + renv_sysreqs_check(sysreqs, prompt = FALSE) + + # report installation commands if requested + if (report) + renv_sysreqs_report(sysdeps, distro, collapse) + + # return result + invisible(sysdeps) + +} + +renv_sysreqs_report <- function(sysdeps, distro, collapse) { + + # collect all system packages + syspkgs <- map(sysdeps, `[[`, "packages") + allpkgs <- sort(unique(unlist(syspkgs))) + if (empty(allpkgs)) + return() + + # include pre-install commands as well, if any + preinstall <- unlist(map(sysdeps, `[[`, "pre_install")) + if (length(preinstall)) { + if (interactive()) { + preamble <- "System pre-requisites can be installed with:" + bulletin(preamble, preinstall) + } else { + writeLines(preinstall) + } + } + + # generate installation commands + installer <- renv_sysreqs_installer(distro) + body <- if (collapse) paste(allpkgs, collapse = " ") else allpkgs + message <- paste("sudo", installer, "-y", body) + + if (interactive()) { + preamble <- "The requisite system packages can be installed with:" + bulletin(preamble, message) + } else { + writeLines(message) + } + +} + +renv_sysreqs_crandb <- function(package) { + tryCatch( + renv_sysreqs_crandb_impl(package), + error = warnify + ) +} + +renv_sysreqs_crandb_impl <- function(package) { + memoize( + key = package, + value = renv_sysreqs_crandb_impl_one(package), + scope = "sysreqs" + ) +} + +renv_sysreqs_crandb_impl_one <- function(package) { + url <- paste("https://crandb.r-pkg.org", package, sep = "/") + destfile <- tempfile("renv-crandb-", fileext = ".json") + download(url, destfile = destfile, quiet = TRUE) + renv_json_read(destfile) +} + +renv_sysreqs_resolve <- function(sysreqs, rules = renv_sysreqs_rules()) { + matches <- map(sysreqs, renv_sysreqs_match, rules) + unlist(matches, recursive = FALSE) +} + +renv_sysreqs_read <- function(package) { + desc <- renv_description_read(package) + desc[["SystemRequirements"]] %||% "" +} + +renv_sysreqs_rules <- function() { + the$sysreqs <- the$sysreqs %||% renv_sysreqs_rules_impl() +} + +renv_sysreqs_rules_impl <- function() { + rules <- system.file("sysreqs/sysreqs.json", package = "renv") + renv_json_read(rules) +} + +renv_sysreqs_match <- function(sysreq, rules = renv_sysreqs_rules()) { + + for (rule in rules) { + match <- renv_sysreqs_match_impl(sysreq, rule) + if (!is.null(match)) { + return(match) + } + } + +} + +renv_sysreqs_match_impl <- function(sysreq, rule) { + + # check for a match in the declared system requirements + pattern <- paste(rule$patterns, collapse = "|") + matches <- grepl(pattern, sysreq, ignore.case = TRUE, perl = TRUE) + + # if we got a match, pull out the dependent packages + if (matches) { + for (dependency in rule$dependencies) { + for (constraint in dependency$constraints) { + if (renv_sysreqs_satisfies(constraint)) { + return(dependency) + } + } + } + } + +} + +renv_sysreqs_satisfies <- function(constraint) { + + if (constraint$os == the$os) { + if (constraint$distribution == the$distro) { + if (!is.null(the$platform$VERSION_ID)) { + versions <- constraint$versions %||% the$platform$VERSION_ID + for (version in versions) { + if (startsWith(the$platform$VERSION_ID, version)) { + return(TRUE) + } + } + } + } + } + + FALSE + +} + +renv_sysreqs_aliases <- function(type, syspkgs) { + case( + type == "deb" ~ renv_sysreqs_aliases_deb(syspkgs), + type == "rpm" ~ renv_sysreqs_aliases_rpm(syspkgs) + ) +} + +renv_sysreqs_aliases_deb <- function(pkgs) { + + # https://www.debian.org/doc/debian-policy/ch-relationships.html#s-virtual + # + # > A virtual package is one which appears in the Provides control field of + # > another package. The effect is as if the package(s) which provide a + # > particular virtual package name had been listed by name everywhere the + # > virtual package name appears. (See also Virtual packages) + # + # read the package database, look which packages 'provide' others, + # and then reverse that map to map virtual packages to the concrete + # package which provides them + # + command <- "dpkg-query -W -f '${Package}=${Provides}\n'" + output <- system(command, intern = TRUE) + result <- renv_properties_read(text = output, delimiter = "=") + + # keep only packages which provide other packages + aliases <- result[nzchar(result)] + + # a package might provide multiple other packages, so split those + splat <- lapply(aliases, function(alias) { + parts <- strsplit(alias, ",\\s*", perl = TRUE)[[1L]] + names(renv_properties_read(text = parts, delimiter = " ")) + }) + + # reverse the map, so that we can map virtual packages to the + # concrete packages which they refer to + envir <- new.env(parent = emptyenv()) + enumerate(splat, function(package, virtuals) { + for (virtual in virtuals) { + envir[[virtual]] <<- c(envir[[virtual]], package) + } + }) + + # convert to intermediate list + result <- as.list(envir, all.names = TRUE) + + # return as named character vector + convert(result, type = "character") + +} + +renv_sysreqs_aliases_rpm <- function(pkgs) { + + # return early if no packages provided + if (empty(pkgs)) + return(character()) + + # for each package, check if there's another package that 'provides' it + fmt <- "rpm --query --whatprovides %s --queryformat '%%{Name}\n'" + args <- paste(renv_shell_quote(pkgs), collapse = " ") + command <- sprintf(fmt, args) + result <- suppressWarnings(system(command, intern = TRUE)) + + # return as named vector, mapping virtual packages to 'real' packages + matches <- grep("no package provides", result, fixed = TRUE, invert = TRUE) + aliases <- result[matches] + names(aliases) <- pkgs[matches] + + convert(aliases, type = "character") + +} + +renv_sysreqs_check <- function(sysreqs, prompt) { + + # check for a supported package installer + type <- case( + nzchar(Sys.which("dpkg")) ~ "deb", + nzchar(Sys.which("rpm")) ~ "rpm", + ~ NULL + ) + + if (is.null(type)) + return(NULL) + + # figure out which system packages are required + sysdeps <- map(sysreqs, renv_sysreqs_resolve) + syspkgs <- map(sysdeps, `[[`, "packages") + + # collect list of all packages discovered + allsyspkgs <- sort(unique(unlist(syspkgs, use.names = FALSE))) + + # some packages might be virtual packages, and won't be reported as installed + # when queried. try to resolve those to the actual underlying packages. + # some examples follows: + # + # Fedora 41: zlib-devel => zlib-ng-compat-devel + # Ubuntu 24.04: libfreetype6-dev => libfreetype-dev + # + aliases <- renv_sysreqs_aliases(type, allsyspkgs) + resolvedpkgs <- alias(allsyspkgs, aliases) + + # list all currently-installed packages + installedpkgs <- case( + type == "deb" ~ system("dpkg-query -W -f '${Package}\n'", intern = TRUE), + type == "rpm" ~ system("rpm --query --all --queryformat='%{Name}\n'", intern = TRUE) + ) + + # check for matches + misspkgs <- setdiff(resolvedpkgs, installedpkgs) + if (empty(misspkgs)) + return(TRUE) + + # notify the user + preamble <- "The following required system packages are not installed:" + postamble <- "The R packages depending on these system packages may fail to install." + parts <- map(misspkgs, function(misspkg) { + needs <- map_lgl(syspkgs, function(syspkg) misspkg %in% syspkg) + list(misspkg, names(syspkgs)[needs]) + }) + + lhs <- extract_chr(parts, 1L) + rhs <- map_chr(extract(parts, 2L), paste, collapse = ", ") + messages <- sprintf("%s [required by %s]", format(lhs), rhs) + bulletin(preamble, messages, postamble) + + installer <- case( + nzchar(Sys.which("apt")) ~ "apt install", + nzchar(Sys.which("dnf")) ~ "dnf install", + nzchar(Sys.which("pacman")) ~ "pacman -S", + nzchar(Sys.which("yum")) ~ "yum install", + nzchar(Sys.which("zypper")) ~ "zypper install", + ) + + preamble <- "An administrator can install these packages with:" + command <- paste("sudo", installer, paste(misspkgs, collapse = " ")) + bulletin(preamble, command) + + cancel_if(prompt && !proceed()) + +} + +renv_sysreqs_installer <- function(distro) { + + installer <- getOption("renv.sysreqs.installer", default = NULL) + if (!is.null(installer)) + return(installer) + + case( + distro == "alpine" ~ "apk add", + distro == "debian" ~ "apt install", + distro == "fedora" ~ "dnf install", + distro == "opensuse" ~ "zypper install", + distro == "redhat" ~ "dnf install", + distro == "rockylinux" ~ "dnf install", + distro == "sle" ~ "zypper install", + distro == "ubuntu" ~ "apt install", + ~ "" + ) +} + +renv_sysreqs_update <- function() { + + # save path to sysreqs folder + dest <- renv_path_normalize("inst/sysreqs/sysreqs.json") + + # move to temporary directory + renv_scope_tempdir() + + # clone the system requirements repository + args <- c("clone", "--depth", "1", "https://github.com/rstudio/r-system-requirements") + renv_system_exec("git", args, action = "cloing rstudio/r-system-requirements") + + # read all of the rules from the requirements repository + files <- list.files( + path = "r-system-requirements/rules", + pattern = "[.]json$", + full.names = TRUE + ) + + contents <- map(files, renv_json_read) + + # give names without extensions for these files + names <- basename(files) + idx <- map_int(gregexpr(".", names, fixed = TRUE), tail, n = 1L) + names(contents) <- substr(names, 1L, idx - 1L) + + # write to sysreqs.json + renv_json_write(contents, file = dest) + +} + + # system.R ------------------------------------------------------------------- @@ -29921,7 +33561,7 @@ renv_system_exec_details <- function(command, args, output) { # tar.R ---------------------------------------------------------------------- -renv_tar_exe <- function() { +renv_tar_exe <- function(default = "") { # allow override tar <- getOption("renv.tar.exe") @@ -29929,8 +33569,11 @@ renv_tar_exe <- function() { return(tar) # on unix, just use default - if (renv_platform_unix()) - return(Sys.which("tar")) + if (renv_platform_unix()) { + tar <- Sys.which("tar") + if (nzchar(tar)) + return(tar) + } # on Windows, use system tar.exe if available root <- Sys.getenv("SystemRoot", unset = NA) @@ -29943,7 +33586,7 @@ renv_tar_exe <- function() { return(tarpath) # otherwise, give up (don't trust the arbitrary tar on PATH) - "" + default } @@ -30011,11 +33654,50 @@ renv_task_unload <- function() { callbacks <- getTaskCallbackNames() for (callback in callbacks) for (prefix in c("renv_", "renv:::")) - if (startswith(callback, prefix)) + if (startsWith(callback, prefix)) removeTaskCallback(callback) } +# tempdir.R ------------------------------------------------------------------ + + +renv_tempdir_init <- function() { + + # only check on linux + if (!renv_platform_linux()) + return() + + # allow disable via envvar if needed + check <- Sys.getenv("RENV_TEMPDIR_NOEXEC_CHECK", unset = "TRUE") + if (not(check)) + return() + + # check that scripts within the R temporary directory can be executed + script <- tempfile("renv-script-", fileext = ".sh") + writeLines("#!/usr/bin/env sh", con = script) + Sys.chmod(script, mode = "0755") + on.exit(unlink(script), add = TRUE) + + status <- system(script, ignore.stdout = TRUE, ignore.stderr = TRUE) + if (identical(status, 0L)) + return() + + fmt <- heredoc(" + + The R temporary directory appears to be within a folder mounted as 'noexec'. + Installation of R packages from sources may fail. + See the section **Note** within `?INSTALL` for more details. + + tempdir(): %s + + ") + + caution(fmt, tempdir(), con = stderr()) + +} + + # template.R ----------------------------------------------------------------- @@ -30083,7 +33765,7 @@ renv_test_retrieve <- function(record) { recursive = TRUE ) - records <- retrieve(record$Package) + records <- renv_retrieve_impl(record$Package) renv_install_impl(records) descpath <- file.path(templib, package) @@ -30103,26 +33785,26 @@ renv_test_retrieve <- function(record) { renv_tests_diagnostics <- function() { # print library paths - caution_bullets( + bulletin( "The following R libraries are set:", paste("-", .libPaths()) ) # print repositories repos <- getOption("repos") - caution_bullets( + bulletin( "The following repositories are set:", paste(names(repos), repos, sep = ": ") ) # print renv root - caution_bullets( + bulletin( "The following renv root directory is being used:", paste("-", paths$root()) ) # print cache root - caution_bullets( + bulletin( "The following renv cache directory is being used:", paste("-", paths$cache()) ) @@ -30141,7 +33823,7 @@ renv_tests_diagnostics <- function() { path <- Sys.getenv("PATH") splat <- strsplit(path, .Platform$path.sep, fixed = TRUE)[[1]] - caution_bullets( + bulletin( "The following PATH is set:", paste("-", splat) ) @@ -30159,7 +33841,7 @@ renv_tests_diagnostics <- function() { vals <- Sys.getenv(envvars, unset = "") vals[vals != ""] <- renv_json_quote(vals[vals != ""]) - caution_bullets( + bulletin( "The following environment variables of interest are set:", paste(keys, vals, sep = " : ") ) @@ -30238,16 +33920,33 @@ truthy <- function(value, default = FALSE) { return(default) } - if (length(value) == 0) - default - else if (is.character(value)) - value %in% c("TRUE", "True", "true", "T", "1") - else if (is.symbol(value)) - as.character(value) %in% c("TRUE", "True", "true", "T", "1") + # skip empty vectors + if (length(value) == 0L) + return(default) + + # handle symbols + if (is.symbol(value)) + value <- as.character(value) + + # only look at first element in vector + value <- value[[1L]] + + # handle some non-character types up-front + if (is.call(value)) + return(default) else if (is.na(value)) - default + return(default) + else if (!is.character(value)) + return(as.logical(value)) + + # check for known truthy / falsy values + if (value %in% c("TRUE", "True", "true", "T", "1")) + TRUE + else if (value %in% c("FALSE", "False", "false", "F", "0")) + FALSE else - as.logical(value) + default + } @@ -30332,7 +34031,7 @@ renv_unload_libpaths <- function(project) { } renv_unload_finalizer <- function(libpath) { - libpath <- dirname(renv_namespace_path(.packageName)) + libpath <- renv_namespace_path(.packageName) .onUnload(libpath) } @@ -30412,22 +34111,6 @@ renv_update_find_git_impl <- function(record) { renv_update_find_github <- function(records) { - # check for GITHUB_PAT - if (!renv_envvar_exists("GITHUB_PAT")) { - - msg <- paste( - "GITHUB_PAT is unset. Updates may fail due to GitHub's API rate limit.", - "", - "To increase your GitHub API rate limit:", - "- Use `usethis::browse_github_pat()` to create a Personal Access Token (PAT).", - "- Use `usethis::edit_r_environ()` and add the token as `GITHUB_PAT`.", - sep = "\n" - ) - - warning(msg, call. = FALSE) - - } - names(records) <- map_chr(records, `[[`, "Package") results <- renv_parallel_exec(records, function(record) { catch(renv_update_find_github_impl(record)) @@ -30455,8 +34138,14 @@ renv_update_find_github_impl <- function(record) { if (sha == record$RemoteSha) return(NULL) + url <- record$RemoteUrl %||% { + origin <- fsub("api.github.com", "github.com", renv_retrieve_origin(host)) + parts <- c(origin, user, repo) + paste(parts, collapse = "/") + } + # get updated record - desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha) + desc <- renv_remotes_resolve_github_description(url, host, user, repo, subdir, sha) current <- list( Package = desc$Package, Version = desc$Version, @@ -30581,6 +34270,13 @@ renv_update_find <- function(records) { #' Use `renv::update(exclude = <...>)` to update all packages except for #' a specific set of excluded packages. #' +#' @param lock Boolean; update the `renv.lock` lockfile after the successful +#' installation of the requested packages? +#' +#' @param all Boolean; should `renv` check all library paths for out-of-date +#' packages? When `FALSE` (the default), only the project library will be +#' checked for out-of-date packages. +#' #' @return A named list of package records which were installed by renv. #' #' @export @@ -30596,9 +34292,12 @@ update <- function(packages = NULL, ..., exclude = NULL, library = NULL, + type = NULL, rebuild = FALSE, check = FALSE, prompt = interactive(), + lock = FALSE, + all = FALSE, project = NULL) { renv_consent_check() @@ -30610,9 +34309,14 @@ update <- function(packages = NULL, renv_scope_verbose_if(prompt) # resolve library path - libpaths <- renv_libpaths_resolve(library) - library <- nth(libpaths, 1L) - renv_scope_libpaths(libpaths) + library <- renv_libpaths_resolve(library) + renv_scope_libpaths(library) + + # check for explicitly-provided type -- we handle this specially for PPM + if (!is.null(type)) { + renv_scope_binding(the, "install_pkg_type", type) + renv_scope_options(pkgType = type) + } # resolve exclusions exclude <- c(exclude, settings$ignored.packages(project = project)) @@ -30621,11 +34325,21 @@ update <- function(packages = NULL, if (config$pak.enabled() && !recursing()) { packages <- setdiff(packages, exclude) renv_pak_init() - return(renv_pak_install(packages, libpaths, project)) + return( + renv_pak_install( + packages = packages, + library = library, + rebuild = rebuild, + type = type, + prompt = prompt, + project = project + ) + ) } # get package records renv_scope_binding(the, "snapshot_hash", FALSE) + libpaths <- if (all) library else library[[1L]] records <- renv_snapshot_libpaths(libpaths = libpaths, project = project) packages <- packages %||% names(records) @@ -30637,7 +34351,7 @@ update <- function(packages = NULL, if (!empty(missing)) { if (prompt || renv_verbose()) { - caution_bullets( + bulletin( "The following package(s) are not currently installed:", missing, "The latest available versions of these packages will be installed instead." @@ -30739,9 +34453,10 @@ update <- function(packages = NULL, # perform the install install( packages = updates, - library = libpaths, + library = library, rebuild = rebuild, prompt = prompt, + lock = lock, project = project ) @@ -30787,7 +34502,7 @@ renv_update_errors_emit_impl <- function(key, preamble, postamble) { sprintf("%s: %s", format(package), errmsg) }) - caution_bullets( + bulletin( preamble = preamble, values = messages, postamble = postamble @@ -30847,12 +34562,22 @@ renv_updates_report <- function(preamble, diff, old, new) { #' #' @description #' Upgrade the version of renv associated with a project, including using -#' a development version from GitHub. Automatically snapshots the update +#' a development version from GitHub. Automatically snapshots the updated #' renv, updates the activate script, and restarts R. #' #' If you want to update all packages (including renv) to their latest CRAN #' versions, use [renv::update()]. #' +#' # Note +#' +#' `upgrade()` is expected to work for renv versions >= 1.0.1. +#' To upgrade from prior versions of renv, users should +#' +#' `renv::deactivate();` +#' `install.packages("renv");` +#' `renv::activate();` +#' `renv::record("renv")` +#' #' @inherit renv-params #' #' @param version The version of renv to be installed. @@ -30933,7 +34658,7 @@ renv_upgrade_impl <- function(project, version, reload, prompt) { ) # retrieve and install renv - records <- retrieve("renv") + records <- renv_retrieve_impl("renv") renv_install_impl(records) # update the lockfile @@ -30949,11 +34674,20 @@ renv_upgrade_impl <- function(project, version, reload, prompt) { # # https://github.com/rstudio/renv/issues/1546 writef("- Updating activate script") - code <- substitute({ + record <- records[["renv"]] + + # make sure we forward renv.config.autoloader.enabled if set + # https://github.com/rstudio/renv/issues/2027 + autoload <- config$autoloader.enabled() + renv_scope_envvars(RENV_CONFIG_AUTOLOADER_ENABLED = autoload) + + code <- expr({ renv <- asNamespace("renv"); renv$summon() - version <- renv_metadata_version_create(record) - renv_infrastructure_write(project, version = version) - }, list(project = project, record = records[["renv"]])) + renv_infrastructure_write( + project = !!project, + version = !!renv_metadata_version_create(record) + ) + }) script <- renv_scope_tempfile("renv-activate-", fileext = ".R") writeLines(deparse(code), con = script) @@ -31334,18 +35068,19 @@ renv_use_python_condaenv <- function(python, } -renv_use_python_fini <- function(info, - name, - version, - project) -{ - # ensure project-local names are treated as such - name <- if (!is.null(name)) path.expand(chartr("\\", "/", name)) - project <- if (!is.null(project)) path.expand(chartr("\\", "/", project)) +renv_use_python_fini <- function(info, name, version, project) { + + # normalize project path for later comparison + project <- renv_path_normalize(project) - if (!is.null(name) && startswith(name, project)) { - base <- substring(name, nchar(project) + 2L) - name <- if (grepl("^[.][^/]+$", base)) base else file.path(".", base) + # handle 'name' -- treat values containing slashes specially, and + # check if those paths are project-relative environments + if (!is.null(name) && grepl("/", name, fixed = TRUE)) { + name <- renv_path_normalize(name) + if (startsWith(name, project)) { + base <- substring(name, nchar(project) + 2L) + name <- if (grepl("^[.][^/]+$", base)) base else file.path(".", base) + } } # form the lockfile fields we'll want to write @@ -31565,7 +35300,7 @@ the$use_libpath <- NULL use <- function(..., lockfile = NULL, library = NULL, - isolate = sandbox, + isolate = TRUE, sandbox = TRUE, attach = FALSE, verbose = TRUE) @@ -31597,18 +35332,40 @@ use <- function(..., return(invisible()) # resolve the provided remotes - remotes <- lapply(dots, renv_remotes_resolve) - names(remotes) <- map_chr(remotes, `[[`, "Package") + records <- lapply(dots, renv_remotes_resolve, latest = TRUE) + names(records) <- map_chr(records, `[[`, "Package") + + # remove any remotes which already appear to be installed + compat <- enum_lgl(records, function(package, record) { + + # check if the package is installed + if (!renv_package_installed(package, lib.loc = library)) + return(FALSE) + + # check if the installed package is compatible + record <- resolve(record) + current <- renv_snapshot_description(package = package) + diff <- renv_lockfile_diff_record(record, current) + + # a null diff implies the two records are compatible + is.null(diff) + + }) + + # drop the already-installed compatible records + records <- records[!compat] + if (empty(records)) + return(invisible()) # install packages records <- local({ renv_scope_options(renv.verbose = verbose) - install(packages = remotes, library = library, prompt = FALSE) + install(packages = records, library = library, rebuild = character(), prompt = FALSE) }) # automatically load the requested remotes if (attach) { - enumerate(remotes, function(package, remote) { + enumerate(records, function(package, remote) { library(package, character.only = TRUE) }) } @@ -31638,6 +35395,13 @@ renv_use_sandbox <- function(sandbox) { renv_scope_options(renv.config.sandbox.enabled = TRUE) renv_sandbox_activate_impl(sandbox = sandbox) + reg.finalizer(renv_envir_self(), function(envir) { + tryCatch( + renv_sandbox_unlock(sandbox), + condition = identity + ) + }, onexit = TRUE) + } @@ -31686,7 +35450,7 @@ bapply <- function(x, f, ..., index = "Index") { enumerate <- function(x, f, ..., FUN.VALUE = NULL) { n <- names(x) - idx <- named(seq_along(x), n) + idx <- `names<-`(seq_along(x), n) callback <- function(i) f(n[[i]], x[[i]], ...) if (is.environment(x)) @@ -31884,8 +35648,13 @@ catch <- function(expr) { catchall <- function(expr) { tryCatch( - withCallingHandlers(expr, condition = renv_error_capture), - condition = renv_error_tag + withCallingHandlers( + expr = expr, + error = renv_error_capture, + warning = renv_error_capture + ), + error = renv_error_tag, + warning = renv_error_tag ) } @@ -31903,6 +35672,15 @@ ask <- function(question, default = FALSE) { if (!interactive()) return(default) + # can't prompt for input when autoloading; code run from `.Rprofile` should + # not attempt to interact with the user + # from `?Startup`: + # "It is not intended that there be interaction with the user during startup + # code. Attempting to do so can crash the R process." + # https://github.com/rstudio/renv/issues/1879 + if (autoloading()) + return(default) + # be verbose in this scope, as we're asking the user for input renv_scope_options(renv.verbose = TRUE) @@ -31949,13 +35727,11 @@ proceed <- function(default = TRUE) { menu <- function(choices, title, default = 1L) { testing <- getOption("renv.menu.choice", integer()) - if (length(testing)) { - selected <- testing[[1]] - options(renv.menu.choice = testing[-1]) + selected <- if (length(testing)) { + options(renv.menu.choice = testing[-1L]) + testing[[1L]] } else if (testing()) { - selected <- default - } else { - selected <- NULL + default } if (!is.null(selected)) { @@ -31985,7 +35761,7 @@ menu <- function(choices, title, default = 1L) { # nocov end -inject <- function(contents, +insert <- function(contents, pattern, replacement, anchor = NULL, @@ -32023,7 +35799,9 @@ read <- function(file) { } plural <- function(word, n) { - if (n == 1) word else paste(word, "s", sep = "") + suffixes <- c("", "s") + indices <- as.integer(n != 1L) + 1L + paste0(word, suffixes[indices]) } nplural <- function(word, n) { @@ -32053,6 +35831,11 @@ visited <- function(name, envir) { value } +zmap <- function(x, f) { + callback <- function(x) do.call(f, x) + lapply(x, callback) +} + rowapply <- function(X, FUN, ...) { lapply(seq_len(NROW(X)), function(I) { FUN(X[I, , drop = FALSE], ...) @@ -32105,14 +35888,31 @@ keep <- function(x, keys) { x[intersect(keys, names(x))] } -exclude <- function(x, keys) { +keep_if <- function(x, f) { + x[f(x)] +} + +omit <- function(x, keys) { x[setdiff(names(x), keys)] } +omit_if <- function(x, f) { + x[!f(x)] +} + invoke <- function(callback, ...) { callback(...) } +resolve <- function(object) { + + while (is.function(object)) + object <- object() + + object + +} + dequote <- function(strings) { for (quote in c("'", '"')) { @@ -32139,21 +35939,6 @@ nth <- function(x, i) { x[[i]] } -heredoc <- function(text, leave = 0) { - - # remove leading, trailing whitespace - trimmed <- gsub("^\\s*\\n|\\n\\s*$", "", text) - - # split into lines - lines <- strsplit(trimmed, "\n", fixed = TRUE)[[1L]] - - # compute common indent - indent <- regexpr("[^[:space:]]", lines) - common <- min(setdiff(indent, -1L)) - leave - paste(substring(lines, common), collapse = "\n") - -} - find <- function(x, f, ...) { for (i in seq_along(x)) if (!is.null(value <- f(x[[i]], ...))) @@ -32187,6 +35972,9 @@ fsub <- function(pattern, replacement, x, ignore.case = FALSE, useBytes = FALSE) rows <- function(data, indices) { + if (is.null(data)) + return(data_frame()) + # convert logical values if (is.logical(indices)) { if (length(indices) < nrow(data)) @@ -32284,13 +36072,14 @@ take <- function(data, index = NULL) { if (is.null(index)) data else .subset2(data, index) } -cancel <- function() { +cancel <- function(verbose = TRUE) { renv_snapshot_auto_suppress_next() if (testing()) stop("Operation canceled", call. = FALSE) - message("- Operation canceled.") + if (verbose) + message("- Operation canceled.") invokeRestart("abort") } @@ -32333,8 +36122,6 @@ summon <- function() { list2env(as.list(renv), envir = envir) } -assert <- function(...) stopifnot(...) - overlay <- function(lhs, rhs) { modifyList(as.list(lhs), as.list(rhs)) } @@ -32352,8 +36139,25 @@ topfun <- function() { } warnify <- function(cnd) { + + # re-signal condition as warning class(cnd) <- c("warning", "condition") warning(cnd) + + # return the condition invisibly + invisible(cnd) + +} + +# note: also handles stringy values like 'True' +not <- function(value) { + if (value) FALSE else TRUE +} + +wait <- function(predicate, ...) { + while (TRUE) + if (predicate(...)) + break } @@ -32442,8 +36246,8 @@ vendor <- function(version = "main", project = getwd()) { # A vendored copy of renv was created at: %s # The renv auto-loader was generated at: %s # - # Please add `renv$initialize()` to your package's `.onLoad()` - # to ensure that renv is initialized on package load. + # Please add `renv$initialize(libname, pkgname)` to your package's + # `.onLoad()` to ensure that renv is initialized on package load. # ") @@ -32724,6 +36528,134 @@ renv_virtualization_type_impl <- function() { } +# vulns.R -------------------------------------------------------------------- + + +#' Request Vulnerability Information for a Package +#' +#' This function acts as an interface to Posit Package Manager's vulnerability +#' API, making it possible to ascertain if the provided packages have any +#' known vulnerabilities. +#' +#' This function requires the \pkg{curl} package to be installed. +#' +#' @inheritParams renv-params +#' +#' @param packages A vector of package specifications, of the form +#' `==` or `@`. +#' +#' @param lockfile The path to an `renv` lockfile. When specified, `packages` +#' is ignored, and vulnerabilities are queried based on the packages defined +#' in the lockfile. +#' +#' @param repos The Package Manager repository to be queried. +#' +#' @param verbose Boolean; when `TRUE`, verbose information from the `curl` +#' web request will be printed to the console. +#' +#' @returns An \R list of vulnerability information. Only packages which +#' have known vulnerabilities will be included in the resulting data object. +#' +#' @keywords internal +#' @export +vulns <- function(packages = NULL, + lockfile = NULL, + ..., + repos = NULL, + verbose = FALSE, + project = NULL) +{ + if (!requireNamespace("curl", quietly = TRUE)) + stop("renv::vulns() requires the 'curl' package") + + renv_scope_error_handler() + renv_dots_check(...) + project <- renv_project_resolve(project) + + packages <- packages %||% { + lockfile <- lockfile %||% renv_paths_lockfile(project) + lockfile <- renv_lockfile_read(lockfile) + records <- renv_lockfile_records(lockfile) + map_chr(records, function(record) { + paste(record[["Package"]], record[["Version"]], sep = "==") + }) + } + + packages <- gsub("@", "==", packages, fixed = TRUE) + + repos <- repos %||% getOption("repos")[[1L]] + parts <- renv_ppm_parse(repos) + if (length(parts) == 0L) { + warningf("failed to parse repository '%s'", repos) + return(list()) + } + + # begin building a curl handle + handle <- curl::new_handle(verbose = verbose) + + # set headers for request + headers <- list("Content-Type" = "application/json") + curl::handle_setheaders(handle, .list = headers) + + # start building POST options + data <- list( + repo = parts[["repos"]], + snapshot = parts[["snapshot"]], + names = as.list(unname(packages)), + metadata = TRUE, + vulns = TRUE, + omit_dependencies = TRUE, + omit_downloads = TRUE, + omit_package_details = TRUE + ) + + json <- renv_json_convert(data) + + # get netrc file path + curl::handle_setopt( + handle = handle, + post = TRUE, + postfields = json + ) + + # use netrc if available + netrcFile <- getOption("netrc", default = Sys.getenv("NETRC", unset = "~/.netrc")) + if (file.exists(netrcFile)) + { + curl::handle_setopt( + handle = handle, + httpauth = 1L, + netrc = 1L, + netrc_file = path.expand(netrcFile) + ) + } + + # make the request, collect the response + endpoint <- file.path(parts[["root"]], "__api__/filter/packages") + response <- curl::curl_fetch_memory(endpoint, handle = handle) + contents <- enc2utf8(rawToChar(response$content)) + splat <- strsplit(contents, "\n", fixed = TRUE)[[1L]] + data <- lapply(splat, function(text) { + renv_json_read(text = text) + }) + + # handle errors + for (i in seq_along(data)) + { + error <- data[[i]][["error"]] + if (!is.character(error)) + next + + code <- data[[i]][["code"]] %||% "unknown" + fmt <- "error requesting package metadata; %s [error code %s]" + msg <- sprintf(fmt, error, as.character(code)) + stop(msg, call. = FALSE) + } + + data +} + + # warnings.R ----------------------------------------------------------------- @@ -32763,6 +36695,9 @@ renv_warnings_unknown_sources <- function(records) { renv_watchdog_server_start <- function(client) { + # silence warnings + renv_scope_options(warn = -1L) + # initialize logging renv_log_init() @@ -32774,8 +36709,8 @@ renv_watchdog_server_start <- function(client) { dlog("watchdog-server", "Waiting for client...") metadata <- list(port = server$port, pid = server$pid) conn <- renv_socket_connect(port = client$port, open = "wb") + defer(close(conn)) serialize(metadata, connection = conn) - close(conn) dlog("watchdog-server", "Synchronized with client.") # initialize locks @@ -32817,13 +36752,19 @@ renv_watchdog_server_run <- function(server, client, lockenv) { str(request) # handle the request + renv_watchdog_server_run_impl(server, client, lockenv, request) + +} + +renv_watchdog_server_run_impl <- function(server, client, lockenv, request) { + switch( request$method %||% "", ListLocks = { dlog("watchdog-server", "Executing 'ListLocks' request.") - conn <- renv_socket_connect(port = request$port, open = "watchdog-server", "b") + conn <- renv_socket_connect(port = request$port, open = "wb") defer(close(conn)) locks <- ls(envir = lockenv, all.names = TRUE) serialize(locks, connection = conn) @@ -32906,7 +36847,7 @@ renv_watchdog_enabled_impl <- function() { if (getRversion() < "4.0.0") return(FALSE) - # skip if explicitly disabled via envvar + # allow override via environment variable enabled <- Sys.getenv("RENV_WATCHDOG_ENABLED", unset = NA) if (!is.na(enabled)) return(truthy(enabled)) @@ -32956,7 +36897,7 @@ renv_watchdog_start_impl <- function() { # can communicate what port it'll be listening on for messages dlog("watchdog", "launching watchdog") server <- renv_socket_server() - socket <- server$socket; port <- server$port + socket <- server$socket defer(close(socket)) # generate script to invoke watchdog @@ -32969,20 +36910,9 @@ renv_watchdog_start_impl <- function() { else renv_libpaths_default() - # for R CMD check - name <- .packageName - pid <- Sys.getpid() - - env <- list( - name = name, - library = library, - pid = pid, - port = port - ) - - code <- substitute(env = env, { - client <- list(pid = pid, port = port) - host <- loadNamespace(name, lib.loc = library) + code <- expr({ + client <- list(pid = !!Sys.getpid(), port = !!server$port) + host <- loadNamespace(!!.packageName, lib.loc = !!library) renv <- if (!is.null(host$renv)) host$renv else host renv$renv_watchdog_server_start(client) }) @@ -33014,8 +36944,8 @@ renv_watchdog_start_impl <- function() { } # store information about the running process + defer(close(conn)) the$watchdog_process <- unserialize(conn) - close(conn) # return TRUE to indicate process was started dlog("watchdog", "watchdog message received [pid == %i]", the$watchdog_process$pid) @@ -33221,52 +37151,45 @@ renv_yaml_load <- function(text) { } -# zzz.R ---------------------------------------------------------------------- +# zzz-libs.R ----------------------------------------------------------------- -.onLoad <- function(libname, pkgname) { - renv_zzz_load() +renv_zzz_libs <- function() { + + status <- tryCatch( + renv_zzz_libs_impl(), + error = identity + ) + } -.onAttach <- function(libname, pkgname) { - renv_zzz_attach() +renv_zzz_libs_impl <- function() { + + if (!installing() || !renv_ext_enabled()) + return(FALSE) + + message("** libs") + package <- Sys.getenv("R_PACKAGE_DIR", unset = getwd()) + renv_ext_compile(package) + + TRUE + } -.onUnload <- function(libpath) { +renv_zzz_libs() - renv_lock_unload() - renv_task_unload() - renv_watchdog_unload() - # do some extra cleanup when running R CMD check - if (renv_platform_unix() && checking() && !ci()) - cleanse() - - # flush the help db to avoid errors on reload - # https://github.com/rstudio/renv/issues/1294 - helpdb <- system.file(package = "renv", "help/renv.rdb") - .Internal <- .Internal - lazyLoadDBflush <- function(...) {} - - tryCatch( - .Internal(lazyLoadDBflush(helpdb)), - error = function(e) NULL - ) - -} +# zzz.R ---------------------------------------------------------------------- -# NOTE: required for devtools::load_all() -.onDetach <- function(libpath) { - package <- Sys.getenv("DEVTOOLS_LOAD", unset = NA) - if (identical(package, .packageName)) - .onUnload(libpath) -} -renv_zzz_load <- function() { +.onLoad <- function(libname, pkgname) { # NOTE: needs to be visible to embedded instances of renv as well the$envir_self <<- renv_envir_self() + # load extensions if available + renv_ext_onload(libname, pkgname) + # make sure renv (and packages using renv!!!) use tempdir for storage # when running tests, or R CMD check if (checking() || testing()) { @@ -33275,6 +37198,12 @@ renv_zzz_load <- function() { root <- Sys.getenv("RENV_PATHS_ROOT", unset = tempfile("renv-root-")) Sys.setenv(RENV_PATHS_ROOT = root) + # unset on exit + reg.finalizer(renv_envir_self(), function(envir) { + if (identical(root, Sys.getenv("RENV_PATHS_ROOT", unset = NA))) + Sys.unsetenv("RENV_PATHS_ROOT") + }, onexit = TRUE) + # set up sandbox -- only done on non-Windows due to strange intermittent # test failures that seemed to occur there? if (renv_platform_unix()) { @@ -33282,12 +37211,18 @@ renv_zzz_load <- function() { Sys.setenv(RENV_PATHS_SANDBOX = sandbox) } - # don't lock sandbox while testing / checking - options(renv.sandbox.locking_enabled = FALSE) + } + # don't lock sandbox while testing / checking + if (testing() || checking() || devmode()) { + options(renv.sandbox.locking_enabled = FALSE) + Sys.setenv(RENV_SANDBOX_LOCKING_ENABLED = FALSE) } + renv_defer_init() renv_metadata_init() + renv_ext_init() + renv_ansify_init() renv_platform_init() renv_virtualization_init() renv_envvars_init() @@ -33298,6 +37233,7 @@ renv_zzz_load <- function() { renv_sandbox_init() renv_sdkroot_init() renv_watchdog_init() + renv_tempdir_init() if (!renv_metadata_embedded()) { @@ -33309,11 +37245,16 @@ renv_zzz_load <- function() { # if an renv project already appears to be loaded, then re-activate # the sandbox now -- this is primarily done to support suspend and - # resume with RStudio where the user profile might not be run + # resume with RStudio where the user profile might not have been run, + # but RStudio would have restored options from the prior session + # + # https://github.com/rstudio/renv/issues/2036 if (renv_rstudio_available()) { project <- getOption("renv.project.path") - if (!is.null(project)) + if (!is.null(project)) { + renv_project_set(project) renv_sandbox_activate(project = project) + } } # make sure renv is unloaded on exit, so locks etc. are released @@ -33324,15 +37265,44 @@ renv_zzz_load <- function() { } -renv_zzz_attach <- function() { +.onAttach <- function(libname, pkgname) { renv_rstudio_fixup() } +.onUnload <- function(libpath) { + + renv_lock_unload() + renv_task_unload() + renv_watchdog_unload() + + # do some extra cleanup when running R CMD check + if (renv_platform_unix() && checking() && !ci()) + cleanse() + + # flush the help db to avoid errors on reload + # https://github.com/rstudio/renv/issues/1294 + helpdb <- file.path(libpath, "help/renv.rdb") + .Internal <- .Internal + lazyLoadDBflush <- function(...) {} + + tryCatch( + .Internal(lazyLoadDBflush(helpdb)), + error = function(e) NULL + ) + +} + +# NOTE: required for devtools::load_all() +.onDetach <- function(libpath) { + if (devmode()) + .onUnload(libpath) +} + renv_zzz_run <- function() { # check if we're in pkgload::load_all() # if so, then create some files - if (renv_envvar_exists("DEVTOOLS_LOAD")) { + if (devmode()) { renv_zzz_bootstrap_activate() renv_zzz_bootstrap_config() } @@ -33348,7 +37318,7 @@ renv_zzz_bootstrap_activate <- function() { source <- "templates/template-activate.R" target <- "inst/resources/activate.R" - scripts <- c("R/bootstrap.R", "R/json-read.R") + scripts <- c("R/ansify.R", "R/bootstrap.R", "R/json-read.R") # Do we need an update source_mtime <- max(renv_file_info(c(source, scripts))$mtime)