#
# 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.
#

# aaa.R ----------------------------------------------------------------------


# global variables
the <- new.env(parent = emptyenv())

# detect if we're running on CI
ci <- function() {
  !is.na(Sys.getenv("CI", unset = NA))
}

# detect if we're running within R CMD build
building <- function() {
  nzchar(Sys.getenv("R_CMD")) &&
    grepl("Rbuild", basename(dirname(getwd())), fixed = TRUE)
}

# are we running code within R CMD check?
checking <- function() {
  "CheckExEnv" %in% search() ||
    renv_envvar_exists("_R_CHECK_PACKAGE_NAME_") ||
    renv_envvar_exists("_R_CHECK_SIZE_OF_TARBALL_")
}

# NOTE: Prefer using 'testing()' to 'renv_tests_running()' for behavior
# that should apply regardless of the package currently being tested.
#
# 'renv_tests_running()' is appropriate when running renv's own tests.
testing <- function() {
  identical(Sys.getenv("TESTTHAT"), "true")
}


# abi.R ----------------------------------------------------------------------


renv_abi_check <- function(packages = NULL,
                           ...,
                           libpaths = NULL,
                           project  = NULL)
{
  if (renv_platform_windows()) {
    writef("- ABI conflict checks are not yet implemented on Windows.")
    return()
  }

  # disable via option if necessary
  enabled <- getOption("renv.abi.check", default = TRUE)
  if (identical(enabled, FALSE))
    return()

  # resolve arguments
  project <- renv_project_resolve(project)
  libpaths <- libpaths %||% renv_libpaths_all()

  # read installed packages
  packages <- packages %||% renv_abi_packages(project, libpaths)

  # analyze each package
  problems <- stack()
  map(packages, function(package) {
    tryCatch(
      renv_abi_check_impl(package, problems),
      error = warnify
    )
  })

  # report problmes
  data <- problems$data()
  if (empty(data)) {
    fmt <- "- No ABI conflicts were detected in the set of installed packages."
    writef(fmt)
    return(invisible(data))
  }

  # combine everything together
  tbl <- bind(data)

  # make reports for each different type
  reasons <- unique(tbl$reason)
  if ("Rcpp_precious_list" %in% reasons) {
    packages <- sort(unique(tbl$package[tbl$reason == "Rcpp_precious_list"]))
    caution_bullets(
      "The following packages were built against a newer version of Rcpp than is currently available:",
      packages,
      c(
        paste(
          "These packages depend on Rcpp (>= 1.0.7);",
          "however, Rcpp", renv_package_version("Rcpp"), "is currently installed."
        ),
        "Consider installing a new version of Rcpp with 'install.packages(\"Rcpp\")'."
      )
    )
  }

  invisible(tbl)

}

renv_abi_check_impl <- function(package, problems) {

  # find path to package
  pkgpath <- renv_package_find(package)

  # look for an associated shared object
  shlib <- renv_package_shlib(pkgpath)
  if (!file.exists(shlib))
    return()

  # read symbols from LinkingTo dependency packages
  pkgdesc <- renv_description_read(path = pkgpath)
  if (is.null(pkgdesc$LinkingTo))
    return()

  # read symbols from the library
  symbols <- renv_abi_symbols(shlib)

  # handle Rcpp
  linkdeps <- renv_description_parse_field(pkgdesc$LinkingTo)
  if ("Rcpp" %in% linkdeps$Package)
    renv_abi_check_impl_rcpp(package, symbols, problems)

  # TODO: other checks? more direct symbol checks for other packages?

}

renv_abi_check_impl_rcpp <- function(package, symbols, problems) {

  # read Rcpp symbols
  rcpplib <- renv_package_shlib("Rcpp")
  rcppsyms <- renv_abi_symbols(rcpplib)

  # perform checks for different versions of Rcpp
  renv_abi_check_impl_rcpp_preciouslist(package, symbols, rcppsyms, problems)

}

renv_abi_check_impl_rcpp_preciouslist <- function(package, symbols, rcppsyms, problems) {

  # check for dependency on Rcpp_precious APIs
  required <- grep("Rcpp_precious", symbols$symbol, value = TRUE)
  if (empty(required))
    return()

  # check for Rcpp_precious APIs being available
  available <- grep("Rcpp_precious", rcppsyms$symbol, value = TRUE)
  if (length(available))
    return()

  problem <- renv_abi_problem(
    package    = paste(package, renv_package_version(package)),
    dependency = paste("Rcpp", renv_package_version("Rcpp")),
    reason     = "Rcpp_precious_list"
  )

  problems$push(problem)

}

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)),
    action  = "reading symbols"
  )

  # parse output
  parts <- strsplit(output, "\\s+")
  data <- .mapply(c, parts, NULL)
  names(data) <- c("offset", "type", "symbol")

  # join into data.frame
  as_data_frame(data)

}

renv_abi_problem <- function(package, dependency, reason) {

  list(
    package    = package,
    dependency = dependency,
    reason     = reason
  )

}

renv_abi_packages <- function(project, libpaths) {

  # create a lockfile
  lockfile <- snapshot(
    library  = libpaths,
    lockfile = NULL,
    type     = "all",
    project  = project
  )

  # return package names
  names(lockfile$Packages)

}


# abort.R --------------------------------------------------------------------


abort <- function(message, ..., body = NULL, class = NULL) {

  # create condition object
  cnd <- if (is.character(message)) {
    structure(class = c(class, "error", "condition"), list(
      message = paste(c(message, body), collapse = "\n"),
      meta = list(message = message, body = body),
      ...
    ))
  } else if (inherits(message, "condition")) {
    message
  } else {
    stop("internal error: abort called with unexpected message")
  }

  # if we were called with a custom condition object not having our meta,
  # just throw it as-is
  if (is.null(cnd$meta))
    stop(cnd)

  # signal the condition, giving calling handlers a chance to run first
  signalCondition(cnd)

  # if we got here, then there wasn't any tryCatch() handler on the stack.
  # handle printing of the error ourselves, and then stop with fallback.
  all <- c(
    cnd$meta$body, if (length(cnd$meta$body)) "",
    paste("Error:", paste(cnd$meta$message, collapse = "\n"))
  )

  # write error message to stderr, as errors might normally do
  writeLines(all, con = stderr())

  # create the fallback, but 'dodge' the existing error handlers
  fallback <- cnd
  fallback$message <- ""
  class(fallback) <- "condition"

  # disable error printing for the empty error
  renv_scope_options(show.error.messages = FALSE)

  # now throw the error
  stop(fallback)

}


# acls.R ---------------------------------------------------------------------


renv_acls_reset <- function(source, target = dirname(source)) {

  # only run on Linux for now
  if (!renv_platform_linux())
    return(FALSE)

  # skip if we don't have 'getfacl', 'setfacl'
  getfacl <- Sys.which("getfacl"); setfacl <- Sys.which("setfacl")
  if (!nzchar(getfacl) || !nzchar(setfacl))
    return(FALSE)

  # build command
  fmt <- "getfacl %s 2> /dev/null | setfacl -R --set-file=- %s 2> /dev/null"
  cmd <- sprintf(fmt, renv_shell_path(target), renv_shell_path(source))

  # execute it
  # TODO: Should we report errors? If so, how?
  catch(
    renv_system_exec(
      command = cmd,
      action = "resetting ACLs",
      quiet = TRUE
    )
  )

}


# actions.R ------------------------------------------------------------------


actions <- function(action = c("snapshot", "restore"),
                    ...,
                    project = NULL,
                    library = NULL,
                    lockfile = NULL,
                    type = settings$snapshot.type(project = project),
                    clean = FALSE)
{
  action   <- match.arg(action)
  project  <- renv_project_resolve(project)
  lockfile <- lockfile %||% renv_lockfile_path(project = project)

  renv_project_lock(project = project)

  switch(
    action,
    snapshot = renv_actions_snapshot(project, library, lockfile, type),
    restore  = renv_actions_restore(project, library, lockfile, clean)
  )
}

renv_actions_merge <- function(snap, lock, diff) {

  fields <- c("Package", "Version", "Source")
  defaults <- data.frame(
    "Package"          = character(),
    "Library Version"  = character(),
    "Library Source"   = character(),
    "Lockfile Version" = character(),
    "Lockfile Source"  = character(),
    check.names = FALSE,
    stringsAsFactors = FALSE
  )

  lhs <- bapply(unname(renv_lockfile_records(snap)), `[`, fields)
  if (length(lhs))
    names(lhs) <- c("Package", paste("Library",  names(lhs)[-1L]))

  rhs <- bapply(unname(renv_lockfile_records(lock)), `[`, fields)
  if (length(rhs))
    names(rhs) <- c("Package", paste("Lockfile", names(rhs)[-1L]))

  merged <- if (length(lhs) && length(rhs))
    merge(lhs, rhs, by = "Package", all = TRUE)
  else if (length(lhs))
    lhs
  else if (length(rhs))
    rhs
  else
    defaults

  actions <- data.frame(Package = names(diff),
                        Action = as.character(diff),
                        check.names = FALSE,
                        stringsAsFactors = FALSE)

  all <- merge(merged, actions, by = "Package")

  missing <- setdiff(names(defaults), names(all))
  all[missing] <- NA_character_

  all

}

renv_actions_snapshot <- function(project, library, lockfile, type) {

  lock <- renv_lockfile_load(project = project)
  snap <- snapshot(project = project,
                   library = library,
                   lockfile = NULL,
                   type = type)

  diff <- renv_lockfile_diff_packages(lock, snap)
  renv_actions_merge(snap, lock, diff)

}

renv_actions_restore <- function(project, library, lockfile, clean) {

  # NOTE: we use a simple snapshot here as we just want to know the
  # difference in library state before and after applying the lockfile;
  # that is, we want to know what the library looks like without any
  # filtering of what records would be reported from the library
  lock <- renv_lockfile_load(project = project)
  snap <- snapshot(project = project,
                   library = library,
                   lockfile = NULL,
                   type = "all")

  diff <- renv_lockfile_diff_packages(snap, lock)
  actions <- renv_actions_merge(snap, lock, diff)
  renv_actions_restore_clean(actions, clean, project)

}

renv_actions_restore_clean <- function(actions, clean, project) {

  # if not cleaning, then we don't do any removals
  if (!clean) {
    filtered <- actions[actions$Action != "remove", ]
    return(filtered)
  }

  # otherwise, only process removals in the project library
  projlib <- renv_paths_library(project = project)
  locations <- renv_package_find(actions$Package)

  keep <- actions$Action != "remove" | dirname(locations) == projlib
  actions[keep, ]

}


# activate.R -----------------------------------------------------------------


#' Activate or deactivate a project
#'
#' @description
#' `activate()` enables renv for a project in both the current session and
#' in all future sessions. You should not generally need to call `activate()`
#' yourself as it's called automatically by [renv::init()], which is the best
#' way to start using renv in a new project.
#'
#' `activate()` first calls [renv::scaffold()] to set up the project
#' infrastructure. Most importantly, this creates a project library and adds a
#' an auto-loader to `.Rprofile` to ensure that the project library is
#' automatically used for all future instances of the project. It then restarts
#' the session to use that auto-loader.
#'
#' `deactivate()` removes the infrastructure added by `activate()`, and
#' restarts the session. By default it will remove the auto-loader from the
#' `.Rprofile`; use `clean = TRUE` to also delete the lockfile and the project
#' library.
#'
#' # Temporary deactivation
#'
#' If you need to temporarily disable autoload activation you can set
#' the `RENV_CONFIG_AUTOLOADER_ENABLED` envvar, e.g.
#' `Sys.setenv(RENV_CONFIG_AUTOLOADER_ENABLED = "false")`.
#'
#' @inherit renv-params
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # activate the current project
#' renv::activate()
#'
#' # activate a separate project
#' renv::activate("~/projects/analysis")
#'
#' # deactivate the currently-activated project
#' renv::deactivate()
#'
#' }
activate <- function(project = NULL, profile = NULL) {

  renv_consent_check()
  renv_scope_error_handler()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  renv_profile_set(profile)

  renv_activate_impl(
    project = project,
    profile = profile,
    version = NULL
  )

  invisible(project)

}

renv_activate_impl <- function(project,
                               profile,
                               version = NULL,
                               load    = TRUE,
                               restart = TRUE)
{
  # prepare renv infrastructure
  renv_infrastructure_write(
    project = project,
    profile = profile,
    version = version
  )

  # ensure renv is imbued into the new library path if necessary
  if (!renv_tests_running())
    renv_imbue_self(project)

  # restart session if requested
  if (restart && !renv_tests_running())
    return(renv_restart_request(project, reason = "renv activated"))

  if (renv_rstudio_available())
    renv_rstudio_initialize(project)

  # try to load the project
  if (load) {
    setwd(project)
    load(project)
  }

  invisible(project)

}

renv_activate_version <- function(project) {

  # try to get version from activate.R
  methods <- list(
    renv_activate_version_lockfile,
    renv_activate_version_activate,
    renv_activate_version_metadata
  )

  for (method in methods) {
    version <- catch(method(project))
    if (is.character(version))
      return(version)
  }

  fmt <- "failed to determine renv version for project %s"
  stopf(fmt, renv_path_pretty(project))

}

renv_activate_version_activate <- function(project) {

  # get path to the activate script
  activate <- renv_paths_activate(project = project)
  if (!file.exists(activate))
    return(NULL)

  # check for version
  contents <- readLines(activate, warn = FALSE)
  line <- grep("version <-", contents, fixed = TRUE, value = TRUE)[[1L]]
  version <- parse(text = line)[[1L]][[3L]]

  # check for sha as well
  line <- grep("attr(version, \"sha\")", contents, fixed = TRUE, value = TRUE)
  if (length(line)) {
    sha <- parse(text = line)[[1L]][[3L]]
    attr(version, "sha") <- sha
  }

  version

}

renv_activate_version_lockfile <- function(project) {

  path <- renv_lockfile_path(project)
  if (!file.exists(path))
    return(NULL)

  # read the renv record
  lockfile <- renv_lockfile_read(path)
  records <- renv_lockfile_records(lockfile)
  renv_metadata_version_create(records[["renv"]])

}

renv_activate_version_metadata <- function(project) {
  the$metadata$version
}

renv_activate_prompt <- function(action, library, prompt, project) {

  # check whether we should ask user to activate
  ask <-
    config$activate.prompt() &&
    prompt &&
    interactive() &&
    is.null(library) &&
    !renv_project_loaded(project) &&
    !testing()

  # for snapshot, since users might want to snapshot their system library
  # in an renv-lite configuration, only prompt if it looks like they're
  # working within an renv project that hasn't been loaded
  if ("snapshot" %in% action) {
    libpath <- renv_paths_library(project = project)
    ask <- ask && file.exists(libpath)
  }

  if (!ask)
    return(FALSE)

  renv_activate_prompt_impl(action, 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?"
  )
  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."
  )

  choice <- menu(choices, title, default = "continue")
  switch(choice,
    activate = { activate(project = project); TRUE },
    continue = FALSE,
    cancel = cancel(),
  )
}


# addins.R -------------------------------------------------------------------


renv_addins_embed_ui <- function() {

  miniUI::miniPage(
    miniUI::gadgetTitleBar("Embed a Lockfile"),
    miniUI::miniContentPanel(
      shiny::verticalLayout(
        shiny::fileInput(
          inputId     = "lockfile",
          label       = "Lockfile path:",
          placeholder = "(Use default)"
        )
      )
    )
  )

}

renv_addins_embed_server <- function(input, output, session) {

  shiny::observeEvent(input$done, {

    # notify the user that we're working now
    progress <- shiny::Progress$new(
      session = shiny::getDefaultReactiveDomain(),
      style   = "notification"
    )

    progress$set(message = "Embedding lockfile...")

    # get editor context
    context <- rstudioapi::getSourceEditorContext()

    # validate we have a path
    path <- context$path
    if (!nzchar(path))
      stop("cannot embed lockfile into an unsaved file", call. = FALSE)

    # get project path
    project <- rstudioapi::getActiveProject()

    # read lockfile
    lockfile <- input$lockfile
    if (!is.null(lockfile))
      lockfile <- renv_lockfile_read(file = lockfile$datapath)

    # save document and run embed
    rstudioapi::documentSave(id = context$id)
    embed(path = path, lockfile = lockfile, project = project)

    # stop app
    invisible(shiny::stopApp())

  })

}

renv_addins_embed <- function() {

  # first, check that shiny and miniUI are available
  for (package in c("miniUI", "rstudioapi", "shiny")) {
    if (!requireNamespace(package, quietly = TRUE)) {
      fmt <- "required package '%s' is not available"
      stopf(fmt, package)
    }
  }

  # ask the user to save the document first if necessary
  context <- rstudioapi::getSourceEditorContext()
  if (!nzchar(context$path))
    stop("this addin cannot be run with an unsaved document")

  # okay, we can run the addin
  shiny::runGadget(
    app    = renv_addins_embed_ui(),
    server = renv_addins_embed_server,
    viewer = shiny::dialogViewer(
      dialogName = "Embed Lockfile",
      width  = 400,
      height = 200
    )
  )
}



# aliases.R ------------------------------------------------------------------


# aliases used primarily for nicer / normalized text output
the$aliases <- list(
  bioc         = "Bioconductor",
  bioconductor = "Bioconductor",
  bitbucket    = "Bitbucket",
  cellar       = "Cellar",
  cran         = "CRAN",
  git2r        = "Git",
  github       = "GitHub",
  gitlab       = "GitLab",
  local        = "Local",
  repository   = "Repository",
  standard     = "Repository",
  url          = "URL",
  xgit         = "Git"
)

alias <- function(text) {
  the$aliases[[text]] %||% text
}


# archive.R ------------------------------------------------------------------


renv_archive_type <- function(archive) {

  ext <- fileext(archive)

  if (ext %in% c(".tgz", ".tar", ".tar.gz"))
    return("tar")
  else if (ext %in% c(".zip"))
    return("zip")
  else
    return("unknown")

}

renv_archive_list <- function(archive) {
  suppressWarnings(renv_archive_list_impl(archive))
}

renv_archive_list_impl <- function(archive) {

  switch(
    renv_archive_type(archive),
    tar = untar(archive, list = TRUE),
    zip = unzip(archive, list = TRUE)[["Name"]],
    stopf("don't know how to list files in archive '%s'", basename(archive))
  )

}

renv_archive_decompress <- function(archive, files = NULL, exdir = ".", ...) {

  switch(
    renv_archive_type(archive),
    tar = renv_archive_decompress_tar(archive, files = files, exdir = exdir, ...),
    zip = renv_archive_decompress_zip(archive, files = files, exdir = exdir, ...),
    stopf("don't know how to decompress archive '%s'", basename(archive))
  )

}

renv_archive_decompress_tar <- function(archive, files = NULL, exdir = ".", ...) {

  # if an appropriate system tar is available, use it
  tar <- renv_tar_exe()
  if (nzchar(tar))
    return(renv_tar_decompress(tar, archive = archive, files = files, exdir = exdir, ...))

  # when using internal TAR, we want to suppress warnings
  # (otherwise we get noise about global PAX headers)
  suppressWarnings(untar(archive, files = files, exdir = exdir, tar = "internal", ...))
  return(TRUE)

}

renv_archive_decompress_zip <- function(archive, files = NULL, exdir = ".", ...) {

  # the default unzip tool will give warnings rather than
  # errors if R was unable to extract from a zip archive
  status <- tryCatch(
    unzip(archive, files = files, exdir = exdir, ...),
    condition = identity
  )

  if (inherits(status, "condition")) {
    fmt <- "failed to decompress '%s' [%s]"
    stopf(fmt, basename(archive), conditionMessage(status))
  }

  TRUE

}

renv_archive_find <- function(archive, pattern) {
  files <- renv_archive_list(archive)
  grep(pattern, files, value = TRUE)
}

renv_archive_read <- function(archive, file) {

  type <- renv_archive_type(archive)
  case(
    type == "tar" ~ renv_archive_read_tar(archive, file),
    type == "zip" ~ renv_archive_read_zip(archive, file),
    ~ stopf("don't know how to read file from archive %s", renv_path_pretty(archive))
  )

}

renv_archive_read_tar <- function(archive, file) {

  # if an appropriate tar is available, use it
  tar <- renv_tar_exe()
  if (nzchar(tar)) {
    args <- c("xf", renv_shell_path(archive), "-O", renv_shell_path(file))
    return(renv_system_exec(tar, args, action = "reading file from archive"))
  }

  # create extraction directory
  exdir <- renv_scope_tempfile("renv-archive-")
  ensure_directory(exdir)

  # unpack the requested file
  suppressWarnings(untar(archive, files = file, exdir = exdir, tar = "internal"))

  # and read it
  archive <- file.path(exdir, file)
  readLines(archive, warn = FALSE)

}

renv_archive_read_zip <- function(archive, file) {
  renv_scope_tempdir()
  conn <- unz(archive, file, encoding = "native.enc")
  defer(close(conn))
  readLines(conn, warn = FALSE)
}


# autoload.R -----------------------------------------------------------------


#' Auto-load the active project
#'
#' Automatically load the renv project associated with a particular directory.
#' renv will search parent directories for the renv project root; if found,
#' that project will be loaded via [renv::load()].
#'
#' To enable the renv auto-loader, you can place:
#'
#' ```
#' renv::autoload()
#' ````
#'
#' into your site-wide or user `.Rprofile` to ensure that renv projects are
#' automatically loaded for any newly-launched \R sessions, even if those \R
#' sessions are launched within the sub-directory of an renv project.
#'
#' If you'd like to launch \R within the sub-directory of an renv project
#' without auto-loading renv, you can set the environment variable:
#'
#' ```
#' RENV_AUTOLOAD_ENABLED = FALSE
#' ```
#'
#' before starting \R.
#'
#' Note that `renv::autoload()` is only compatible with projects using
#' `renv 0.15.3` or newer, as it relies on features within the `renv/activate.R`
#' script that are only generated with newer versions of renv.
#'
#' @export
autoload <- function() {
  invisible(renv_autoload_impl())
}

renv_autoload_impl <- function() {

  # check if we're disabled
  enabled <- Sys.getenv("RENV_AUTOLOAD_ENABLED", unset = "TRUE")
  if (!truthy(enabled))
    return(FALSE)

  # bail if load is already being called
  if (the$load_running)
    return(FALSE)

  # avoid recursion
  running <- getOption("renv.autoload.running")
  if (identical(running, TRUE))
    return(FALSE)

  # set our flag
  renv_scope_options(renv.autoload.running = TRUE)

  # try to find a project
  project <- catch(renv_project_find())
  if (inherits(project, "error"))
    return(FALSE)

  # move to project directory
  renv_scope_wd(project)

  # if we have a project profile, source it
  profile <- file.path(project, ".Rprofile")
  if (file.exists(profile)) {
    sys.source(profile, envir = globalenv())
    return(TRUE)
  }

  # if we have an activate script, run it
  activate <- file.path(project, "renv/activate.R")
  if (file.exists(activate)) {
    sys.source(activate, envir = globalenv())
    return(TRUE)
  }

  # otherwise, just try to load the project
  load(project)
  TRUE

}


# available-packages.R -------------------------------------------------------


# tools for querying information about packages available on CRAN.
# note that this does _not_ merge package entries from multiple repositories;
# rather, a list of databases is returned (one for each repository)
available_packages <- function(type,
                               repos = NULL,
                               limit = NULL,
                               quiet = FALSE,
                               cellar = FALSE)
{
  dynamic(

    key = list(
      type = type,
      repos = repos %||% getOption("repos"),
      cellar = cellar
    ),

    value = renv_available_packages_impl(
      type   = type,
      repos  = repos,
      limit  = limit,
      quiet  = quiet,
      cellar = cellar
    )

  )
}

renv_available_packages_impl <- function(type,
                                         repos = NULL,
                                         limit = NULL,
                                         quiet = FALSE,
                                         cellar = FALSE)
{
  limit <- limit %||% Sys.getenv("R_AVAILABLE_PACKAGES_CACHE_CONTROL_MAX_AGE", "3600")
  repos <- renv_repos_normalize(repos %||% getOption("repos"))

  # invalidate cache if http_proxy or https_proxy environment variables change,
  # since those could effect (or even re-direct?) repository URLs
  envkeys <- c("http_proxy", "https_proxy", "HTTP_PROXY", "HTTPS_PROXY")
  envvals <- Sys.getenv(envkeys, unset = NA)

  # invalidate the cache if 'renv.download.headers' changes as well
  headers <- getOption("renv.download.headers")
  key <- list(repos = repos, type = type, headers = headers, envvals)

  # retrieve available packages
  dbs <- if (length(repos)) index(
    scope = "available-packages",
    key   = key,
    value = renv_available_packages_query(type, repos, quiet),
    limit = as.integer(limit)
  )

  # include cellar if requested
  dbs[["__renv_cellar__"]] <- if (cellar)
    renv_available_packages_cellar(type = type)

  dbs

}

renv_available_packages_query <- function(type, repos, quiet = FALSE) {

  if (quiet)
    renv_scope_options(renv.verbose = FALSE)

  fmt <- "- Querying repositories for available %s packages ... "
  printf(fmt, type)

  # exclude repositories which are known to not have packages available
  if (type == "binary") {
    ignored <- setdiff(grep("^BioC", names(repos), value = TRUE), "BioCsoft")
    repos <- repos[setdiff(names(repos), ignored)]
  }

  # request repositories
  urls <- contrib.url(repos, type)
  errors <- new.env(parent = emptyenv())
  dbs <- map(urls, renv_available_packages_query_impl, type = type, errors = errors)
  names(dbs) <- names(repos)

  # notify finished
  writef("Done!")

  # propagate errors
  errors <- as.list(errors)
  if (empty(errors))
    return(dbs)

  header <- "renv was unable to query available packages from the following repositories:"
  msgs <- enum_chr(errors, function(url, cnds) {
    msgs <- map_chr(cnds, conditionMessage)
    paste(c(header(url), msgs, ""), collapse = "\n")
  })

  caution_bullets(header, msgs)
  filter(dbs, Negate(is.null))

}

renv_available_packages_query_impl_packages_rds <- function(url) {
  path <- file.path(url, "PACKAGES.rds")
  destfile <- renv_scope_tempfile("renv-packages-", fileext = ".rds")

  download(url = path, destfile = destfile, quiet = TRUE)
  suppressWarnings(readRDS(destfile))
}

renv_available_packages_query_impl_packages_gz <- function(url) {
  path <- file.path(url, "PACKAGES.gz")
  destfile <- renv_scope_tempfile("renv-packages-", fileext = ".gz")

  download(url = path, destfile = destfile, quiet = TRUE)
  suppressWarnings(read.dcf(destfile))
}

renv_available_packages_query_impl_packages <- function(url) {
  path <- file.path(url, "PACKAGES")
  destfile <- renv_scope_tempfile("renv-packages-")

  download(url = path, destfile = destfile, quiet = TRUE)
  suppressWarnings(read.dcf(destfile))
}

renv_available_packages_query_impl <- function(url, type, errors) {

  # define query_impl methods for the different PACKAGES
  methods <- list(
    renv_available_packages_query_impl_packages_rds,
    renv_available_packages_query_impl_packages_gz,
    renv_available_packages_query_impl_packages
  )

  stack <- stack()
  seize <- function(restart) {
    function(condition) {
      stack$push(condition)
      invokeRestart(restart)
    }
  }

  for (method in methods) {

    db <- withCallingHandlers(
      catch(method(url)),
      warning = seize(restart = "muffleWarning"),
      message = seize(restart = "muffleMessage")
    )

    if (inherits(db, "error")) {
      stack$push(db)
      next
    }

    return(renv_available_packages_success(db, url, type))

  }

  assign(url, stack$data(), envir = errors)
  NULL

}

renv_available_packages_success <- function(db, url, type) {

  # convert to data.frame
  db <- as_data_frame(db)
  if (nrow(db) == 0L)
    return(db)

  # build repository url
  repository <- rep.int(url, nrow(db))

  # update with path
  path <- db$Path
  if (length(path)) {
    set <- !is.na(path)
    repository[set] <- paste(url, path[set], sep = "/")
  }

  # set it
  db$Repository <- repository

  # add in necessary missing columns
  required <- c(
    "Package", "Version", "Priority",
    "Depends", "Imports", "LinkingTo", "Suggests", "Enhances",
    "License", "License_is_FOSS", "License_restricts_use",
    "OS_type", "Archs", "MD5sum",
    if (type %in% "source") "NeedsCompilation",
    "File", "Repository"
  )

  missing <- setdiff(required, names(db))
  db[missing] <- NA_character_
  db <- db[required]

  # filter as appropriate
  db <- renv_available_packages_filter(db)

  # remove row names
  row.names(db) <- NULL

  # ok
  db

}

renv_available_packages_entry <- function(package,
                                          type   = "source",
                                          repos  = NULL,
                                          filter = NULL,
                                          quiet  = FALSE,
                                          prefer = NULL)
{

  # if filter is a string, treat it as an explicit version requirement
  version <- NULL
  if (is.character(filter)) {
    version <- filter
    filter <- function(entries) {
      matches <- which(entries$Version == version)
      candidate <- head(matches, n = 1L)
      entries[candidate, ]
    }
  }

  # by default, provide a filter that selects the newest-available package
  filter <- filter %||% function(entries) {
    version <- numeric_version(entries$Version)
    ordered <- order(version, decreasing = TRUE)
    entries[ordered[[1]], ]
  }

  # read available packages
  dbs <- available_packages(
    type  = type,
    repos = repos,
    quiet = quiet
  )

  # if a preferred repository is marked and available, prefer using that
  if (length(prefer) == 1L && prefer %in% names(dbs)) {
    idx <- match(prefer, names(dbs))
    ord <- c(idx, setdiff(seq_along(dbs), idx))
    dbs <- dbs[ord]
  }

  # iterate through repositories, and find first matching
  for (i in seq_along(dbs)) {

    db <- dbs[[i]]
    matches <- which(db$Package == package)
    if (empty(matches))
      next

    entries <- db[matches, ]
    entry <- filter(entries)
    if (nrow(entry) == 0)
      next

    entry[["Type"]] <- type
    entry[["Name"]] <- names(dbs)[[i]] %||% ""
    return(entry)

  }

  # report package + version if both available
  pkgver <- if (length(version))
    paste(package, version)
  else
    package

  fmt <- "failed to find %s for '%s' in package repositories"
  stopf(fmt, type, pkgver)

}

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)))
    return(entry)

  # otherwise, construct it
  record <- entry

  if (identical(record$Name, "__renv_cellar__")) {
    record$Source     <- "Cellar"
    record$Repository <- NULL
    record$Name       <- NULL
  } else {
    record$Source     <- "Repository"
    record$Repository <- entry$Name
    record$Name       <- NULL
  }

  # form url
  url <- entry$Repository
  path <- entry$Path
  if (length(path) && !is.na(path))
    url <- paste(url, path, sep = "/")

  attr(record, "type") <- type
  attr(record, "url")  <- url

  record

}

renv_available_packages_latest_repos_impl <- function(package, type, repos) {

  # get available packages
  dbs <- available_packages(
    type   = type,
    repos  = repos,
    quiet  = TRUE,
    cellar = TRUE
  )

  fields <- c(
    "Package", "Version",
    "OS_type", "NeedsCompilation",
    "Repository", "Path", "File"
  )

  entries <- bapply(dbs, function(db) {

    # extract entries for this package
    entries <- rows(db, db$Package == package)
    if (nrow(entries) == 0L)
      return(entries)

    # keep only compatible rows + the required fields
    cols(entries, intersect(fields, names(db)))

  }, index = "Name")

  if (is.null(entries))
    return(NULL)

  # sort based on version
  version <- numeric_version(entries$Version)
  ordered <- order(version, decreasing = TRUE)

  # extract newest entry
  entry <- as.list(entries[ordered[[1L]], ])

  # remove an NA file entry if necessary
  # https://github.com/rstudio/renv/issues/1045
  if (length(entry$File) && is.na(entry$File))
    entry$File <- NULL

  # return newest-available version
  renv_available_packages_record(entry, type)

}

renv_available_packages_latest <- function(package,
                                           type = NULL,
                                           repos = NULL)
{
  methods <- list(
    renv_available_packages_latest_repos,
    if (renv_mran_enabled())
      renv_available_packages_latest_mran
  )

  errors <- stack()

  entries <- lapply(methods, function(method) {

    if (is.null(method))
      return(NULL)

    entry <- catch(method(package, type, repos))
    if (inherits(entry, "error")) {
      errors$push(entry)
      return(NULL)
    }

    entry

  })

  # if both entries are null, error
  if (all(map_lgl(entries, is.null))) {
    map(errors$data(), warning)
    stopf("package '%s' is not available", package)
  } else if (is.null(entries[[2L]])) {
    return(entries[[1L]])
  } else if (is.null(entries[[1L]])) {
    return(entries[[2L]])
  }

  # extract both entries
  lhs <- entries[[1L]]
  rhs <- entries[[2L]]

  # extract versions
  lhsv <- package_version(lhs$Version %||% "0.0")
  rhsv <- package_version(rhs$Version %||% "0.0")

  # if the versions don't match, take the newest one
  if (lhsv > rhsv)
    return(lhs)
  else if (rhsv > lhsv)
    return(rhs)

  # otherwise, if we have a binary from the active package repositories,
  # use those; otherwise, use the mran binary
  if (identical(lhsv, rhsv)) {
    if (identical(attr(lhs, "type", exact = TRUE), "binary"))
      return(lhs)
    else
      return(rhs)
  }

  # otherwise, return the regular repository entry
  lhs

}

renv_available_packages_latest_mran <- 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")

  # ensure local MRAN database is up-to-date
  renv_mran_database_refresh(explicit = FALSE)

  # attempt to read it
  database <- catch(renv_mran_database_load())
  if (inherits(database, "error"))
    return(database)

  # get entry for this version of R + platform
  suffix <- contrib.url("", type = "binary")
  entry <- database[[suffix]]
  if (is.null(entry))
    stopf("no MRAN 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)

  # take the latest-available package
  entries <- unlist(mget(matching, envir = entry))
  sorted <- sort(entries, decreasing = TRUE)
  key <- names(sorted)[[1L]]
  idate <- sorted[[1L]]

  # split into package, version
  index <- regexpr(" ", key, fixed = TRUE)
  version <- substring(key, index + 1)

  # return an appropriate record
  record <- list(
    Package    = package,
    Version    = version,
    Source     = "Repository",
    Repository = "MRAN"
  )

  # convert from integer to date
  date <- as.Date(idate, origin = "1970-01-01")

  # form url to binary package
  base <- renv_mran_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"

  record
}

renv_available_packages_latest_repos <- function(package,
                                                 type = NULL,
                                                 repos = NULL)
{
  type  <- type %||% getOption("pkgType")
  repos <- repos %||% getOption("repos")

  # detect requests for only source packages
  if (identical(type, "source"))
    return(renv_available_packages_latest_repos_impl(package, "source", repos))

  # detect requests for only binary packages
  if (grepl("\\bbinary\\b", type))
    return(renv_available_packages_latest_repos_impl(package, "binary", repos))

  # otherwise, check both source and binary repositories
  src <- renv_available_packages_latest_repos_impl(package, "source", repos)
  bin <- renv_available_packages_latest_repos_impl(package, "binary", repos)

  # choose an appropriate record
  if (is.null(src) && is.null(bin))
    stopf("package '%s' is not available", package)
  else if (is.null(src))
    renv_available_packages_record(bin, "binary")
  else if (is.null(bin))
    renv_available_packages_record(src, "source")
  else
    renv_available_packages_latest_select(src, bin)
}

renv_available_packages_latest_select <- function(src, bin) {

  # if the binary is at least as old as the source version,
  # then use the binary version
  if (renv_version_compare(bin$Version, src$Version) >= 0)
    return(renv_available_packages_record(bin, "binary"))

  # if the user has requested we skip source repositories,
  # use the binary anyway
  ipcs <- getOption("install.packages.check.source", default = "yes")
  if (!identical(ipcs, "yes"))
    return(renv_available_packages_record(bin, "binary"))

  # if the package requires compilation, check to see whether
  # the user has opted in to compiling packages from source
  nc <- identical(src$NeedsCompilation, "yes")
  if (nc) {

    # check user preference re: compilation from source
    ipcfs <- getOption(
      "install.packages.compile.from.source",
      default = Sys.getenv("R_COMPILE_AND_INSTALL_PACKAGES")
    )

    # if make is not available, then we can't build from source
    make <- Sys.getenv("MAKE", unset = "make")
    if (!nzchar(Sys.which(make)))
      ipcfs <- "never"

    # if we're on macOS and command line tools are not available,
    # then we can't build from sources
    if (renv_platform_macos() && !renv_xcode_available())
      ipcfs <- "never"

    if (identical(ipcfs, "never"))
      return(renv_available_packages_record(bin, "binary"))

  }

  # take the source version
  renv_available_packages_record(src, "source")

}

renv_available_packages_cellar <- function(type, project = NULL) {

  # look in the cellar
  project <- renv_project_resolve(project)
  roots <- renv_cellar_roots(project = project)

  # look for packages
  all <- list.files(
    path         = roots,
    all.files    = TRUE,
    full.names   = TRUE,
    recursive    = TRUE,
    include.dirs = FALSE
  )

  # keep only files with matching extensions
  ext <- renv_package_ext(type = type)
  keep <- all[fileext(all) %in% ext]

  # construct records for each cellar entry
  records <- lapply(keep, function(path) {

    # infer package name, version from tarball name
    base <- basename(keep)
    idx <- regexpr("_", base, fixed = TRUE)
    package <- substring(base, 1L, idx - 1L)
    version <- substring(base, idx + 1L, nchar(base) - nchar(ext))

    # set the Repository field
    prefix <- if (renv_platform_windows()) "file:///" else "file://"
    repository <- paste0(prefix, dirname(path))

    # build record
    list(
      Package = package,
      Version = version,
      Repository = repository
    )

  })

  bind(records)

}

renv_available_packages_filter <- function(db) {

  # sanity check
  if (is.null(db) || nrow(db) == 0L)
    return(db)

  # TODO: subarch? duplicates?
  # remove packages which won't work on this OS
  db <- renv_available_packages_filter_ostype(db)
  db <- renv_available_packages_filter_version(db)

  # return filtered database
  db

}

renv_available_packages_filter_ostype <- function(db) {
  ostype <- db$OS_type
  ok <- is.na(ostype) | ostype %in% .Platform$OS.type
  rows(db, ok)
}

renv_available_packages_filter_version <- function(db) {

  depends <- db$Depends

  # find the packages which express an R dependency
  splat <- strsplit(depends, "\\s*,\\s*", perl = TRUE)

  # remove the non-R dependencies
  table <- c("R ", "R\n", "R(")
  splat <- map(splat, function(requirements) {
    requirements[match(substr(requirements, 1L, 2L), table, 0L) != 0L]
  })

  # collect the unique R dependencies
  dependencies <- unique(unlist(splat))

  # convert this to a simpler form
  pattern <- "^R\\s*\\(([^\\d\\s+]+)\\s*([^\\)]+)\\)$"
  matches <- gsub(pattern, "\\1 \\2", dependencies, perl = TRUE)

  # split into operator and version
  idx <- regexpr(" ", matches, fixed = TRUE)
  ops <- substring(matches, 1L, idx - 1L)
  version <- numeric_version(substring(matches, idx + 1L))

  # bundle the calls for efficiency
  ok <- rep.int(NA, length(ops))
  names(ok) <- dependencies

  # iterate over the operations, and update our vector
  rversion <- getRversion()
  for (op in unique(ops)) {
    idx <- ops == op
    ok[idx] <- do.call(op, list(rversion, version[idx]))
  }

  # now, map the names back to their computed values, and check whether
  # all requirements were satisfied
  ok <- map_lgl(splat, function(requirements) {
    all(ok[requirements])
  })

  rows(db, ok)

}

# flattens available packages, keeping only the newest version
renv_available_packages_flatten <- function(dbs) {

  # stack the databases together
  stacked <- bind(dbs)

  # order by package + version
  # TODO: 'order()' is kind of slow for numeric versions; can we do better?
  index <- with(stacked, order(Package, numeric_version(Version), decreasing = TRUE))
  ordered <- rows(stacked, index)

  # remove duplicates
  dupes <- duplicated(ordered$Package)
  filtered <- rows(ordered, !dupes)

  # ready to return
  filtered

}


# backports.R ----------------------------------------------------------------


if (is.null(.BaseNamespaceEnv$lengths)) {

  lengths <- function(x, use.names = TRUE) {
    vapply(x, length, numeric(1), USE.NAMES = use.names)
  }

}


# base64.R -------------------------------------------------------------------


the$base64_table <- as.integer(charToRaw("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="))

renv_base64_encode_main <- function(input) {

  ni <- as.integer(length(input))
  if (ni < 3L)
    return(integer())

  no <- ni %/% 3L * 4L
  output <- integer(no)

  i0 <- seq.int(1L, ni - 2L, by = 3L)
  i1 <- seq.int(2L, ni - 1L, by = 3L)
  i2 <- seq.int(3L, ni - 0L, by = 3L)

  o0 <- seq.int(1L, no - 3L, by = 4L)
  o1 <- seq.int(2L, no - 2L, by = 4L)
  o2 <- seq.int(3L, no - 1L, by = 4L)
  o3 <- seq.int(4L, no - 0L, by = 4L)

  output[o0] <- the$base64_table[1L + bitwShiftR(input[i0], 2L)]

  output[o1] <- the$base64_table[1L + bitwOr(
    bitwShiftL(bitwAnd(input[i0], 0x03L), 4L),
    bitwShiftR(bitwAnd(input[i1], 0xF0L), 4L)
  )]

  output[o2] <- the$base64_table[1L + bitwOr(
    bitwShiftL(bitwAnd(input[i1], 0x0FL), 2L),
    bitwShiftR(bitwAnd(input[i2], 0xC0L), 6L)
  )]

  output[o3] <- the$base64_table[1L + bitwAnd(input[i2], 0x3FL)]

  output

}

renv_base64_encode_rest <- function(input) {

  ni <- as.integer(length(input))
  remaining <- ni %% 3L
  if (remaining == 0L)
    return(integer())

  output <- rep.int(61L, 4L)
  i <- ni - remaining + 1

  output[1L] <- the$base64_table[1L + bitwShiftR(input[i + 0L], 2L)]

  if (remaining == 1L) {

    output[2L] <- the$base64_table[1L + bitwShiftL(bitwAnd(input[i + 0L], 0x03L), 4L)]

  } else if (remaining == 2L) {

    output[2L] <- the$base64_table[1L + bitwOr(
      bitwShiftL(bitwAnd(input[i + 0L], 0x03L), 4L),
      bitwShiftR(bitwAnd(input[i + 1L], 0xF0L), 4L)
    )]

    output[3L] <- the$base64_table[1L + bitwShiftL(bitwAnd(input[i + 1L], 0x0FL), 2L)]

  }

  output

}

renv_base64_encode <- function(text) {

  # convert to raw vector
  input <- case(
    is.character(text) ~ as.integer(charToRaw(text)),
    is.raw(text)       ~ as.integer(text),
    ~ stopf("unexpected input type '%s'", typeof(text))
  )

  encoded <- c(
    renv_base64_encode_main(input),
    renv_base64_encode_rest(input)
  )

  rawToChar(as.raw(encoded))

}

the$base64_decode_table <- NULL
renv_base64_decode_table <- function() {
  the$base64_decode_table <- the$base64_decode_table %||% {
    table <- integer(255)
    text <- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/="
    table[utf8ToInt(text)] <- seq_len(nchar(text)) - 1L
    table
  }
}

renv_base64_decode_main <- function(input) {

  ni <- length(input)
  no <- (ni * 3L) %/% 4L

  output <- integer(no)

  i0 <- seq(from = 1L, to = ni - 3L, by = 4L)
  i1 <- seq(from = 2L, to = ni - 2L, by = 4L)
  i2 <- seq(from = 3L, to = ni - 1L, by = 4L)
  i3 <- seq(from = 4L, to = ni - 0L, by = 4L)

  o0 <- seq.int(1L, no - 2L, by = 3L)
  o1 <- seq.int(2L, no - 1L, by = 3L)
  o2 <- seq.int(3L, no - 0L, by = 3L)

  t <- renv_base64_decode_table()

  output[o0] <- bitwOr(
    bitwAnd(bitwShiftL(t[input[i0]], 2L), 255L),
    bitwAnd(bitwShiftR(t[input[i1]], 4L), 255L)
  )

  output[o1] <- bitwOr(
    bitwAnd(bitwShiftL(t[input[i1]], 4L), 255L),
    bitwAnd(bitwShiftR(t[input[i2]], 2L), 255L)
  )

  output[o2] <- bitwOr(
    bitwAnd(bitwShiftL(t[input[i2]], 6L), 255L),
    bitwAnd(bitwShiftR(t[input[i3]], 0L), 255L)
  )

  output

}

renv_base64_decode <- function(encoded) {

  # remove newlines
  if (c(regexpr("\n", encoded, fixed = TRUE)) != -1L)
    encoded <- gsub("\n", "", encoded, fixed = TRUE)

  # convert to raw vector
  input <- case(
    is.character(encoded) ~ as.integer(charToRaw(encoded)),
    is.raw(encoded)       ~ as.integer(encoded),
    ~ stopf("unexpected input type '%s'", typeof(encoded))
  )

  # decode vector
  output <- renv_base64_decode_main(input)

  # trim off padded bits
  n <- length(input)
  if (input[n - 1L] == 61L)
    output <- head(output, n = -2L)
  else if (input[n] == 61L)
    output <- head(output, n = -1L)

  # convert back to string
  rawToChar(as.raw(output))

}


# bind.R ---------------------------------------------------------------------


bind <- function(data, names = NULL, index = "Index") {

  # keep only non-empty data
  data <- Filter(NROW, data)
  if (!length(data))
    return(NULL)

  # check for quick exit
  if (length(data) == 1L) {

    # no-name case
    if (is.null(names(data))) {
      rhs <- data[[1L]]
      names(rhs) <- names(rhs) %||% names
      return(as_data_frame(rhs))
    }

    # named case
    lhs <- list(rep.int(names(data), times = NROW(data[[1L]])))
    names(lhs) <- index
    rhs <- as.list(data[[1L]])
    return(as_data_frame(c(lhs, rhs)))

  }

  # ensure all datasets have the same column names
  # try to preserve the ordering of names if possible
  # (try to find one dataset which has all column relevant column names)
  nms <- character()
  for (i in seq_along(data)) {
    names(data[[i]]) <- names(data[[i]]) %||% names
    nmsi <- names(data[[i]])
    if (length(nmsi) > length(nms))
      nms <- nmsi
  }

  # check now if we've caught all relevant names; if we didn't,
  # just fall back to a "dumb" union
  allnms <- unique.default(unlist(lapply(data, names), use.names = FALSE))
  if (!setequal(nms, allnms))
    nms <- allnms

  # we've collected all names; now fill with NAs as necessary
  filled <- map(data, function(datum) {
    datum[setdiff(nms, names(datum))] <- NA
    datum[nms]
  })

  # we've collected and ordered each data.frame, now merge them
  rhs <- .mapply(c, filled, list(use.names = FALSE))
  names(rhs) <- names(filled[[1L]])

  if (is.null(names(data))) {
    names(rhs) <- names(rhs) %||% names
    return(as_data_frame(rhs))
  }

  if (index %in% names(rhs)) {
    fmt <- "name collision: bound list already contains column called '%s'"
    stopf(fmt, index)
  }

  lhs <- list()
  rows <- function(item) nrow(item) %||% length(item[[1L]])
  lhs[[index]] <- rep.int(names(filled), times = map_dbl(filled, rows))

  as_data_frame(c(lhs, rhs))

}







# binding.R ------------------------------------------------------------------


renv_binding_lock <- function(envir, symbol) {
  .BaseNamespaceEnv$lockBinding(symbol, envir)
}

renv_binding_locked <- function(envir, symbol) {
  .BaseNamespaceEnv$bindingIsLocked(symbol, envir)
}

renv_binding_unlock <- function(envir, symbol) {
  .BaseNamespaceEnv$unlockBinding(symbol, envir)
}

renv_binding_replace <- function(envir, symbol, replacement) {

  # get the original definition
  original <- envir[[symbol]]

  # if the binding is locked, temporarily unlock it
  if (renv_binding_locked(envir, symbol)) {
    defer(renv_binding_lock(envir, symbol))
    renv_binding_unlock(envir, symbol)
  }

  # update the binding
  assign(symbol, replacement, envir = envir)

  # return old definition
  original

}


# bioconductor.R -------------------------------------------------------------


renv_bioconductor_manager <- function() {
  if (getRversion() >= "3.5.0")
    "BiocManager"
  else
    "BiocInstaller"
}

renv_bioconductor_init <- function(library = NULL) {
  renv_scope_options(renv.verbose = FALSE)

  if (identical(renv_bioconductor_manager(), "BiocManager"))
    renv_bioconductor_init_biocmanager(library)
  else
    renv_bioconductor_init_biocinstaller(library)
}

renv_bioconductor_init_biocmanager <- function(library = NULL) {

  library <- library %||% renv_libpaths_active()
  if (renv_package_installed("BiocManager", lib.loc = library))
    return(TRUE)

  ensure_directory(library)
  install("BiocManager", library = library)
  TRUE

}

renv_bioconductor_init_biocinstaller <- function(library = NULL) {

  library <- library %||% renv_libpaths_active()
  if (renv_package_installed("BiocInstaller", lib.loc = library))
    return(TRUE)

  url <- "https://bioconductor.org/biocLite.R"
  destfile <- renv_scope_tempfile("renv-bioclite-", fileext = ".R")
  download(url, destfile = destfile, quiet = TRUE)

  ensure_directory(library)
  renv_scope_libpaths(library)
  source(destfile)
  TRUE

}

renv_bioconductor_version <- function(project, refresh = FALSE) {

  # check and see if we have an override via option
  version <- getOption("renv.bioconductor.version")
  if (!is.null(version))
    return(version)

  # check and see if the project has been configured to use a specific
  # Bioconductor release
  if (!refresh) {
    version <- settings$bioconductor.version(project = project)
    if (length(version))
      return(version)
  }

  # if BiocVersion is installed, use it
  if (renv_package_available("BiocVersion"))
    return(format(packageVersion("BiocVersion")[1, 1:2]))

  # make sure the required bioc package is available
  renv_bioconductor_init()

  # otherwise, infer the Bioconductor version from installed packages
  case(

    renv_package_available("BiocManager") ~ {
      BiocManager <- renv_scope_biocmanager()
      format(BiocManager$version())
    },

    renv_package_available("BiocVersion") ~ {
      BiocInstaller <- renv_namespace_load("BiocInstaller")
      format(BiocInstaller$biocVersion())
    }

  )

}

# Returns the union of the inferred Bioconductor repositories, together with the
# current value of the 'repos' R option. The Bioconductor repositories are
# placed first in the repository list.
renv_bioconductor_repos <- function(project = NULL, version = NULL) {

  # allow bioconductor repos override
  repos <- getOption("renv.bioconductor.repos")
  if (!is.null(repos))
    return(repos)

  # make sure the required bioc package is available
  renv_bioconductor_init()

  # read Bioconductor version (normally set during restore)
  version <- version %||% renv_bioconductor_version(project = project)

  # read Bioconductor repositories (prefer BiocInstaller for older R)
  if (identical(renv_bioconductor_manager(), "BiocManager"))
    renv_bioconductor_repos_biocmanager(version)
  else
    renv_bioconductor_repos_biocinstaller(version)

}

renv_bioconductor_repos_biocmanager <- function(version) {

  BiocManager <- renv_scope_biocmanager()
  version <- version %||% BiocManager$version()

  tryCatch(
    BiocManager$.repositories(site_repository = character(), version = version),
    error = function(e) {
      BiocManager$repositories(version = version)
    }
  )

}

renv_bioconductor_repos_biocinstaller <- function(version) {
  BiocInstaller <- asNamespace("BiocInstaller")
  version <- version %||% BiocInstaller$biocVersion()
  BiocInstaller$biocinstallRepos(version = version)
}

renv_bioconductor_required <- function(records) {

  for (record in records)
    if (identical(record$Source, "Bioconductor"))
      return(TRUE)

  FALSE

}


# bootstrap.R ----------------------------------------------------------------


`%||%` <- function(x, y) {
  if (is.null(x)) y else x
}

catf <- function(fmt, ..., appendLF = TRUE) {

  quiet <- getOption("renv.bootstrap.quiet", default = FALSE)
  if (quiet)
    return(invisible())

  msg <- sprintf(fmt, ...)
  cat(msg, file = stdout(), sep = if (appendLF) "\n" else "")

  invisible(msg)

}

header <- function(label,
                   ...,
                   prefix = "#",
                   suffix = "-",
                   n = min(getOption("width"), 78))
{
  label <- sprintf(label, ...)
  n <- max(n - nchar(label) - nchar(prefix) - 2L, 8L)
  if (n <= 0)
    return(paste(prefix, label))

  tail <- paste(rep.int(suffix, n), collapse = "")
  paste0(prefix, " ", label, " ", tail)

}

startswith <- function(string, prefix) {
  substring(string, 1, nchar(prefix)) == prefix
}

bootstrap <- function(version, library) {

  friendly <- renv_bootstrap_version_friendly(version)
  section <- header(sprintf("Bootstrapping renv %s", friendly))
  catf(section)

  # attempt to download renv
  catf("- Downloading renv ... ", appendLF = FALSE)
  withCallingHandlers(
    tarball <- renv_bootstrap_download(version),
    error = function(err) {
      catf("FAILED")
      stop("failed to download:\n", conditionMessage(err))
    }
  )
  catf("OK")
  on.exit(unlink(tarball), add = TRUE)

  # now attempt to install
  catf("- Installing renv  ... ", appendLF = FALSE)
  withCallingHandlers(
    status <- renv_bootstrap_install(version, tarball, library),
    error = function(err) {
      catf("FAILED")
      stop("failed to install:\n", conditionMessage(err))
    }
  )
  catf("OK")

  # add empty line to break up bootstrapping from normal output
  catf("")

  return(invisible())
}

renv_bootstrap_tests_running <- function() {
  getOption("renv.tests.running", default = FALSE)
}

renv_bootstrap_repos <- function() {

  # get CRAN repository
  cran <- getOption("renv.repos.cran", "https://cloud.r-project.org")

  # check for repos override
  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)

    return(repos)

  }

  # check for lockfile repositories
  repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity)
  if (!inherits(repos, "error") && length(repos))
    return(repos)

  # retrieve current repos
  repos <- getOption("repos")

  # ensure @CRAN@ entries are resolved
  repos[repos == "@CRAN@"] <- cran

  # add in renv.bootstrap.repos if set
  default <- c(FALLBACK = "https://cloud.r-project.org")
  extra <- getOption("renv.bootstrap.repos", default = default)
  repos <- c(repos, extra)

  # remove duplicates that might've snuck in
  dupes <- duplicated(repos) | duplicated(names(repos))
  repos[!dupes]

}

renv_bootstrap_repos_lockfile <- function() {

  lockpath <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = "renv.lock")
  if (!file.exists(lockpath))
    return(NULL)

  lockfile <- tryCatch(renv_json_read(lockpath), error = identity)
  if (inherits(lockfile, "error")) {
    warning(lockfile)
    return(NULL)
  }

  repos <- lockfile$R$Repositories
  if (length(repos) == 0)
    return(NULL)

  keys <- vapply(repos, `[[`, "Name", FUN.VALUE = character(1))
  vals <- vapply(repos, `[[`, "URL", FUN.VALUE = character(1))
  names(vals) <- keys

  return(vals)

}

renv_bootstrap_download <- function(version) {

  sha <- attr(version, "sha", exact = TRUE)

  methods <- if (!is.null(sha)) {

    # attempting to bootstrap a development version of renv
    c(
      function() renv_bootstrap_download_tarball(sha),
      function() renv_bootstrap_download_github(sha)
    )

  } else {

    # attempting to bootstrap a release version of renv
    c(
      function() renv_bootstrap_download_tarball(version),
      function() renv_bootstrap_download_cran_latest(version),
      function() renv_bootstrap_download_cran_archive(version)
    )

  }

  for (method in methods) {
    path <- tryCatch(method(), error = identity)
    if (is.character(path) && file.exists(path))
      return(path)
  }

  stop("All download methods failed")

}

renv_bootstrap_download_impl <- function(url, destfile) {

  mode <- "wb"

  # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17715
  fixup <-
    Sys.info()[["sysname"]] == "Windows" &&
    substring(url, 1L, 5L) == "file:"

  if (fixup)
    mode <- "w+b"

  args <- list(
    url      = url,
    destfile = destfile,
    mode     = mode,
    quiet    = TRUE
  )

  if ("headers" %in% names(formals(utils::download.file)))
    args$headers <- renv_bootstrap_download_custom_headers(url)

  do.call(utils::download.file, args)

}

renv_bootstrap_download_custom_headers <- function(url) {

  headers <- getOption("renv.download.headers")
  if (is.null(headers))
    return(character())

  if (!is.function(headers))
    stopf("'renv.download.headers' is not a function")

  headers <- headers(url)
  if (length(headers) == 0L)
    return(character())

  if (is.list(headers))
    headers <- unlist(headers, recursive = FALSE, use.names = TRUE)

  ok <-
    is.character(headers) &&
    is.character(names(headers)) &&
    all(nzchar(names(headers)))

  if (!ok)
    stop("invocation of 'renv.download.headers' did not return a named character vector")

  headers

}

renv_bootstrap_download_cran_latest <- function(version) {

  spec <- renv_bootstrap_download_cran_latest_find(version)
  type  <- spec$type
  repos <- spec$repos

  baseurl <- utils::contrib.url(repos = repos, type = type)
  ext <- if (identical(type, "source"))
    ".tar.gz"
  else if (Sys.info()[["sysname"]] == "Windows")
    ".zip"
  else
    ".tgz"
  name <- sprintf("renv_%s%s", version, ext)
  url <- paste(baseurl, name, sep = "/")

  destfile <- file.path(tempdir(), name)
  status <- tryCatch(
    renv_bootstrap_download_impl(url, destfile),
    condition = identity
  )

  if (inherits(status, "condition"))
    return(FALSE)

  # report success and return
  destfile

}

renv_bootstrap_download_cran_latest_find <- function(version) {

  # check whether binaries are supported on this system
  binary <-
    getOption("renv.bootstrap.binary", default = TRUE) &&
    !identical(.Platform$pkgType, "source") &&
    !identical(getOption("pkgType"), "source") &&
    Sys.info()[["sysname"]] %in% c("Darwin", "Windows")

  types <- c(if (binary) "binary", "source")

  # iterate over types + repositories
  for (type in types) {
    for (repos in renv_bootstrap_repos()) {

      # retrieve package database
      db <- tryCatch(
        as.data.frame(
          utils::available.packages(type = type, repos = repos),
          stringsAsFactors = FALSE
        ),
        error = identity
      )

      if (inherits(db, "error"))
        next

      # check for compatible entry
      entry <- db[db$Package %in% "renv" & db$Version %in% version, ]
      if (nrow(entry) == 0)
        next

      # found it; return spec to caller
      spec <- list(entry = entry, type = type, repos = repos)
      return(spec)

    }
  }

  # if we got here, we failed to find renv
  fmt <- "renv %s is not available from your declared package repositories"
  stop(sprintf(fmt, version))

}

renv_bootstrap_download_cran_archive <- function(version) {

  name <- sprintf("renv_%s.tar.gz", version)
  repos <- renv_bootstrap_repos()
  urls <- file.path(repos, "src/contrib/Archive/renv", name)
  destfile <- file.path(tempdir(), name)

  for (url in urls) {

    status <- tryCatch(
      renv_bootstrap_download_impl(url, destfile),
      condition = identity
    )

    if (identical(status, 0L))
      return(destfile)

  }

  return(FALSE)

}

renv_bootstrap_download_tarball <- function(version) {

  # if the user has provided the path to a tarball via
  # an environment variable, then use it
  tarball <- Sys.getenv("RENV_BOOTSTRAP_TARBALL", unset = NA)
  if (is.na(tarball))
    return()

  # allow directories
  if (dir.exists(tarball)) {
    name <- sprintf("renv_%s.tar.gz", version)
    tarball <- file.path(tarball, name)
  }

  # bail if it doesn't exist
  if (!file.exists(tarball)) {

    # let the user know we weren't able to honour their request
    fmt <- "- RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist."
    msg <- sprintf(fmt, tarball)
    warning(msg)

    # bail
    return()

  }

  catf("- Using local tarball '%s'.", tarball)
  tarball

}

renv_bootstrap_download_github <- function(version) {

  enabled <- Sys.getenv("RENV_BOOTSTRAP_FROM_GITHUB", unset = "TRUE")
  if (!identical(enabled, "TRUE"))
    return(FALSE)

  # prepare download options
  pat <- Sys.getenv("GITHUB_PAT")
  if (nzchar(Sys.which("curl")) && nzchar(pat)) {
    fmt <- "--location --fail --header \"Authorization: token %s\""
    extra <- sprintf(fmt, pat)
    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)) {
    fmt <- "--header=\"Authorization: token %s\""
    extra <- sprintf(fmt, pat)
    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)
  }

  url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version)
  name <- sprintf("renv_%s.tar.gz", version)
  destfile <- file.path(tempdir(), name)

  status <- tryCatch(
    renv_bootstrap_download_impl(url, destfile),
    condition = identity
  )

  if (!identical(status, 0L))
    return(FALSE)

  renv_bootstrap_download_augment(destfile)

  return(destfile)

}

# Add Sha to DESCRIPTION. This is stop gap until #890, after which we
# can use renv::install() to fully capture metadata.
renv_bootstrap_download_augment <- function(destfile) {
  sha <- renv_bootstrap_git_extract_sha1_tar(destfile)
  if (is.null(sha)) {
    return()
  }

  # Untar
  tempdir <- tempfile("renv-github-")
  on.exit(unlink(tempdir, recursive = TRUE), add = TRUE)
  untar(destfile, exdir = tempdir)
  pkgdir <- dir(tempdir, full.names = TRUE)[[1]]

  # Modify description
  desc_path <- file.path(pkgdir, "DESCRIPTION")
  desc_lines <- readLines(desc_path)
  remotes_fields <- c(
    "RemoteType: github",
    "RemoteHost: api.github.com",
    "RemoteRepo: renv",
    "RemoteUsername: rstudio",
    "RemotePkgRef: rstudio/renv",
    paste("RemoteRef: ", sha),
    paste("RemoteSha: ", sha)
  )
  writeLines(c(desc_lines[desc_lines != ""], remotes_fields), con = desc_path)

  # Re-tar
  local({
    old <- setwd(tempdir)
    on.exit(setwd(old), add = TRUE)

    tar(destfile, compression = "gzip")
  })
  invisible()
}

# Extract the commit hash from a git archive. Git archives include the SHA1
# hash as the comment field of the tarball pax extended header
# (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html)
# For GitHub archives this should be the first header after the default one
# (512 byte) header.
renv_bootstrap_git_extract_sha1_tar <- function(bundle) {

  # open the bundle for reading
  # We use gzcon for everything because (from ?gzcon)
  # > Reading from a connection which does not supply a 'gzip' magic
  # > header is equivalent to reading from the original connection
  conn <- gzcon(file(bundle, open = "rb", raw = TRUE))
  on.exit(close(conn))

  # The default pax header is 512 bytes long and the first pax extended header
  # with the comment should be 51 bytes long
  # `52 comment=` (11 chars) + 40 byte SHA1 hash
  len <- 0x200 + 0x33
  res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len])

  if (grepl("^52 comment=", res)) {
    sub("52 comment=", "", res)
  } else {
    NULL
  }
}

renv_bootstrap_install <- function(version, tarball, library) {

  # attempt to install it into project library
  dir.create(library, showWarnings = FALSE, recursive = TRUE)
  output <- renv_bootstrap_install_impl(library, tarball)

  # check for successful install
  status <- attr(output, "status")
  if (is.null(status) || identical(status, 0L))
    return(status)

  # an error occurred; report it
  header <- "installation of renv failed"
  lines <- paste(rep.int("=", nchar(header)), collapse = "")
  text <- paste(c(header, lines, output), collapse = "\n")
  stop(text)

}

renv_bootstrap_install_impl <- function(library, tarball) {

  # invoke using system2 so we can capture and report output
  bin <- R.home("bin")
  exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R"
  R <- file.path(bin, exe)

  args <- c(
    "--vanilla", "CMD", "INSTALL", "--no-multiarch",
    "-l", shQuote(path.expand(library)),
    shQuote(path.expand(tarball))
  )

  system2(R, args, stdout = TRUE, stderr = TRUE)

}

renv_bootstrap_platform_prefix <- function() {

  # construct version prefix
  version <- paste(R.version$major, R.version$minor, sep = ".")
  prefix <- paste("R", numeric_version(version)[1, 1:2], sep = "-")

  # include SVN revision for development versions of R
  # (to avoid sharing platform-specific artefacts with released versions of R)
  devel <-
    identical(R.version[["status"]],   "Under development (unstable)") ||
    identical(R.version[["nickname"]], "Unsuffered Consequences")

  if (devel)
    prefix <- paste(prefix, R.version[["svn rev"]], sep = "-r")

  # build list of path components
  components <- c(prefix, R.version$platform)

  # include prefix if provided by user
  prefix <- renv_bootstrap_platform_prefix_impl()
  if (!is.na(prefix) && nzchar(prefix))
    components <- c(prefix, components)

  # build prefix
  paste(components, collapse = "/")

}

renv_bootstrap_platform_prefix_impl <- function() {

  # if an explicit prefix has been supplied, use it
  prefix <- Sys.getenv("RENV_PATHS_PREFIX", unset = NA)
  if (!is.na(prefix))
    return(prefix)

  # if the user has requested an automatic prefix, generate it
  auto <- Sys.getenv("RENV_PATHS_PREFIX_AUTO", unset = NA)
  if (auto %in% c("TRUE", "True", "true", "1"))
    return(renv_bootstrap_platform_prefix_auto())

  # empty string on failure
  ""

}

renv_bootstrap_platform_prefix_auto <- function() {

  prefix <- tryCatch(renv_bootstrap_platform_os(), error = identity)
  if (inherits(prefix, "error") || prefix %in% "unknown") {

    msg <- paste(
      "failed to infer current operating system",
      "please file a bug report at https://github.com/rstudio/renv/issues",
      sep = "; "
    )

    warning(msg)

  }

  prefix

}

renv_bootstrap_platform_os <- function() {

  sysinfo <- Sys.info()
  sysname <- sysinfo[["sysname"]]

  # handle Windows + macOS up front
  if (sysname == "Windows")
    return("windows")
  else if (sysname == "Darwin")
    return("macos")

  # check for os-release files
  for (file in c("/etc/os-release", "/usr/lib/os-release"))
    if (file.exists(file))
      return(renv_bootstrap_platform_os_via_os_release(file, sysinfo))

  # check for redhat-release files
  if (file.exists("/etc/redhat-release"))
    return(renv_bootstrap_platform_os_via_redhat_release())

  "unknown"

}

renv_bootstrap_platform_os_via_os_release <- function(file, sysinfo) {

  # read /etc/os-release
  release <- utils::read.table(
    file             = file,
    sep              = "=",
    quote            = c("\"", "'"),
    col.names        = c("Key", "Value"),
    comment.char     = "#",
    stringsAsFactors = FALSE
  )

  vars <- as.list(release$Value)
  names(vars) <- release$Key

  # get os name
  os <- tolower(sysinfo[["sysname"]])

  # read id
  id <- "unknown"
  for (field in c("ID", "ID_LIKE")) {
    if (field %in% names(vars) && nzchar(vars[[field]])) {
      id <- vars[[field]]
      break
    }
  }

  # read version
  version <- "unknown"
  for (field in c("UBUNTU_CODENAME", "VERSION_CODENAME", "VERSION_ID", "BUILD_ID")) {
    if (field %in% names(vars) && nzchar(vars[[field]])) {
      version <- vars[[field]]
      break
    }
  }

  # join together
  paste(c(os, id, version), collapse = "-")

}

renv_bootstrap_platform_os_via_redhat_release <- function() {

  # read /etc/redhat-release
  contents <- readLines("/etc/redhat-release", warn = FALSE)

  # infer id
  id <- if (grepl("centos", contents, ignore.case = TRUE))
    "centos"
  else if (grepl("redhat", contents, ignore.case = TRUE))
    "redhat"
  else
    "unknown"

  # try to find a version component (very hacky)
  version <- "unknown"

  parts <- strsplit(contents, "[[:space:]]")[[1L]]
  for (part in parts) {

    nv <- tryCatch(numeric_version(part), error = identity)
    if (inherits(nv, "error"))
      next

    version <- nv[1, 1]
    break

  }

  paste(c("linux", id, version), collapse = "-")

}

renv_bootstrap_library_root_name <- function(project) {

  # use project name as-is if requested
  asis <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT_ASIS", unset = "FALSE")
  if (asis)
    return(basename(project))

  # otherwise, disambiguate based on project's path
  id <- substring(renv_bootstrap_hash_text(project), 1L, 8L)
  paste(basename(project), id, sep = "-")

}

renv_bootstrap_library_root <- function(project) {

  prefix <- renv_bootstrap_profile_prefix()

  path <- Sys.getenv("RENV_PATHS_LIBRARY", unset = NA)
  if (!is.na(path))
    return(paste(c(path, prefix), collapse = "/"))

  path <- renv_bootstrap_library_root_impl(project)
  if (!is.null(path)) {
    name <- renv_bootstrap_library_root_name(project)
    return(paste(c(path, prefix, name), collapse = "/"))
  }

  renv_bootstrap_paths_renv("library", project = project)

}

renv_bootstrap_library_root_impl <- function(project) {

  root <- Sys.getenv("RENV_PATHS_LIBRARY_ROOT", unset = NA)
  if (!is.na(root))
    return(root)

  type <- renv_bootstrap_project_type(project)
  if (identical(type, "package")) {
    userdir <- renv_bootstrap_user_dir()
    return(file.path(userdir, "library"))
  }

}

renv_bootstrap_validate_version <- function(version, description = NULL) {

  # resolve description file
  #
  # avoid passing lib.loc to `packageDescription()` below, since R will
  # use the loaded version of the package by default anyhow. note that
  # this function should only be called after 'renv' is loaded
  # https://github.com/rstudio/renv/issues/1625
  description <- description %||% packageDescription("renv")

  # check whether requested version 'version' matches loaded version of renv
  sha <- attr(version, "sha", exact = TRUE)
  valid <- if (!is.null(sha))
    renv_bootstrap_validate_version_dev(sha, description)
  else
    renv_bootstrap_validate_version_release(version, description)

  if (valid)
    return(TRUE)

  # 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"]])) {
    paste("rstudio/renv", description[["RemoteSha"]], sep = "@")
  } else {
    paste("renv", description[["Version"]], sep = "@")
  }

  # display both loaded version + sha if available
  friendly <- renv_bootstrap_version_friendly(
    version = description[["Version"]],
    sha     = 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"
  )
  catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote)

  FALSE

}

renv_bootstrap_validate_version_dev <- function(version, description) {
  expected <- description[["RemoteSha"]]
  is.character(expected) && startswith(expected, version)
}

renv_bootstrap_validate_version_release <- function(version, description) {
  expected <- description[["Version"]]
  is.character(expected) && identical(expected, version)
}

renv_bootstrap_hash_text <- function(text) {

  hashfile <- tempfile("renv-hash-")
  on.exit(unlink(hashfile), add = TRUE)

  writeLines(text, con = hashfile)
  tools::md5sum(hashfile)

}

renv_bootstrap_load <- function(project, libpath, version) {

  # try to load renv from the project library
  if (!requireNamespace("renv", lib.loc = libpath, quietly = TRUE))
    return(FALSE)

  # warn if the version of renv loaded does not match
  renv_bootstrap_validate_version(version)

  # execute renv load hooks, if any
  hooks <- getHook("renv::autoload")
  for (hook in hooks)
    if (is.function(hook))
      tryCatch(hook(), error = warnify)

  # load the project
  renv::load(project)

  TRUE

}

renv_bootstrap_profile_load <- function(project) {

  # if RENV_PROFILE is already set, just use that
  profile <- Sys.getenv("RENV_PROFILE", unset = NA)
  if (!is.na(profile) && nzchar(profile))
    return(profile)

  # check for a profile file (nothing to do if it doesn't exist)
  path <- renv_bootstrap_paths_renv("profile", profile = FALSE, project = project)
  if (!file.exists(path))
    return(NULL)

  # read the profile, and set it if it exists
  contents <- readLines(path, warn = FALSE)
  if (length(contents) == 0L)
    return(NULL)

  # set RENV_PROFILE
  profile <- contents[[1L]]
  if (!profile %in% c("", "default"))
    Sys.setenv(RENV_PROFILE = profile)

  profile

}

renv_bootstrap_profile_prefix <- function() {
  profile <- renv_bootstrap_profile_get()
  if (!is.null(profile))
    return(file.path("profiles", profile, "renv"))
}

renv_bootstrap_profile_get <- function() {
  profile <- Sys.getenv("RENV_PROFILE", unset = "")
  renv_bootstrap_profile_normalize(profile)
}

renv_bootstrap_profile_set <- function(profile) {
  profile <- renv_bootstrap_profile_normalize(profile)
  if (is.null(profile))
    Sys.unsetenv("RENV_PROFILE")
  else
    Sys.setenv(RENV_PROFILE = profile)
}

renv_bootstrap_profile_normalize <- function(profile) {

  if (is.null(profile) || profile %in% c("", "default"))
    return(NULL)

  profile

}

renv_bootstrap_path_absolute <- function(path) {

  substr(path, 1L, 1L) %in% c("~", "/", "\\") || (
    substr(path, 1L, 1L) %in% c(letters, LETTERS) &&
    substr(path, 2L, 3L) %in% c(":/", ":\\")
  )

}

renv_bootstrap_paths_renv <- function(..., profile = TRUE, project = NULL) {
  renv <- Sys.getenv("RENV_PATHS_RENV", unset = "renv")
  root <- if (renv_bootstrap_path_absolute(renv)) NULL else project
  prefix <- if (profile) renv_bootstrap_profile_prefix()
  components <- c(root, renv, prefix, ...)
  paste(components, collapse = "/")
}

renv_bootstrap_project_type <- function(path) {

  descpath <- file.path(path, "DESCRIPTION")
  if (!file.exists(descpath))
    return("unknown")

  desc <- tryCatch(
    read.dcf(descpath, all = TRUE),
    error = identity
  )

  if (inherits(desc, "error"))
    return("unknown")

  type <- desc$Type
  if (!is.null(type))
    return(tolower(type))

  package <- desc$Package
  if (!is.null(package))
    return("package")

  "unknown"

}

renv_bootstrap_user_dir <- function() {
  dir <- renv_bootstrap_user_dir_impl()
  path.expand(chartr("\\", "/", dir))
}

renv_bootstrap_user_dir_impl <- function() {

  # use local override if set
  override <- getOption("renv.userdir.override")
  if (!is.null(override))
    return(override)

  # use R_user_dir if available
  tools <- asNamespace("tools")
  if (is.function(tools$R_user_dir))
    return(tools$R_user_dir("renv", "cache"))

  # try using our own backfill for older versions of R
  envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME")
  for (envvar in envvars) {
    root <- Sys.getenv(envvar, unset = NA)
    if (!is.na(root))
      return(file.path(root, "R/renv"))
  }

  # use platform-specific default fallbacks
  if (Sys.info()[["sysname"]] == "Windows")
    file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv")
  else if (Sys.info()[["sysname"]] == "Darwin")
    "~/Library/Caches/org.R-project.R/R/renv"
  else
    "~/.cache/R/renv"

}

renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) {
  sha <- sha %||% attr(version, "sha", exact = TRUE)
  parts <- c(version, sprintf(shafmt %||% " [sha: %s]", substring(sha, 1L, 7L)))
  paste(parts, collapse = "")
}

renv_bootstrap_exec <- function(project, libpath, version) {
  if (!renv_bootstrap_load(project, libpath, version))
    renv_bootstrap_run(version, libpath)
}

renv_bootstrap_run <- function(version, libpath) {

  # perform bootstrap
  bootstrap(version, libpath)

  # exit early if we're just testing bootstrap
  if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA)))
    return(TRUE)

  # try again to load
  if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
    return(renv::load(project = getwd()))
  }

  # failed to download or load renv; warn the user
  msg <- c(
    "Failed to find an renv installation: the project will not be loaded.",
    "Use `renv::activate()` to re-initialize the project."
  )

  warning(paste(msg, collapse = "\n"), call. = FALSE)

}


# 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_cache_version_previous <- function() {
  version <- renv_cache_version()
  number <- as.integer(substring(version, 2L))
  paste("v", number - 1L, sep = "")
}

# given a record, find a compatible version of that package in the cache,
# using a computed hash if available; if no hash is available, then try
# to match based on the package name + version
renv_cache_find <- function(record) {

  # validate required fields -- if any are missing, we can't use the cache
  required <- c("Package", "Version")
  missing <- renv_vector_diff(required, names(record))
  if (length(missing))
    return("")

  # if we have a hash, use it directly
  if (!is.null(record$Hash)) {

    # generate path to package installations in cache
    paths <- with(record, renv_paths_cache(Package, Version, Hash, Package))

    # if there are multiple cache entries, return the first existing one
    # if no entries exist, return path into first cache entry
    for (path in paths)
      if (file.exists(path))
        return(path)

    return(paths[[1L]])

  }

  # if the record doesn't have a hash, check to see if we can still locate a
  # compatible package version within the cache
  root <- with(record, renv_paths_cache(Package, Version))
  hashes <- list.files(root, full.names = TRUE)
  packages <- list.files(hashes, full.names = TRUE)

  # iterate over package paths, read DESCRIPTION, and look
  # for something compatible with the requested record
  for (package in packages) {

    # try to read the DESCRIPTION file
    dcf <- catch(as.list(renv_description_read(package)))
    if (inherits(dcf, "error"))
      next

    # if we're requesting an install from an R package repository,
    # and the cached package has a "Repository" field, then use it
    source <- renv_record_source(record)
    hasrepo <-
      source %in% c("cran", "repository") &&
      "Repository" %in% names(dcf)

    if (hasrepo)
      return(package)

    # check for compatible fields
    fields <- unique(c(
      renv_record_names(record, c("Package", "Version")),
      renv_record_names(dcf, c("Package", "Version"))
    ))

    # drop unnamed fields
    record <- record[nzchar(record)]
    dcf <- dcf[nzchar(dcf)]

    # check identical
    lhs <- keep(record, fields)
    rhs <- keep(dcf, fields)
    if (identical(lhs, rhs))
      return(package)

  }

  # failed; return "" as proxy for missing file
  ""

}

# given the path to a package's description file,
# compute the location it would be assigned if it
# were moved to the renv cache
renv_cache_path <- function(path) {
  record <- renv_description_read(path)
  record$Hash <- renv_hash_description(path)
  renv_cache_find(record)
}

renv_cache_path_components <- function(path) {

  data_frame(
    Package = renv_path_component(path, 1L),
    Hash    = renv_path_component(path, 2L),
    Version = renv_path_component(path, 3L)
  )

}

renv_cache_synchronize <- function(record, linkable = FALSE) {

  # construct path to package in library
  library <- renv_libpaths_active()
  path <- file.path(library, record$Package)
  if (!file.exists(path))
    return(FALSE)

  # bail if the package source is unknown
  # (packages with an unknown source are not cacheable)
  desc <- renv_description_read(path)
  source <- renv_snapshot_description_source(desc)
  if (identical(source, list(Source = "unknown")))
    return(FALSE)

  # bail if record not cacheable
  if (!renv_record_cacheable(record))
    return(FALSE)

  # if we don't have a hash, compute it now
  record$Hash <- record$Hash %||% renv_hash_description(path)

  # construct cache entry
  caches <- renv_cache_find(record)

  # try to synchronize
  copied <- FALSE
  for (cache in caches) {
    copied <- renv_cache_synchronize_impl(cache, record, linkable, path)
    if (copied)
      return(TRUE)
  }

  return(FALSE)

}

renv_cache_synchronize_impl <- function(cache, record, linkable, path) {

  # double-check we have a valid cache path
  if (!nzchar(cache))
    return(FALSE)

  # if our cache -> path link is already up to date, then nothing to do
  if (renv_file_same(cache, path))
    return(TRUE)

  # try to create the cache directory target
  # (catch errors due to permissions, etc)
  parent <- dirname(cache)
  status <- catchall(ensure_directory(parent))
  if (inherits(status, "error"))
    return(FALSE)

  # double-check that the cache is writable
  writable <- local({
    file <- renv_scope_tempfile("renv-tempfile-", tmpdir = parent)
    status <- catchall(file.create(file))
    file.exists(file)
  })

  if (!writable)
    return(FALSE)

  # obtain lock on the cache
  lockpath <- file.path(parent, ".cache.lock")
  renv_scope_lock(lockpath)

  # if we already have a cache entry, back it up
  restore <- renv_file_backup(cache)
  defer(restore())

  # copy package from source location into the cache
  if (linkable) {
    renv_cache_move(path, cache, overwrite = TRUE)
    renv_file_link(cache, path, overwrite = TRUE)
  } else {
    renv_cache_copy(path, cache, overwrite = TRUE)
  }

  if (renv_platform_unix()) {

    # 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
      )
    }

    # 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)

  }

  TRUE

}

renv_cache_list <- function(cache = NULL, packages = NULL) {
  caches <- cache %||% renv_paths_cache()
  paths <- map(caches, renv_cache_list_impl, packages = packages)
  unlist(paths, recursive = TRUE, use.names = FALSE)
}

renv_cache_list_impl <- function(cache, packages) {

  # paths to packages in the cache have the following format:
  #
  #    <package>/<version>/<hash>/<package>
  #
  # so find entries in the cache by listing files in each directory
  names <- file.path(cache, packages %||% list.files(cache))
  versions <- list.files(names, full.names = TRUE)
  hashes <- list.files(versions, full.names = TRUE)
  paths <- list.files(hashes, full.names = TRUE)

  # only keep paths that appear to be valid
  valid <- grep(renv_regexps_package_name(), basename(paths))
  paths[valid]

}

renv_cache_problems <- function(paths, reason) {

  data_frame(
    Package = renv_path_component(paths, 1L),
    Version = renv_path_component(paths, 3L),
    Path    = paths,
    Reason  = reason
  )

}

renv_cache_diagnose_corrupt_metadata <- function(paths, problems, verbose) {

  # check for missing metadata files
  metapaths <- file.path(paths, "Meta/package.rds")
  ok <- file.exists(metapaths)
  bad <- paths[!ok]

  if (length(bad)) {

    # nocov start
    if (verbose) {
      caution_bullets(
        "The following package(s) are missing 'Meta/package.rds':",
        renv_cache_format_path(bad),
        "These packages should be purged and reinstalled."
      )
    }
    # nocov end

    data <- renv_cache_problems(
      paths  = bad,
      reason = "'Meta/package.rds' does not exist"
    )

    problems$push(data)

  }

  # check for corrupt / unreadable metadata files
  ok <- map_lgl(metapaths, function(path) {
    rds <- catch(readRDS(path))
    !inherits(rds, "error")
  })

  bad <- paths[!ok]

  if (length(bad)) {

    # nocov start
    if (verbose) {
      caution_bullets(
        "The following package(s) have corrupt 'Meta/package.rds' files:",
        renv_cache_format_path(bad),
        "These packages should be purged and reinstalled."
      )
    }
    # nocov end

    data <- renv_cache_problems(
      paths  = bad,
      reason = "'Meta/package.rds' does not exist"
    )

    problems$push(data)

  }

  paths

}

renv_cache_diagnose_missing_descriptions <- function(paths, problems, verbose) {

  descpaths <- file.path(paths, "DESCRIPTION")
  exists <- file.exists(descpaths)
  bad <- paths[!exists]
  if (empty(bad))
    return(paths)

  # nocov start
  if (verbose) {
    caution_bullets(
      "The following packages are missing DESCRIPTION files in the cache:",
      renv_cache_format_path(bad),
      "These packages should be purged and reinstalled."
    )
  }
  # nocov end

  data <- renv_cache_problems(
    paths  = bad,
    reason = "'DESCRIPTION' file does not exist"
  )

  problems$push(data)
  paths[exists]

}

renv_cache_diagnose_bad_hash <- function(paths, problems, verbose) {

  expected <- map_chr(paths, renv_cache_path)
  wrong <- paths != expected & !file.exists(expected)
  if (!any(wrong))
    return(paths)

  # nocov start
  if (verbose) {

    lhs <- renv_cache_path_components(paths[wrong])
    rhs <- renv_cache_path_components(expected[wrong])

    fmt <- "%s %s [Hash: %s != %s]"
    entries <- sprintf(fmt, lhs$Package, lhs$Version, lhs$Hash, rhs$Hash)

    caution_bullets(
      "The following packages have incorrect hashes:",
      entries,
      "Consider using `renv::rehash()` to re-hash these packages."
    )
  }
  # nocov end

  data <- renv_cache_problems(
    paths  = paths[wrong],
    reason = "unexpected hash"
  )

  problems$push(data)
  paths

}

renv_cache_diagnose_wrong_built_version <- function(paths, problems, verbose) {

  # form paths to DESCRIPTION files
  descpaths <- file.path(paths, "DESCRIPTION")

  # parse the version of R each was built for
  versions <- map_chr(descpaths, function(descpath) {

    tryCatch(
      renv_description_built_version(descpath),
      error = function(e) {
        warning(e)
        NA
      }
    )

  })

  # check for NAs, report and remove them
  isna <- is.na(versions)
  if (any(isna)) {

    # nocov start
    if (verbose) {

      caution_bullets(
        "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."
      )

    }
    # nocov end

    data <- renv_cache_problems(
      paths = paths[isna],
      reason = "missing Built field"
    )

    problems$push(data)

    paths    <- paths[!isna]
    versions <- versions[!isna]

  }

  # check for incompatible versions
  wrong <- map_lgl(versions, function(version) {
    tryCatch(
      renv_version_compare(version, getRversion(), 2L) != 0,
      error = function(e) {
        warning(e)
        TRUE
      }
    )
  })

  if (!any(wrong))
    return(paths)

  # nocov start
  if (verbose) {

    caution_bullets(
      "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."
    )

  }
  # nocov end

  data <- renv_cache_problems(
    paths = paths[wrong],
    reason = "built for different version of R"
  )

  problems$push(data)
  paths

}

renv_cache_diagnose <- function(verbose = NULL) {

  verbose <- verbose %||% renv_verbose()

  problems <- stack()
  paths <- renv_cache_list()
  paths <- renv_cache_diagnose_corrupt_metadata(paths, problems, verbose)
  paths <- renv_cache_diagnose_missing_descriptions(paths, problems, verbose)
  paths <- renv_cache_diagnose_bad_hash(paths, problems, verbose)
  paths <- renv_cache_diagnose_wrong_built_version(paths, problems, verbose)

  invisible(bind(problems$data()))

}

renv_cache_acls_reset <- function(target) {

  enabled <- Sys.getenv("RENV_CACHE_ACLS", unset = "TRUE")
  if (enabled)
    renv_acls_reset(target)

}

# copies a package at location 'source' to cache location 'target'
renv_cache_copy <- function(source, target, overwrite = FALSE) {
  ensure_parent_directory(target)
  renv_file_copy(source, target, overwrite = overwrite)
  renv_cache_acls_reset(target)
}

# moves a package from location 'source' to cache location 'target',
# and then links back from 'target' to 'source'
renv_cache_move <- function(source, target, overwrite = FALSE) {

  # move package into the cache if requested
  if (overwrite || !file.exists(target)) {
    ensure_parent_directory(target)
    renv_file_move(source, target, overwrite = TRUE)
  }

  # try to reset ACLs on the cache directory
  renv_cache_acls_reset(target)

  # link from the cache back to the target location
  renv_file_link(target, source, overwrite = TRUE)

}

# nocov start
renv_cache_format_path <- function(paths) {

  # extract path components
  names    <- format(renv_path_component(paths, 1L))
  hashes   <- format(renv_path_component(paths, 2L))
  versions <- format(renv_path_component(paths, 3L))

  # format and write
  fmt <- "%s %s [Hash: %s]"
  sprintf(fmt, names, versions, hashes)

}
# nocov end

renv_cache_clean_empty <- function(cache = NULL) {
  caches <- cache %||% renv_paths_cache()
  map(caches, renv_cleanse_empty)
}

renv_cache_package_validate <- function(path) {

  if (renv_project_type(path) == "package")
    return(TRUE)

  type <- renv_file_type(path, symlinks = FALSE)
  if (!nzchar(type))
    return(FALSE)

  name <- if (type == "directory") "directory" else "file"
  fmt <- "%s %s exists but does not appear to be an R package"
  warningf(fmt, name, shQuote(path))

  FALSE

}

renv_cache_config_enabled <- function(project) {
  config$cache.enabled() && settings$use.cache(project = project)
}

renv_cache_config_symlinks <- function(project) {

  usesymlinks <-
    config$cache.symlinks(default = NULL) %||%
    renv_cache_config_symlinks_default(project = project)

  usesymlinks && settings$use.cache(project = project)

}

renv_cache_config_symlinks_default <- function(project) {

  # on linux, we can always use symlinks
  if (renv_platform_unix())
    return(TRUE)

  # on Windows, only try to use symlinks (junction points) if the cache
  # and the project library appear to live on the same drive
  libpath <- renv_paths_library(project = project)
  cachepath <- renv_paths_cache()

  # TODO: with this change, anyone using networks not mapped to a local drive
  # would need to opt-in to using symlinks, but that's probably okay?
  all(
    substring(libpath, 1L, 2L) == substring(cachepath, 1L, 2L),
    substring(libpath, 2L, 2L) == ":",
    substring(cachepath, 2L, 2L) == ":"
  )


}

renv_cache_linkable <- function(project, library) {
  renv_cache_config_enabled(project = project) &&
    renv_cache_config_symlinks(project = project) &&
    getOption(
      "renv.cache.linkable",
      renv_path_same(library, renv_paths_library(project = project))
    )
}


# call.R ---------------------------------------------------------------------


# 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
renv_call_expect <- function(node, package, methods) {

  if (!is.call(node))
    return(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)

    # 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

  if (!match)
    return(NULL)

  node

}

renv_call_normalize <- function(node, stack) {

  # 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>%", "%<>%"))

  if (!ispipe)
    return(node)

  # get lhs and rhs of piped expression
  lhs <- node[[2L]]
  rhs <- node[[3L]]

  # handle rhs symbols
  if (is.symbol(rhs))
    rhs <- call(as.character(rhs))

  # check for usage of '.'
  # if it exists, replace each with lhs
  hasdot <- FALSE
  dot <- as.symbol(".")
  for (i in seq_along(rhs)) {
    if (identical(dot, rhs[[i]])) {
      hasdot <- TRUE
      rhs[[i]] <- lhs
    }
  }

  if (hasdot)
    return(rhs)

  # otherwise, mutate rhs call with lhs passed as first argument
  args <- as.list(rhs)
  as.call(c(args[[1L]], lhs, args[-1L]))

}


renv_call_matches <- function(call, name = NULL, n_args = NULL) {
  if (!is.call(call))
    return(FALSE)

  if (!is.null(name)) {
    if (!is.name(call[[1]]))
      return(FALSE)

    if (!as.character(call[[1]]) %in% name)
      return(FALSE)
  }

  if (!is.null(n_args) && length(call) != n_args + 1L)
    return(FALSE)

  TRUE
}


# caution.R ------------------------------------------------------------------


caution <- function(fmt = "", ..., con = stdout()) {
  enabled <- getOption("renv.caution.verbose", default = TRUE)
  if (!is.null(fmt) && enabled)
    writeLines(sprintf(fmt, ...), con = con)
}

caution_bullets <- function(preamble = NULL,
                            values = NULL,
                            postamble = NULL,
                            ...,
                            bullets = TRUE,
                            emitter = NULL)
{
  if (empty(values))
    return(invisible())

  renv_dots_check(...)

  lines <- c(
    if (length(preamble))  paste(preamble, collapse = "\n"),
    if (bullets)
      paste("-", values, collapse = "\n")
    else
      paste(values, collapse = "\n"),
    if (length(postamble)) paste(postamble, collapse = "\n"),
    ""
  )

  text <- paste(lines, collapse = "\n")
  renv_caution_impl(text, emitter)
}

renv_caution_impl <- function(text, emitter = NULL) {

  # NOTE: Used by vetiver, so perhaps is part of the API.
  # We should think of a cleaner way of exposing this.
  # https://github.com/rstudio/renv/issues/1413
  emitter <- emitter %||% {
    getOption("renv.pretty.print.emitter", default = caution)
  }

  emitter(text)
  invisible(NULL)

}


# cellar.R -------------------------------------------------------------------


renv_cellar_roots <- function(project = NULL) {
  c(
    renv_paths_renv("cellar", project = project),
    renv_paths_renv("local", project = project),
    renv_paths_cellar(),
    renv_paths_local()
  )
}

renv_cellar_database <- function(project = NULL) {

  # find cellar root directories
  project <- renv_project_resolve(project)
  roots <- renv_cellar_roots(project)

  # list files both at top-level + one nested level
  paths <- list.files(roots, full.names = TRUE)
  paths <- c(paths, list.files(paths, full.names = TRUE))

  # grab files that look like packages
  extpat <- "(?:\\.tar\\.gz|\\.tgz|\\.zip)$"
  paths <- grep(extpat, paths, value = TRUE)

  # parse into data.frame
  base <- basename(paths)
  parts <- strsplit(base, "_", fixed = TRUE)
  package <- map_chr(parts, `[[`, 1L)
  rest <- map_chr(parts, `[[`, 2L)
  version <- sub(extpat, "", rest)

  data_frame(
    Package = package,
    Version = version,
    Path    = paths
  )

}

renv_cellar_latest <- function(package, project) {

  db <- renv_cellar_database(project = project)
  db <- rows(db, db$Package == package)
  db <- rows(db, order(package_version(db$Version), decreasing = TRUE))
  if (nrow(db) == 0L)
    return(record)

  entry <- db[1, ]
  list(
    Package = entry$Package,
    Version = entry$Version,
    Source  = "Cellar"
  )

}


# check.R --------------------------------------------------------------------


renv_check_unknown_source <- function(records, project = NULL) {

  # nothing to do if we have no records
  if (empty(records))
    return(TRUE)

  # for testing, we ignore renv
  if (renv_tests_running())
    records$renv <- NULL

  # keep only records which have unknown source
  unknown <- filter(records, function(record) {

    source <- renv_record_source(record)
    if (source != "unknown")
      return(FALSE)

    localpath <- tryCatch(
      renv_retrieve_cellar_find(record, project),
      error = function(e) ""
    )

    if (file.exists(localpath))
      return(FALSE)

    TRUE

  })

  # if all records have a known source, return TRUE
  if (empty(unknown))
    return(TRUE)

  # provide warning
  if (!renv_tests_running())
    renv_warnings_unknown_sources(unknown)

  # return FALSE to indicate failed validation
  FALSE

}




# checkout.R -----------------------------------------------------------------


#' Checkout a repository
#'
#' `renv::checkout()` can be used to retrieve the latest-availabe packages from
#' a (set of) package repositories.
#'
#' `renv::checkout()` is most useful with services like the Posit's
#' [Package Manager](https://packagemanager.rstudio.com/), as it
#' can be used to switch between different repository snapshots within an
#' renv project. In this way, you can upgrade (or downgrade) all of the
#' packages used in a particular renv project to the package versions
#' provided by a particular snapshot.
#'
#' 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
#' replaced with the version provided by the requested repositories. This could
#' be a concern if your project uses \R packages from GitHub whose name matches
#' that of an existing CRAN package, but is otherwise unrelated to the package
#' on CRAN.
#'
#' @inheritParams renv-params
#'
#' @param repos The \R package repositories to use.
#'
#' @param packages The packages to be installed. When `NULL` (the default),
#'   all packages currently used in the project will be installed, as
#'   determined by [renv::dependencies()]. The recursive dependencies of these
#'   packages will be included as well.
#'
#' @param date The snapshot date to use. When set, the associated snapshot as
#'   available from the Posit's public
#'   [Package Manager](https://packagemanager.rstudio.com/) instance will be
#'   used. Ignored if `repos` is non-`NULL`.
#'
#' @param actions The action(s) to perform with the requested repositories.
#'   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
#'   `c("snapshot", "restore")` if you'd like to generate a lockfile and
#'   install those packages in the same step.
#'
#' @examples
#' \dontrun{
#'
#' # check out packages from PPM using the date '2023-01-02'
#' renv::checkout(date = "2023-01-02")
#'
#' # alternatively, supply the full repository path
#' renv::checkout(repos = "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")
#'
#' }
#' @export
checkout <- function(repos = NULL,
                     ...,
                     packages = NULL,
                     date     = NULL,
                     clean    = FALSE,
                     actions  = "restore",
                     project  = NULL)
{
  renv_consent_check()
  renv_scope_error_handler()
  renv_dots_check(...)

  project  <- renv_project_resolve(project)
  renv_project_lock(project = project)

  # set new repositories
  repos <- repos %||% renv_checkout_repos(date)
  options(repos = repos)

  # TODO: Activate Bioconductor if it appears to be used by this project

  # select packages to install
  packages <- packages %||% renv_checkout_packages(project = project)

  # get the associated remotes for these packages
  remotes <- renv_checkout_remotes(packages, project)

  # parse these into package records
  records <- map(remotes, renv_remotes_resolve)

  # 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'")
    )
  }

  invisible(lockfile)

}

renv_checkout_packages <- function(project) {
  renv_dependencies_impl(
    project,
    field = "Package",
    dev = TRUE
  )
}

renv_checkout_remotes <- function(packages, project) {

  # get available packages
  dbs <- available_packages(type = "source")
  if (is.null(dbs))
    stop("no package repositories are available")

  # flatten so we only see the latest version of a package
  db <- renv_available_packages_flatten(dbs)

  # keep only packages which appear to be available in the repositories
  packages <- intersect(packages, db$Package)

  # 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))
  packages <- setdiff(packages, ignored)

  # compute recursive dependencies for these packages
  renv_checkout_recdeps(packages, db)

}

renv_checkout_recdeps <- function(packages, db) {

  # initialize environment (will map package names to discovered remotes)
  envir <- new.env(parent = emptyenv())

  # set R to NA since it's a common non-package 'dependency' for packages
  envir$R <- NA

  # iterate through dependencies
  for (package in packages)
    renv_checkout_recdeps_impl(package, db, envir)

  # get list of discovered dependencies
  recdeps <- as.list.environment(envir, all.names = TRUE)

  # drop any NA values
  recdeps <- filter(recdeps, Negate(is.na))

  # return sorted vector
  recdeps[csort(names(recdeps))]

}

renv_checkout_recdeps_impl <- function(package, db, envir) {

  # check if we've already visited this package
  if (!is.null(envir[[package]]))
    return()

  # get entry from database
  entry <- rows(db, db$Package == package)
  if (nrow(entry) == 0L) {
    envir[[package]] <- NA_character_
    return()
  }

  # set discovered remote
  envir[[package]] <- with(entry, paste(Package, Version, sep = "@"))

  # iterate through hard dependencies
  fields <- c("Depends", "Imports", "LinkingTo")
  for (field in fields) {
    value <- entry[[field]]
    if (!is.null(value) && !is.na(value)) {
      value <- renv_description_parse_field(entry[[field]])
      for (package in value$Package)
        if (is.null(envir[[package]]))
          renv_checkout_recdeps_impl(package, db, envir)
    }
  }

  # for soft dependencies, only include those if they're currently installed
  # TODO: or check if it's in the lockfile?
  value <- entry[["Suggests"]]
  if (!is.null(value) && !is.na(value)) {
    value <- renv_description_parse_field(value)
    for (package in value$Package)
      if (is.null(envir[[package]]))
        if (renv_package_installed(package))
          renv_checkout_recdeps_impl(package, db, envir)
  }

}

renv_checkout_repos <- function(date) {

  # if no date was provided, just use default repositories
  if (is.null(date))
    return(getOption("repos"))

  # build path to repository snapshot location
  root <- dirname(config$ppm.url())
  url <- file.path(root, date)
  if (renv_download_available(file.path(url, "src/contrib/PACKAGES")))
    return(c(PPM = url))

  # requested date not available; try to search a bit
  candidate <- date
  for (i in 1:7) {
    candidate <- format(as.Date(candidate) - 1L)
    url <- file.path(root, candidate)
    if (renv_download_available(file.path(url, "src/contrib/PACKAGES"))) {
      fmt <- "- Snapshot date '%s' not available; using '%s' instead"
      printf(fmt, date, candidate)
      return(c(PPM = url))
    }
  }

  stopf("repository snapshot '%s' not available", date)

}


# clean.R --------------------------------------------------------------------


#' Clean a project
#'
#' Clean up a project and its associated \R libraries.
#'
#' # Actions
#'
#' The following clean actions are available:
#'
#' \describe{
#'
#' \item{`package.locks`}{
#'
#'   During package installation, \R will create package locks in the
#'   library path, typically named `00LOCK-<package>`. On occasion, if package
#'   installation fails or \R is terminated while installing a package, these
#'   locks can be left behind and will inhibit future attempts to reinstall
#'   that package. Use this action to remove such left-over package locks.
#'
#' }
#'
#' \item{`library.tempdirs`}{
#'
#'   During package installation, \R may create temporary directories with
#'   names of the form `file\w{12}`, and on occasion those files can be
#'   left behind even after they are no longer in use. Use this action to
#'   remove such left-over directories.
#' }
#'
#' \item{`system.library`}{
#'
#'   In general, it is recommended that only packages distributed with \R
#'   are installed into the default library (the library path referred to
#'   by `.Library`). Use this action to remove any user-installed packages
#'   that have been installed to the system library.
#'
#'   Because this action is destructive, it is by default never run -- it
#'   must be explicitly requested by the user.
#'
#' }
#'
#' \item{`unused.packages`}{
#'
#'   Remove packages that are installed in the project library, but no longer
#'   appear to be used in the project sources.
#'
#'   Because this action is destructive, it is by default only run in
#'   interactive sessions when prompting is enabled.
#'
#' }
#'
#' }
#'
#'
#' @inherit renv-params
#'
#' @param actions The set of clean actions to take. See the documentation in
#'   **Actions** for a list of available actions, and the default actions
#'   taken when no actions are supplied.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # clean the current project
#' renv::clean()
#'
#' }
clean <- function(project = NULL,
                  ...,
                  actions = NULL,
                  prompt  = interactive())
{
  renv_scope_error_handler()
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_scope_verbose_if(prompt)

  renv_activate_prompt("clean", NULL, prompt, project)

  actions <- actions %||% renv_clean_actions(prompt)

  all <- list(
    package.locks     = renv_clean_package_locks,
    library.tempdirs  = renv_clean_library_tempdirs,
    system.library    = renv_clean_system_library,
    unused.packages   = renv_clean_unused_packages
  )

  methods <- all[actions]
  for (method in methods)
    tryCatch(method(project, prompt), error = warnify)

  writef("- The project has been cleaned.")
  invisible(project)
}

renv_clean_actions <- function(prompt) {

  default <- c(
    "package.locks",
    "library.tempdirs"
  )

  unsafe <- c(
    # "system.library",
    "unused.packages"
  )

  c(default, if (prompt) unsafe)

}

renv_clean_library_tempdirs <- function(project, prompt) {

  ntd <- function() {
    writef("- No temporary directories were found in the project library.")
    FALSE
  }

  library <- renv_paths_library(project = project)
  children <- list.files(library, full.names = TRUE)

  bad <- grep("/file\\w{12}$", children, value = TRUE)
  if (empty(bad))
    return(ntd())

  # nocov start
  if (prompt || renv_verbose()) {

    caution_bullets("The following directories will be removed:", bad)

    if (prompt && !proceed())
      cancel()

  }
  # nocov end

  unlink(bad, recursive = TRUE)
  TRUE

}


# remove user packages in system library
renv_clean_system_library <- function(project, prompt) {

  ntd <- function() {
    writef("- No non-system packages were discovered in the system library.")
    FALSE
  }

  # explicitly query for packages
  syslib <- renv_path_normalize(renv_libpaths_system())
  db <- installed_packages(lib.loc = syslib, priority = "NA")
  packages <- setdiff(db$Package, "translations")

  # also look for leftover package folders
  # (primarily for Windows, where .dlls from old packages can be left behind)

  # nocov start
  if (renv_platform_windows()) {
    folders <- list.files(syslib, full.names = TRUE)
    descpaths <- file.path(folders, "DESCRIPTION")
    missing <- !file.exists(descpaths)
    packages <- union(packages, basename(folders)[missing])
  }
  # nocov end

  # check for any packages needing removal
  if (empty(packages))
    return(ntd())

  # nocov start
  if (prompt || renv_verbose()) {

    caution_bullets(
      "The following non-system packages are installed in the system library:",
      packages,
      c(
        "Normally, only packages distributed with R should be installed in the system library.",
        "These packages will be removed.",
        "If necessary, consider reinstalling these packages in your site library."
      )
    )

    if (prompt && !proceed())
      cancel()

  }
  # nocov end

  remove(packages, library = syslib)
  TRUE

}

renv_clean_unused_packages <- function(project, prompt) {

  ntd <- function() {
    writef("- No unused packages were found in the project library.")
    FALSE
  }

  # find packages installed in the project library
  library <- renv_paths_library(project = project)
  installed <- list.files(library)
  if (empty(installed))
    return(ntd())

  # find packages used in the project and their recursive dependencies
  packages <- renv_snapshot_dependencies(project, dev = TRUE)
  paths <- renv_package_dependencies(packages, project = project)
  packages <- names(paths)

  # figure out which packages aren't needed
  removable <- renv_vector_diff(installed, packages)
  if (empty(removable))
    return(ntd())

  # nocov start
  if (prompt || renv_verbose()) {

    caution_bullets(
      c(
        "The following packages are installed in the project library,",
        "but appear to be no longer used in your project."
      ),
      removable,
      "These packages will be removed."
    )

    if (prompt && !proceed())
      cancel()

  }
  # nocov end

  remove(removable, library = library)
  return(TRUE)

}

renv_clean_package_locks <- function(project, prompt) {

  ntd <- function() {
    writef("- No stale package locks were found.")
    FALSE
  }

  # find 00LOCK directories in library
  library <- renv_paths_library(project = project)
  lock <- list.files(path = library, pattern = "^00LOCK", full.names = TRUE)
  if (empty(lock))
    return(ntd())

  # check to see which are old
  now <- Sys.time()
  mtime <- file.mtime(lock)
  mtime[is.na(mtime)] <- now
  diff <- difftime(now, mtime, units = "secs")
  old <- lock[diff > 120]
  if (empty(old))
    return(ntd())

  # nocov start
  if (prompt || renv_verbose()) {

    caution_bullets(
      "The following stale package locks were discovered in your library:",
      basename(old),
      "These locks will be removed."
    )

    if (prompt && !proceed())
      cancel()

  }
  # nocov end

  unlink(old, recursive = TRUE)
  TRUE
}

# nocov start
renv_clean_cache <- function(project, prompt) {

  ntd <- function() {
    writef("- No unused packages were found in the renv cache.")
    FALSE
  }

  # find projects monitored by renv
  projects <- renv_paths_root("projects")
  projlist <- character()
  if (file.exists(projects))
    projlist <- readLines(projects, warn = FALSE, encoding = "UTF-8")

  # inform user if any projects are missing
  missing <- !file.exists(projlist)
  if (any(missing)) {

    caution_bullets(
      "The following projects are monitored by renv, but no longer exist:",
      projlist[missing],
      "These projects will be removed from renv's project list."
    )

    if (prompt && !proceed())
      cancel()

    writeLines(projlist[!missing], con = projects, useBytes = TRUE)

  }

  action <- function(project) {
    library <- renv_paths_library(project = project)
    packages <- list.files(library, full.names = TRUE)
    descs <- file.path(packages, "DESCRIPTION")
    existing <- file.exists(descs)
    map_chr(descs[existing], renv_cache_path, USE.NAMES = FALSE)
  }

  # for each project, find packages used in their renv private library,
  # and look for entries in the cache
  projlist <- projlist[!missing]
  callback <- renv_progress_callback(action, length(projlist))
  used <- uapply(projlist, callback)

  # check what packages are actually available in the cache
  available <- renv_cache_list()

  diff <- renv_vector_diff(available, used)
  if (empty(diff))
    return(ntd())

  if (prompt || renv_verbose()) {

    caution_bullets(
      "The following packages are installed in the cache but no longer used:",
      renv_cache_format_path(diff),
      "These packages will be removed."
    )

    if (prompt && !proceed())
      cancel()

  }

  # remove the directories
  unlink(diff, recursive = TRUE)
  renv_cache_clean_empty()

  writef("- %i package(s) have been removed.", length(diff))
  TRUE

}
# nocov end


# cleanse.R ------------------------------------------------------------------


# tools for cleaning up renv's cached data
cleanse <- function() {

  enabled <- Sys.getenv("RENV_CLEANSE_ENABLED", unset = "TRUE")
  if (!truthy(enabled))
    return(invisible(FALSE))

  # remove unused sandbox directories
  renv_cleanse_sandbox(path = renv_paths_sandbox())

  # remove empty directories in the root directory
  # we can't do this on Windows, as some empty directories
  # might also be broken junctions, and we want to keep
  # those around so we can inform the user that they need
  # to repair that
  if (!renv_platform_windows())
    renv_cleanse_empty(path = renv_paths_root())

  invisible(TRUE)

}

renv_cleanse_sandbox <- function(path) {

  # get sandbox root path
  root <- dirname(path)
  if (!file.exists(root))
    return(FALSE)

  # list directories within
  dirs <- list.files(root, full.names = TRUE)

  # look for apparently-unused sandbox directories
  info <- suppressWarnings(file.info(dirs, extra_cols = FALSE))
  age <- difftime(Sys.time(), info$mtime, units = "days")
  old <- age >= 7

  # remove the old sandbox directories
  unlink(dirs[old], recursive = TRUE, force = TRUE)

}

renv_cleanse_empty <- function(path) {

  # no-op for Solaris
  if (renv_platform_solaris())
    return(FALSE)

  if (!file.exists(path))
    return(FALSE)

  renv_scope_wd(path)

  # execute system command for removing empty directories
  action <- "removing empty directories"
  if (renv_platform_windows()) {
    args <- c(".", ".", "/S", "/MOVE")
    renv_system_exec("robocopy", args, action, 0:8)
  } else {
    args <- c(".", "-type", "d", "-empty", "-delete")
    renv_system_exec("find", args, action)
  }

  TRUE

}


# cli.R ----------------------------------------------------------------------


renv_cli_install <- function(target = NULL) {

  # get path to bundled tool
  exe <- if (renv_platform_windows()) "bin/renv.bat" else "bin/renv"
  path <- system.file(exe, package = "renv")

  # copy into directory on PATH
  target <- target %||% path.expand("~/bin/renv")
  ensure_parent_directory(target)
  file.copy(path, target)

  writef("- renv binary copied to %s.", renv_path_pretty(target))
  invisible(target)

}

renv_cli_exec <- function(clargs = commandArgs(trailingOnly = TRUE)) {
  invisible(renv_cli_exec_impl(clargs))
}

renv_cli_exec_impl <- function(clargs) {

  # check for tool called without arguments, or called with '--help'
  usage <-
    length(clargs) == 0 ||
    clargs[1L] %in% c("help", "--help")

  if (usage)
    return(renv_cli_usage())

  # extract method
  method <- clargs[1L]

  # check request for help on requested method
  help <-
    clargs[2L] %in% c("help", "--help")

  if (help)
    return(renv_cli_help(method))

  # check for known function in renv
  exports <- getNamespaceExports("renv")
  if (!method %in% exports)
    return(renv_cli_unknown(method, exports))

  # begin building call
  args <- list(call("::", as.name("renv"), as.name(method)))

  for (clarg in clargs[-1L]) {

    # convert '--no-<flag>' into a FALSE parameter
    if (grepl("^--no-", clarg)) {
      key <- substring(clarg, 6L)
      args[[key]] <- FALSE
    }

    # convert '--param=value' flags
    else if (grepl("^--[^=]+=", clarg)) {
      index <- regexpr("=", clarg, fixed = TRUE)
      key <- substring(clarg, 3L, index - 1L)
      val <- substring(clarg, index + 1L)
      args[[key]] <- renv_cli_parse(val)
    }

    # convert '--flag' into a TRUE parameter
    else if (grepl("^--", clarg)) {
      key <- substring(clarg, 3L)
      args[[key]] <- TRUE
    }

    # convert 'param=value' flags
    else if (grepl("=", clarg, fixed = TRUE)) {
      index <- regexpr("=", clarg, fixed = TRUE)
      key <- substring(clarg, 1L, index - 1L)
      val <- substring(clarg, index + 1L)
      args[[key]] <- renv_cli_parse(val)
    }

    # take other parameters as-is
    else {
      args[[length(args) + 1L]] <- renv_cli_parse(clarg)
    }

  }

  # invoke method with parsed arguments
  expr <- as.call(args)
  eval(expr = expr, envir = globalenv())

}

renv_cli_usage <- function() {

  usage <- "
Usage: renv [method] [args...]

[method] should be the name of a function exported from renv.
[args...] should be arguments accepted by that function.

Use renv [method] --help for more information about the associated function.

Examples:

  # basic commands
  renv init      # initialize a project
  renv snapshot  # snapshot project library
  renv restore   # restore project library
  renv status    # check project status

  # install a package
  renv install dplyr

  # run a script in an renv project
  renv run path/to/script.R
"

  writeLines(usage, con = stderr())

}

renv_cli_help <- function(method) {
  print(help(method, package = "renv"))
}

renv_cli_unknown <- function(method, exports) {

  # report unknown command
  caution("renv: '%s' is not a known command.", method)

  # check for similar commands
  distance <- c(adist(method, exports))
  names(distance) <- exports
  n <- min(distance)
  if (n > 2)
    return(1L)

  candidates <- names(distance)[distance == n]
  fmt <- "did you mean %s?"
  caution(fmt, paste(shQuote(candidates), collapse = " or "))
  return(1L)

}

renv_cli_parse <- function(text) {

  # handle logical-like values up-front
  if (text %in% c("true", "True", "TRUE"))
    return(TRUE)
  else if (text %in% c("false", "False", "FALSE"))
    return(FALSE)

  # parse the expression
  value <- parse(text = text)[[1L]]
  if (is.language(value)) text else value

}


# conda.R --------------------------------------------------------------------


# given the path to a Python installation managed by conda, attempt to
# find the conda installation + executable used to create it
renv_conda_find <- function(python) {

  tryCatch(
    renv_conda_find_impl(python),
    error = function(e) {
      warning(e)
      ""
    }
  )

}

renv_conda_find_impl <- function(python) {

  # read the conda environment's history to try to find conda
  base <- dirname(python)
  if (!renv_platform_windows())
    base <- dirname(base)

  history <- file.path(base, "conda-meta/history")
  if (!file.exists(history))
    return("")

  contents <- readLines(history, n = 2L, warn = FALSE)
  if (length(contents) < 2)
    return("")

  line <- substring(contents[2L], 8L)
  index <- regexpr(" ", line, fixed = TRUE)
  if (index == -1L)
    return("")

  conda <- substring(line, 1L, index - 1L)
  if (renv_platform_windows())
    conda <- file.path(dirname(conda), "conda.exe")

  # prefer condabin if it exists
  condabin <- file.path(dirname(conda), "../condabin", basename(conda))
  if (file.exists(condabin))
    conda <- condabin

  # bail if conda wasn't found
  if (!file.exists(conda))
    return("")

  renv_path_canonicalize(conda)

}


# condition.R ----------------------------------------------------------------


renv_condition_signal <- function(class = NULL, data = NULL) {
  condition <- list(message = character(), call = NULL, data = data)
  class(condition) <- c(class, "renv.condition", "condition")
  signalCondition(condition)
}


# config-defaults.R ----------------------------------------------------------


# Auto-generated by renv_zzz_bootstrap_config()

#' @rdname config
#' @export
#' @format NULL
config <- list(

  activate.prompt = function(..., default = TRUE) {
    renv_config_get(
      name    = "activate.prompt",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  autoloader.enabled = function(..., default = TRUE) {
    renv_config_get(
      name    = "autoloader.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  auto.snapshot = function(..., default = FALSE) {
    renv_config_get(
      name    = "auto.snapshot",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  bitbucket.host = function(..., default = "api.bitbucket.org/2.0") {
    renv_config_get(
      name    = "bitbucket.host",
      type    = "character[1]",
      default = default,
      args    = list(...)
    )
  },

  copy.method = function(..., default = "auto") {
    renv_config_get(
      name    = "copy.method",
      type    = "*",
      default = default,
      args    = list(...)
    )
  },

  connect.timeout = function(..., default = 20L) {
    renv_config_get(
      name    = "connect.timeout",
      type    = "integer[1]",
      default = default,
      args    = list(...)
    )
  },

  connect.retry = function(..., default = 3L) {
    renv_config_get(
      name    = "connect.retry",
      type    = "integer[1]",
      default = default,
      args    = list(...)
    )
  },

  cache.enabled = function(..., default = TRUE) {
    renv_config_get(
      name    = "cache.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  cache.symlinks = function(..., default = .Platform$OS.type == "unix") {
    renv_config_get(
      name    = "cache.symlinks",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  dependency.errors = function(..., default = "reported") {
    renv_config_get(
      name    = "dependency.errors",
      type    = "character[1]",
      default = default,
      args    = list(...)
    )
  },

  dependencies.limit = function(..., default = 1000L) {
    renv_config_get(
      name    = "dependencies.limit",
      type    = "integer[1]",
      default = default,
      args    = list(...)
    )
  },

  exported.functions = function(..., default = "*") {
    renv_config_get(
      name    = "exported.functions",
      type    = "character[*]",
      default = default,
      args    = list(...)
    )
  },

  external.libraries = function(..., default = NULL) {
    renv_config_get(
      name    = "external.libraries",
      type    = "character[*]",
      default = default,
      args    = list(...)
    )
  },

  filebacked.cache = function(..., default = TRUE) {
    renv_config_get(
      name    = "filebacked.cache",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  github.host = function(..., default = "api.github.com") {
    renv_config_get(
      name    = "github.host",
      type    = "character[1]",
      default = default,
      args    = list(...)
    )
  },

  gitlab.host = function(..., default = "gitlab.com") {
    renv_config_get(
      name    = "gitlab.host",
      type    = "character[1]",
      default = default,
      args    = list(...)
    )
  },

  hydrate.libpaths = function(..., default = NULL) {
    renv_config_get(
      name    = "hydrate.libpaths",
      type    = "character[*]",
      default = default,
      args    = list(...)
    )
  },

  install.build = function(..., default = FALSE) {
    renv_config_get(
      name    = "install.build",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  install.remotes = function(..., default = TRUE) {
    renv_config_get(
      name    = "install.remotes",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  install.shortcuts = function(..., default = TRUE) {
    renv_config_get(
      name    = "install.shortcuts",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  install.staged = function(..., default = TRUE) {
    renv_config_get(
      name    = "install.staged",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  install.transactional = function(..., default = TRUE) {
    renv_config_get(
      name    = "install.transactional",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  install.verbose = function(..., default = FALSE) {
    renv_config_get(
      name    = "install.verbose",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  locking.enabled = function(..., default = FALSE) {
    renv_config_get(
      name    = "locking.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  mran.enabled = function(..., default = FALSE) {
    renv_config_get(
      name    = "mran.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  pak.enabled = function(..., default = FALSE) {
    renv_config_get(
      name    = "pak.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  ppm.enabled = function(..., default = TRUE) {
    renv_config_get(
      name    = "ppm.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  ppm.default = function(..., default = TRUE) {
    renv_config_get(
      name    = "ppm.default",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  ppm.url = function(..., default = "https://packagemanager.posit.co/cran/latest") {
    renv_config_get(
      name    = "ppm.url",
      type    = "character[1]",
      default = default,
      args    = list(...)
    )
  },

  repos.override = function(..., default = NULL) {
    renv_config_get(
      name    = "repos.override",
      type    = "character[*]",
      default = default,
      args    = list(...)
    )
  },

  rspm.enabled = function(..., default = TRUE) {
    renv_config_get(
      name    = "rspm.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  sandbox.enabled = function(..., default = TRUE) {
    renv_config_get(
      name    = "sandbox.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  shims.enabled = function(..., default = TRUE) {
    renv_config_get(
      name    = "shims.enabled",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  snapshot.inference = function(..., default = TRUE) {
    renv_config_get(
      name    = "snapshot.inference",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  snapshot.validate = function(..., default = TRUE) {
    renv_config_get(
      name    = "snapshot.validate",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  startup.quiet = function(..., default = NULL) {
    renv_config_get(
      name    = "startup.quiet",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  synchronized.check = function(..., default = TRUE) {
    renv_config_get(
      name    = "synchronized.check",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  updates.check = function(..., default = FALSE) {
    renv_config_get(
      name    = "updates.check",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  updates.parallel = function(..., default = 2L) {
    renv_config_get(
      name    = "updates.parallel",
      type    = "*",
      default = default,
      args    = list(...)
    )
  },

  user.environ = function(..., default = TRUE) {
    renv_config_get(
      name    = "user.environ",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  user.library = function(..., default = FALSE) {
    renv_config_get(
      name    = "user.library",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  },

  user.profile = function(..., default = FALSE) {
    renv_config_get(
      name    = "user.profile",
      type    = "logical[1]",
      default = default,
      args    = list(...)
    )
  }

)


# config.R -------------------------------------------------------------------


#' User-level settings
#'
#' Configure different behaviors of renv.
#'
#' For a given configuration option:
#'
#' 1. If an \R option of the form `renv.config.<name>` is available,
#'    then that option's value will be used;
#'
#' 2. If an environment variable of the form `RENV_CONFIG_<NAME>` is available,
#'   then that option's value will be used;
#'
#' 3. Otherwise, the default for that particular configuration value is used.
#'
#' Any periods (`.`)s in the option name are transformed into underscores (`_`)
#' in the environment variable name, and vice versa. For example, the
#' configuration option `auto.snapshot` could be configured as:
#'
#' - `options(renv.config.auto.snapshot = <...>)`
#' - `Sys.setenv(RENV_CONFIG_AUTO_SNAPSHOT = <...>)`
#'
#' Note that if both the \R option and the environment variable are defined, the
#' \R option will be used instead. Environment variables can be more useful when
#' you want a particular configuration to be automatically inherited by child
#' processes; if that behavior is not desired, then the R option may be
#' preferred.
#'
#' If you want to set and persist these options across multiple projects, it is
#' recommended that you set them in a a startup `.Renviron` file; e.g. in your
#' own `~/.Renviron`, or in the R installation's `etc/Rprofile.site` file. See
#' [Startup] for more details.
#'
#' Configuration options can also be set within the project `.Rprofile`, but
#' be aware the options should be set before `source("renv/activate.R")` is
#' called.
#'
#' @eval renv_roxygen_config_section()
#'
#' @section Copy methods:
#'
#' If you find that renv is unable to copy some directories in your
#' environment, you may want to try setting the `copy.method` option. By
#' default, renv will try to choose a system tool that is likely to succeed in
#' copying files on your system -- `robocopy` on Windows, and `cp` on Unix.
#' renv will also instruct these tools to preserve timestamps and attributes
#' when copying files. However, you can select a different method as
#' appropriate.
#'
#' The following methods are supported:
#'
#' \tabular{ll}{
#' `auto`     \tab Use `robocopy` on Windows, and `cp` on Unix-alikes. \cr
#' `R`        \tab Use \R's built-in `file.copy()` function. \cr
#' `cp`       \tab Use `cp` to copy files. \cr
#' `robocopy` \tab Use `robocopy` to copy files. (Only available on Windows.) \cr
#' `rsync`    \tab Use `rsync` to copy files. \cr
#' }
#'
#' You can also provide a custom copy method if required; e.g.
#'
#' ```
#' options(renv.config.copy.method = function(src, dst) {
#'   # copy a file from 'src' to 'dst'
#' })
#' ```
#'
#' Note that renv will always first attempt to copy a directory first to a
#' temporary path within the target folder, and then rename that temporary path
#' to the final target destination. This helps avoid issues where a failed
#' attempt to copy a directory could leave a half-copied directory behind
#' in the final location.
#'
#' @section Project-local settings:
#'
#' For settings that should persist alongside a particular project, the
#' various settings available in [settings] can be used.
#'
#' @examples
#'
#' # disable automatic snapshots
#' options(renv.config.auto.snapshot = FALSE)
#'
#' # disable with environment variable
#' Sys.setenv(RENV_CONFIG_AUTO_SNAPSHOT = FALSE)
#'
#' @rdname config
#' @name config
NULL

renv_config_get <- function(name,
                            scope   = "config",
                            type    = "*",
                            default = NULL,
                            args    = NULL)
{
  # check for R option of associated name
  optname <- tolower(name)
  optkey <- paste("renv", scope, optname, sep = ".")
  optval <- getOption(optkey)
  if (!is.null(optval))
    return(renv_config_validate(name, optval, type, default, args))

  # check for environment variable
  envname <- gsub(".", "_", toupper(name), fixed = TRUE)
  envkey <- paste("RENV", toupper(scope), envname, sep = "_")
  envval <- Sys.getenv(envkey, unset = NA)
  if (!is.na(envval) && nzchar(envval)) {
    decoded <- renv_config_decode_envvar(envkey, envval)
    return(renv_config_validate(name, decoded, type, default, args))
  }

  # return default if nothing found
  default

}

renv_config_decode_envvar <- function(envname, envval) {

  map <- env(
    "NULL" = NULL,
    "NA"   = NA,
    "NaN"  = NaN,
    "true" = TRUE,
    "True" = TRUE,
    "TRUE" = TRUE,
    "false" = FALSE,
    "False" = FALSE,
    "FALSE" = FALSE
  )

  if (exists(envval, envir = map, inherits = FALSE))
    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*"

  strsplit(envval, pattern, perl = TRUE)[[1L]]

}

renv_config_validate <- function(name, value, type, default, args) {

  # no validation required for type = '*'
  if (identical(type, "*"))
    return(value)

  # if 'value' is a function, invoke it with args
  if (is.function(value)) {
    value <- catch(do.call(value, args))
    if (inherits(value, "error")) {
      warning(value, call. = FALSE)
      return(default)
    }
  }

  # parse the type string
  pattern <- paste0(
    "^",          # start of specifier
    "([^[(]+)",   # type name
    "[[(]",       # opening bracket
    "([^])]+)",   # length specifier
    "[])]",       # closing bracket
    "$"           # end of specifier
  )

  m <- regexec(pattern, type)
  matches <- regmatches(type, m)
  fields <- matches[[1L]]

  # extract declared mode, size
  mode <- fields[[2L]]
  size <- fields[[3L]]

  # validate the requested size for this option
  if (!renv_config_validate_size(value, size)) {
    fmt <- "value for option '%s' does not satisfy constraint '%s'"
    warningf(fmt, name, type)
  }

  # convert NULL values to requested type
  if (is.null(value)) {
    value <- convert(value, mode)
    return(value)
  }

  # otherwise, validate that this is a valid option
  if (identical(storage.mode(value), mode))
    return(value)

  # try converting
  converted <- catchall(convert(value, mode))
  if (any(is.na(converted)) || inherits(converted, "condition")) {
    fmt <- "'%s' does not satisfy constraint '%s' for config '%s'; using default '%s' instead"
    warningf(fmt, stringify(value), type, name, stringify(default))
    return(default)
  }

  # ok, validated + converted option
  converted

}

renv_config_validate_size <- function(value, size) {

  case(
    size == "*" ~ TRUE,
    size == "+" ~ length(value) > 0,
    size == "?" ~ length(value) %in% c(0, 1),
    TRUE        ~ as.numeric(size) == length(value)
  )

}

renv_config_install_staged <- function(default = TRUE) {

  values <- c(
    config$install.staged(default = NULL),
    config$install.transactional(default = NULL),
    default
  )

  values[[1L]]

}


# consent.R ------------------------------------------------------------------


#' Consent to usage of renv
#'
#' Provide consent to renv, allowing it to write and update certain files
#' on your filesystem.
#'
#' As part of its normal operation, renv will write and update some files
#' in your project directory, as well as an application-specific cache
#' directory. These paths are documented within [paths].
#'
#' In accordance with the
#' [CRAN Repository Policy](https://cran.r-project.org/web/packages/policies.html),
#' renv must first obtain consent from you, the user, before these actions
#' can be taken. Please call `renv::consent()` first to provide this consent.
#'
#' You can also set the \R option:
#'
#' ```
#' options(renv.consent = TRUE)
#' ```
#'
#' to implicitly provide consent for e.g. non-interactive \R sessions.
#'
#' @param provided The default provided response. If you need to provide
#'   consent from a non-interactive \R session, you can invoke
#'   `renv::consent(provided = TRUE)` explicitly.
#'
#' @return `TRUE` if consent is provided, or an \R error otherwise.
#'
#' @export
consent <- function(provided = FALSE) {

  # assume consent if embedded
  if (renv_metadata_embedded())
    return(TRUE)

  # compute path to root directory
  root <- renv_paths_root()
  if (renv_file_type(root) == "directory") {
    writef("- Consent to use renv has already been provided -- nothing to do.")
    return(invisible(TRUE))
  }

  # write welcome message
  template <- system.file("resources/WELCOME", package = "renv")
  contents <- readLines(template)
  replacements <- list(RENV_PATHS_ROOT = renv_path_pretty(root))
  welcome <- renv_template_replace(contents, replacements)
  writef(welcome)

  # ask user if they want to proceed
  response <- catchall(proceed(default = provided))
  if (!identical(response, TRUE)) {
    msg <- "consent was not provided; operation aborted"
    stop(msg, call. = FALSE)
  }

  # cache the user response
  options(renv.consent = TRUE)
  ensure_directory(root)
  writef("- %s has been created.", renv_path_pretty(root))

  invisible(TRUE)

}

renv_consent_check <- function() {

  # check for explicit consent
  consent <- getOption("renv.consent")
  if (identical(consent, TRUE))
    return(TRUE)
  else if (identical(consent, FALSE))
    stopf("consent has been explicitly withdrawn")

  # check for existence of root
  root <- renv_paths_root()
  if (renv_file_type(root) == "directory")
    return(TRUE)

  # check for implicit consent
  consented <-
    !interactive() ||
    renv_envvar_exists("CI") ||
    renv_envvar_exists("GITHUB_ACTION") ||
    renv_envvar_exists("RENV_PATHS_ROOT") ||
    file.exists("/.singularity.d") ||
    renv_virtualization_type() != "native"

  if (consented) {
    ensure_directory(root)
    return(TRUE)
  }

  # looks like the user's first interactive use of renv
  consent()

}


# cran.R ---------------------------------------------------------------------


# nocov start

renv_cran_status <- function(email   = NULL,
                             package = NULL,
                             view    = "maintainer")
{
  case(
    view == "maintainer" ~ renv_cran_status_maintainer(email, package),
    TRUE                 ~ stopf("unrecognized view '%s'", view)
  )

}

renv_cran_status_maintainer <- function(email, package) {

  email <- email %||% renv_cran_status_maintainer_email(package = package)
  parts <- strsplit(email, "@", fixed = TRUE)[[1L]]

  fmt <- "https://cran.r-project.org/web/checks/check_results_%s_at_%s.html"
  url <- sprintf(fmt, parts[[1L]], parts[[2L]])

  browseURL(url)

}

renv_cran_status_maintainer_email <- function(package = NULL) {

  mtr <- renv_package_description_field(
    package = package %||% "renv",
    field   = "Maintainer"
  )

  indices <- gregexpr("[<>]", mtr, perl = TRUE)[[1L]]
  substring(mtr, indices[[1L]] + 1L, indices[[2L]] - 1L)

}

# nocov end


# curl.R ---------------------------------------------------------------------


the$curl_valid <- new.env(parent = emptyenv())

renv_curl_exe <- function() {

  curl <- Sys.getenv("RENV_CURL_EXECUTABLE", unset = NA)
  if (is.na(curl))
    curl <- Sys.which("curl")

  if (!nzchar(curl))
    return(renv_curl_exe_missing(curl))

  renv_curl_validate(curl)

}

renv_curl_validate <- function(curl) {

  the$curl_valid[[curl]] <- the$curl_valid[[curl]] %||% {
    renv_curl_validate_impl(curl)
  }

}

renv_curl_validate_impl <- function(curl) {

  # make sure we can run this copy of curl
  # note that 'system2()' will give an error if curl isn't runnable at all
  output <- suppressWarnings(
    tryCatch(
      system2(
        command = curl,
        args = "--version",
        stdout = TRUE,
        stderr = TRUE
      ),
      error = identity
    )
  )

  if (!inherits(output, "error")) {
    status <- attr(output, "status") %||% 0L
    if (status == 0L)
      return(curl)
  }

  message <- if (inherits(output, "error"))
    conditionMessage(output)
  else
    output

  fmt <- "Error executing '%s --version': is your copy of curl functional?"
  footer <- sprintf(fmt, curl)
  all <- c("", header(paste(curl, "--version"), prefix = "$"), message, "", footer)

  defer(
    message(paste(all, collapse = "\n")),
    scope = renv_dynamic_envir()
  )

  return(curl)

}

renv_curl_exe_missing <- function(curl) {

  if (!once())
    return(invisible(curl))

  parts <- c(
    "curl does not appear to be installed; downloads will fail.",
    "See <https://rstudio.github.io/renv/articles/renv.html#downloads> for more information."
  )

  msg <- paste(parts, collapse = "\n")
  warning(msg, call. = FALSE)

  invisible(curl)

}


# data_frame.R ---------------------------------------------------------------


data_frame <- function(...) {
  as_data_frame(list(...))
}

as_data_frame <- function(data) {

  # split matrices into columns
  if (is.matrix(data)) {
    result <- vector("list", ncol(data))
    names(result) <- colnames(data)
    dimnames(data) <- NULL
    for (i in seq_len(ncol(data)))
      result[[i]] <- data[, i]
    data <- result
  }

  # convert other objects to lists
  if (!is.list(data))
    data <- as.list(data)

  # recycle columns
  n <- lengths(data, use.names = FALSE)
  nrow <- max(n)

  # start recycling
  for (i in seq_along(data)) {
    if (n[[i]] == 0L) {
      length(data[[i]]) <- nrow
    } else if (n[[i]] != nrow) {
      data[[i]] <- rep.int(data[[i]], nrow / n[[i]])
    }
  }

  # set attributes
  class(data) <- "data.frame"
  attr(data, "row.names") <- .set_row_names(nrow)

  # return data
  data

}


# dcf.R ----------------------------------------------------------------------


# similar to base::read.dcf(), but:
# - allows for whitespace between fields
# - allows for non-indented field continuations
# - always keeps whitespace
renv_dcf_read <- function(file, text = NULL, ...) {

  # read file
  contents <- text %||% renv_dcf_read_impl(file, ...)

  # split on newlines
  parts <- strsplit(contents, "\\r?\\n(?=\\S)", perl = TRUE)[[1L]]

  # remove embedded newlines
  parts <- gsub("\\r?\\n\\s*", " ", parts, perl = TRUE)

  # split into key / value pairs
  index <- regexpr(":", parts, fixed = TRUE)
  keys <- substring(parts, 1L, index - 1L)
  vals <- substring(parts, index + 1L)

  # trim whitespace
  vals <- trimws(vals)

  # return early if everything looks fine
  ok <- nzchar(keys)
  if (all(ok)) {
    storage.mode(vals) <- "list"
    names(vals) <- keys
    return(vals)
  }

  # otherwise, fix up bad continuations
  starts <- which(ok)
  ends <- c(tail(starts - 1L, n = -1L), length(keys))
  vals <- .mapply(
    function(start, end) paste(vals[start:end], collapse = " "),
    list(starts, ends),
    NULL
  )

  # set up names
  names(vals) <- keys[ok]

  # done
  vals

}

renv_dcf_read_impl_encoding <- function(bytes) {

  # try to find encoding -- if none is declared, assume native encoding?
  start <- 0L
  while (TRUE) {

    # find 'Encoding'
    start <- grepRaw("Encoding:", bytes, fixed = TRUE, offset = start + 1L)
    if (length(start) == 0L)
      return(NULL)

    # check for preceding newline, or start of file
    if (start == 1L || bytes[[start - 1L]] == 0x0A) {
      start <- start + 9L
      break
    }

  }

  # find the end of the encoding field
  end <- grepRaw("\\r?\\n", bytes, offset = start + 1L)
  if (length(end) == 0L)
    end <- length(bytes)

  # pull it out
  field <- rawToChar(bytes[start:end])
  trimws(field)

}

renv_dcf_read_impl <- function(file, ...) {

  # suppress warnings in this scope
  renv_scope_options(warn = -1L)

  # first, read the file as bytes to get encoding
  # use a guess for the file size to avoid expensive lookup, but fallback
  # if necessary
  bytes <- readBin(file, what = "raw", n = 8192L)
  if (length(bytes) == 8192L) {
    n <- renv_file_size(file)
    bytes <- readBin(con = file, what = "raw", n = n)
  }

  # try to guess the encoding
  encoding <- renv_dcf_read_impl_encoding(bytes)

  # try a bunch of candidate encodings
  encodings <- c(encoding, "UTF-8", "latin1", "")
  for (encoding in unique(encodings)) {
    result <- iconv(list(bytes), from = encoding, to = "UTF-8")
    if (!is.na(result))
      return(result)
  }

  # all else fails, just pretend it's in the native encoding
  rawToChar(bytes)

}

renv_dcf_write <- function(x, file = "") {

  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)

  renv_filebacked_invalidate(file)

  invisible(result)

}


# deactivate.R ---------------------------------------------------------------

#' @rdname activate
#' @param clean If `TRUE`, will also remove the `renv/` directory and the
#'   lockfile.
#' @export
deactivate <- function(project = NULL, clean = FALSE) {

  renv_scope_error_handler()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  renv_infrastructure_remove_rprofile(project)

  unload(project)

  if (clean) {
    unlink(file.path(project, "renv.lock"))
    unlink(file.path(project, "renv"), recursive = TRUE, force = TRUE)
  }

  renv_restart_request(project, reason = "renv deactivated")
  invisible(project)

}


# debuggify.R ----------------------------------------------------------------


debuggify <- function(expr) {
  withCallingHandlers(expr, interrupt = renv_debuggify_dump)
}

renv_debuggify_dump <- function(cnd) {

  # print a backtrace
  status <- sys.status()
  calls <- head(status$sys.calls, n = -2L)
  frames <- head(status$sys.frames, n = -2L)
  traceback <- renv_error_format(calls, frames)
  caution(traceback)

  # print information about each frame
  n <- length(calls)
  for (i in seq_along(calls)) {
    renv_debuggify_dump_impl(
      index  = n - i + 1,
      call   = calls[[i]],
      frame  = frames[[i]]
    )
  }

}

renv_debuggify_dump_impl <- function(index, call, frame) {
  writeLines(header(paste("Frame", index)))
  vars <- ls(envir = frame, all.names = TRUE)
  lapply(vars, renv_debuggify_dump_impl_one, call = call, frame = frame)
  writeLines("")
}

renv_debuggify_dump_impl_one <- function(var, call, frame) {

  if (var %in% c("expr"))
    return("<promise>")

  str(frame[[var]])

}


# defer.R --------------------------------------------------------------------


# environment hosting exit callbacks
the$defer_callbacks <- new.env(parent = emptyenv())

defer <- function(expr, scope = parent.frame()) {

  handler <- renv_defer_add(
    list(expr = substitute(expr), envir = parent.frame()),
    envir = scope
  )

  invisible(handler)

}

renv_defer_id <- function(envir) {
  format.default(envir)
}

renv_defer_get <- function(envir) {
  id <- renv_defer_id(envir)
  the$defer_callbacks[[id]]
}

renv_defer_set <- function(envir, handlers) {

  # get any previously-set handlers. if we don't see any handlers registered,
  # this must be our first time registering exit handlers on the environment,
  # and so we'll want to register an on.exit handler to call our handlers
  oldhandlers <- renv_defer_get(envir)
  if (is.null(oldhandlers)) {
    call <- as.call(list(renv_defer_execute, envir))
    do.call(base::on.exit, list(substitute(call), TRUE), envir = envir)
  }

  # register the newly-set handlers
  id <- renv_defer_id(envir)
  the$defer_callbacks[[id]] <- handlers

}

renv_defer_remove <- function(envir) {
  id <- renv_defer_id(envir)
  rm(list = id, envir = the$defer_callbacks)
}

renv_defer_execute <- function(envir = parent.frame()) {

  # check for handlers -- may be NULL if they were intentionally executed
  # early via a call to `renv_defer_execute()`
  handlers <- renv_defer_get(envir)
  if (is.null(handlers))
    return()

  # execute the existing handlers
  for (handler in handlers)
    tryCatch(eval(handler$expr, handler$envir), error = identity)

  # remove the handlers
  renv_defer_remove(envir)

}

renv_defer_add <- function(envir, handler) {
  handlers <- c(list(handler), renv_defer_get(envir))
  renv_defer_set(envir, handlers)
  handler
}


# dependencies.R -------------------------------------------------------------


#' Find R package dependencies in a project
#'
#' @description
#' `dependencies()` will crawl 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(...)`)
#' .
#'
#' For \R package projects, dependencies expressed in the `DESCRIPTION` file
#' will also be discovered.
#'
#' Note that the rmarkdown package is required in order to crawl 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:
#'
#' ```{r eval=FALSE}
#' for (package in c("dplyr", "ggplot2")) {
#'   library(package, character.only = TRUE)
#' }
#' ```
#'
#' 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.
#'
#' 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
#' called `_dependencies.R` that includes straightforward library calls:
#'
#' ```
#' library(dplyr)
#' library(ggplot2)
#' 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
#' determine whether certain files or folders should be included when traversing
#' directories. If preferred, you can also create a `.renvignore` file (with
#' entries of the same format as a standard `.gitignore` file) to tell renv
#' which files to ignore within a directory. If both `.renvignore` and
#' `.gitignore` exist within a folder, the `.renvignore` will be used in lieu of
#' the `.gitignore`.
#'
#' See <https://git-scm.com/docs/gitignore> for documentation on the
#' `.gitignore` format. Some simple examples here:
#'
#' ```
#' # ignore all R Markdown files
#' *.Rmd
#'
#' # ignore all data folders
#' data/
#'
#' # ignore only data folders from the root of the project
#' /data/
#' ```
#'
#' 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.

#' # Errors
#'
#' renv's attempts to enumerate package dependencies in your project can fail
#' -- most commonly, because of failures when attempting to parse your \R code.
#' You can use the `errors` argument to suppress these problems, but a
#' more robust solution is tell renv not to look at the problematic code.
#' As well as using `.renvignore`, as described above, you can also suppress errors
#' discovered within individual `.Rmd` chunks by including `renv.ignore=TRUE`
#' in the chunk header. For example:
#'
#'     ```{r chunk-label, renv.ignore=TRUE}
#'     # code in this chunk will be ignored by renv
#'     ```
#'
#' Similarly, if you'd like renv to parse a chunk that is otherwise ignored
#' (e.g. because it has `eval=FALSE` as a chunk header), you can set:
#'
#'     ```{r chunk-label, eval=FALSE, renv.ignore=FALSE}
#'     # code in this chunk will _not_ be ignored
#'     ```
#'
#' # Development dependencies
#'
#' renv has some support for distinguishing between development and run-time
#' dependencies. For example, your Shiny app might rely on
#' [ggplot2](https://ggplot2.tidyverse.org) (a run-time dependency) but while
#' you use [usethis](https://usethis.r-lib.org) during development, your app
#' doesn't need it to run (i.e. it's only a development dependency).
#'
#' You can record development dependencies by listing them in the `Suggests`
#' field of your project's `DESCRIPTION` file. Development dependencies will be installed by
#' [renv::install()] (when called without arguments) but will not be tracked in
#' the project snapshot. If you need greater control, you can also try project
#' profiles as discussed in `vignette("profiles")`.
#'
#' @inheritParams renv-params
#'
#' @param path The path to a `.R`, `.Rmd`, `.qmd`, `DESCRIPTION`, a directory
#'   containing such files, or an R function. The default uses all files
#'   found within the current working directory and its children.
#'
#' @param root The root directory to be used for dependency discovery.
#'   Defaults to the active project directory. You may need to set this
#'   explicitly to ensure that your project's `.renvignore`s (if any) are
#'   properly handled.
#'
#' @param quiet Boolean; be quiet while checking for dependencies?
#'   Setting `quiet = TRUE` is equivalent to setting `progress = FALSE`
#'   and `errors = "ignored"`, and overrides those options when not `NULL`.
#'
#' @param progress Boolean; report progress output while enumerating
#'   dependencies?
#'
#' @param errors How should errors that occur during dependency enumeration be
#'   handled?
#'
#'   * `"reported"` (the default): errors are reported to the user, but
#'      otherwise ignored.
#'   * `"fatal"`: errors are fatal and stop execution.
#'   *  `"ignored"`: errors are ignored and not reported to the user.
#'
#' @param dev Boolean; include development dependencies? These packages are
#'   typically required when developing the project, but not when running it
#'   (i.e. you want them installed when humans are working on the project but
#'   not when computers are deploying it).
#'
#'   Development dependencies include packages listed in the `Suggests` field
#'   of a `DESCRIPTION` found in the project root, and roxygen2 or devtools if
#'   their use is implied by other project metadata. They also include packages
#'   used in `~/.Rprofile` if `config$user.profile()` is `TRUE`.
#'
#' @return An \R `data.frame` of discovered dependencies, mapping inferred
#'   package names to the files in which they were discovered. Note that the
#'   `Package` field might name a package remote, rather than just a plain
#'   package name.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # find R package dependencies in the current directory
#' renv::dependencies()
#'
#' }
dependencies <- function(
  path = getwd(),
  root = NULL,
  ...,
  quiet = NULL,
  progress = TRUE,
  errors = c("reported", "fatal", "ignored"),
  dev = FALSE)
{
  renv_scope_error_handler()

  # special case: if 'path' is a function, parse its body for dependencies
  if (is.function(path))
    return(renv_dependencies_discover_r(expr = body(path)))

  renv_dependencies_impl(
    path     = path,
    root     = root,
    quiet    = quiet,
    progress = progress,
    errors   = errors,
    dev      = dev,
    ...
  )
}

renv_dependencies_impl <- function(
  path = getwd(),
  ...,
  root = NULL,
  field = NULL,
  quiet = NULL,
  progress = FALSE,
  errors = c("reported", "fatal", "ignored"),
  dev = FALSE)
{
  renv_dots_check(...)

  path <- renv_path_normalize(path, mustWork = TRUE)
  root <- root %||% renv_dependencies_root(path)

  # handle 'quiet' parameter
  if (quiet %||% FALSE) {
    progress <- FALSE
    errors <- "ignored"
  }

  # ignore errors when testing, unless explicitly asked for
  if (renv_tests_running() && missing(errors))
    errors <- "ignored"

  # resolve errors
  errors <- match.arg(errors)

  before <- Sys.time()
  renv_dependencies_scope(root = root)
  files <- renv_dependencies_find(path, root)
  deps <- renv_dependencies_discover(files, progress, errors)
  after <- Sys.time()
  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))
  }

  take(deps, field)
}

renv_dependencies_root <- function(path = getwd()) {

  path <- renv_path_normalize(path, mustWork = TRUE)

  project <- renv_project_get(default = NULL)
  if (!is.null(project) && all(renv_path_within(path, project)))
    return(project)

  roots <- uapply(path, renv_dependencies_root_impl)
  if (empty(roots))
    return(NULL)

  uniroot <- unique(roots)
  if (length(uniroot) > 1)
    return(NULL)

  uniroot

}

renv_dependencies_root_impl <- function(path) {

  renv_file_find(path, function(parent) {
    anchors <- c("DESCRIPTION", ".git", ".Rproj.user", "renv.lock", "renv")
    for (anchor in anchors)
      if (file.exists(file.path(parent, anchor)))
        return(parent)
  })

}

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(
    ".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),
    "renv.lock"     = function(path) renv_dependencies_discover_renv_lock(path),
    "rsconnect"     = function(path) renv_dependencies_discover_rsconnect(path)
  )

  cbext <- list(
    ".rproj"       = function(path) renv_dependencies_discover_rproj(path),
    ".r"           = function(path) renv_dependencies_discover_r(path),
    ".qmd"         = function(path) renv_dependencies_discover_multimode(path, "qmd"),
    ".rmd"         = function(path) renv_dependencies_discover_multimode(path, "rmd"),
    ".rmarkdown"   = function(path) renv_dependencies_discover_multimode(path, "rmd"),
    ".rnw"         = function(path) renv_dependencies_discover_multimode(path, "rnw"),
    ".ipynb"       = function(path) renv_dependencies_discover_ipynb(path)
  )

  name <- basename(path)
  ext  <- tolower(fileext(path))

  callback <- cbname[[name]] %||% cbext[[ext]]
  if (!is.null(callback))
    return(callback)

  # for files without an extension, check if those might be executable by R
  if (!nzchar(ext)) {
    shebang <- renv_file_shebang(path)
    if (grepl("\\b(?:R|r|Rscript)\\b", shebang))
      return(function(path) renv_dependencies_discover_r(path))
  }

}

renv_dependencies_find_extra <- function(root) {

  # if we don't have a root, we don't have a project
  if (is.null(root))
    return(NULL)

  # only run for root-level dependency checks
  project <- renv_project_resolve()
  if (!renv_path_same(root, project))
    return(NULL)

  # only run if we have a custom profile
  profile <- renv_profile_get()
  if (is.null(profile))
    return(NULL)

  # look for dependencies in the associated 'renv' folder
  path <- renv_paths_renv(project = project)
  renv_dependencies_find_impl(path, root, 0L)

}

renv_dependencies_find <- function(path = getwd(), root = getwd()) {
  files <- lapply(path, renv_dependencies_find_impl, root = root, depth = 0)
  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)
    }
  }

  unlist(c(files, extra), recursive = TRUE, use.names = FALSE)
}

renv_dependencies_find_impl <- function(path, root, depth) {

  # check file type
  info <- renv_file_info(path)

  # the file might have been removed after listing -- if so, just ignore it
  if (is.na(info$isdir))
    return(NULL)

  # if this is a directory, recurse
  if (info$isdir)
    return(renv_dependencies_find_dir(path, root, depth))

  path
}

renv_dependencies_find_dir <- function(path, root, depth) {

  # check if this path should be ignored
  excluded <- renv_renvignore_exec(path, root, path)
  if (excluded)
    return(character())

  # check if we've already scanned this directory
  # (necessary to guard against recursive symlinks)
  if (!renv_platform_windows()) {
    norm <- renv_path_normalize(path)
    state <- renv_dependencies_state()
    if (visited(norm, state$scanned))
      return(character())
  }

  # list children
  children <- renv_dependencies_find_dir_children(path, root, depth)

  # notify about number of children
  renv_condition_signal("renv.dependencies.count", list(path = path, count = length(children)))

  # find recursive dependencies
  depth <- depth + 1
  paths <- map(children, renv_dependencies_find_impl, root = root, depth = depth)

  # explicitly include rsconnect folder
  # (so we can infer a dependency on rsconnect when appropriate)
  rsconnect <- file.path(path, "rsconnect")
  if (file.exists(rsconnect))
    paths <- c(rsconnect, paths)

  paths

}

# return the set of files / subdirectories within a directory that should be
# crawled for dependencies
renv_dependencies_find_dir_children <- function(path, root, depth) {

  # list files in the folder
  children <- renv_file_list(path, full.names = TRUE)

  # skip if this contains too many files
  # https://github.com/rstudio/renv/issues/1186
  count <- length(children)
  if (count >= config$dependencies.limit()) {
    relpath <- renv_path_relative(path, dirname(root))
    renv_dependencies_find_dir_children_overload(relpath, count)
  }

  # remove files which are broken symlinks
  children <- children[file.exists(children)]

  # remove hard-coded ignores
  # (only keep DESCRIPTION files at the top level)
  ignored <- c("packrat", "renv", "revdep", "vendor", if (depth) c("DESCRIPTION", "NAMESPACE"))
  children <- children[!basename(children) %in% ignored]

  # compute exclusions
  excluded <- renv_renvignore_exec(path, root, children)

  # keep only non-excluded children
  children[!excluded]

}

renv_dependencies_find_dir_children_overload <- function(path, count) {

  # check for missing state (e.g. if internal method called directly)
  state <- renv_dependencies_state()
  if (is.null(state))
    return()

  fmt <- "directory contains %s; consider ignoring this directory"
  msg <- sprintf(fmt, nplural("file", count))
  error <- simpleError(message = msg)

  path <- path %||% state$path
  problem <- list(file = path, error = error)
  state$problems$push(problem)

}

renv_dependencies_discover <- function(paths, progress, errors) {

  if (!renv_dependencies_discover_preflight(paths, errors))
    return(invisible(list()))

  # short path if we're not showing progress
  if (identical(progress, FALSE))
    return(bapply(paths, renv_dependencies_discover_impl))

  # otherwise, run with progress reporting

  # nocov start
  printf("Finding R package dependencies ... ")
  callback <- renv_progress_callback(renv_dependencies_discover_impl, length(paths))
  deps <- lapply(paths, callback)
  writef("Done!")

  bind(deps)
  # nocov end

}

renv_dependencies_discover_impl <- function(path) {

  callback <- renv_dependencies_callback(path)
  if (is.null(callback)) {
    return(NULL)
  }

  tryCatch(
    filebacked("dependencies", path, callback),
    error = function(cnd) {
      warning(cnd)
      NULL
    }
  )

}

renv_dependencies_discover_preflight <- function(paths, errors) {

  if (identical(errors, "ignored"))
    return(TRUE)

  if (length(paths) < config$dependencies.limit())
    return(TRUE)

  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.",
    "Consider using .renvignore to ignore irrelevant files.",
    "See `?renv::dependencies` for more information.",
    "Set `options(renv.config.dependencies.limit = Inf)` to disable this warning.",
    ""
  )
  writef(lines, length(paths))

  if (identical(errors, "reported"))
    return(TRUE)

  cancel_if(interactive() && !proceed())

  TRUE

}

renv_dependencies_discover_renv_lock <- function(path) {
  renv_dependencies_list(path, "renv")
}

renv_dependencies_discover_description_fields <- function(path, project = NULL) {

  # most callers don't pass in project so we need to get it from global state
  project <- project %||%
    renv_dependencies_state(key = "root") %||%
    renv_restore_state(key = "root") %||%
    renv_project_resolve()

  # by default, respect fields defined in settings
  fields <- settings$package.dependency.fields(project = project)

  # if this appears to be the DESCRIPTION associated with the active project,
  # and an explicit set of dependencies was provided in install, then use those
  if (renv_path_same(file.path(project, "DESCRIPTION"), path)) {
    default <- the$install_dependency_fields %||% c(fields, "Suggests")
    profile <- sprintf("Config/renv/profiles/%s/dependencies", renv_profile_get())
    fields <- c(default, profile)
  }

  fields

}

renv_dependencies_discover_description <- function(path,
                                                   fields = NULL,
                                                   subdir = NULL,
                                                   project = NULL)
{
  dcf <- catch(renv_description_read(path = path, subdir = subdir))
  if (inherits(dcf, "error"))
    return(renv_dependencies_error(path, error = dcf))

  # resolve the dependency fields to be used
  fields <- fields %||% renv_dependencies_discover_description_fields(path, project)

  # make sure dependency fields are expanded
  fields <- renv_description_dependency_fields_expand(fields)

  data <- map(
    fields,
    renv_dependencies_discover_description_impl,
    dcf  = dcf,
    path = path
  )

  # if this is a bioconductor package, add their implicit dependencies
  if ("biocViews" %in% names(dcf)) {
    data[[length(data) + 1L]] <- renv_dependencies_list(
      source = path,
      packages = c(renv_bioconductor_manager(), "BiocVersion")
    )
  }

  bind(data)

}

renv_dependencies_discover_namespace <- function(path) {

  tryCatch(
    renv_dependencies_discover_namespace_impl(path),
    error = warnify
  )

}

renv_dependencies_discover_namespace_impl <- function(path) {

  # parseNamespaceFile() expects to be called on an installed package,
  # so we have to pretend our best here
  library <- dirname(dirname(path))
  package <- basename(dirname(path))
  info <- parseNamespaceFile(
    package     = package,
    package.lib = library,
    mustExist   = TRUE
  )

  # read package names from imports
  packages <- map_chr(info$imports, `[[`, 1L)

  renv_dependencies_list(
    source   = path,
    packages = sort(unique(packages))
  )

}

renv_dependencies_discover_description_impl <- function(dcf, field, path) {

  # read field
  contents <- dcf[[field]]
  if (!is.character(contents))
    return(list())

  # split on commas
  parts <- strsplit(dcf[[field]], "\\s*,\\s*")[[1]]

  # drop any empty fields
  x <- parts[nzchar(parts)]

  # match to split on remote, version
  pattern <- paste0(
    "([^,\\([:space:]]+)",                    # remote name
    "(?:\\s*\\(([><=]+)\\s*([0-9.-]+)\\))?"   # optional version specification
  )

  m <- regexec(pattern, x)
  matches <- regmatches(x, m)
  if (empty(matches))
    return(list())

  # create dependency list
  renv_dependencies_list(
    path,
    extract_chr(matches, 2L),
    extract_chr(matches, 3L),
    extract_chr(matches, 4L),
    dev = field == "Suggests"
  )

}

renv_dependencies_discover_bookdown <- function(path) {
  # TODO: other dependencies to parse from bookdown?
  renv_dependencies_list(path, "bookdown")
}

renv_dependencies_discover_pkgdown <- function(path) {
  # TODO: other dependencies to parse from pkgdown?
  renv_dependencies_list(path, "pkgdown")
}

renv_dependencies_discover_quarto <- function(path) {
  # TODO: other dependencies to parse from quarto?
  #
  # NOTE: we previously inferred a dependency on the R 'quarto' package here,
  # but quarto is normally invoked directly (rather than via the package) and
  # so such a dependency is not strictly necessary.
  #
  # https://github.com/rstudio/renv/issues/995
  renv_dependencies_list_empty()
}

renv_dependencies_discover_rsconnect <- function(path) {
  renv_dependencies_list(path, "rsconnect")
}

renv_dependencies_discover_multimode <- function(path, mode) {

  # TODO: find in-line R code?
  deps <- stack()

  if (mode %in% c("rmd", "qmd"))
    deps$push(renv_dependencies_discover_rmd_yaml_header(path, mode))

  deps$push(renv_dependencies_discover_chunks(path, mode))

  bind(Filter(NROW, deps$data()))

}

renv_dependencies_discover_rmd_yaml_header <- function(path, mode) {

  deps <- stack(mode = "character")

  # R Markdown documents always depend on rmarkdown
  if (identical(mode, "rmd"))
    deps$push("rmarkdown")

  # try and read the document's YAML header
  contents <- renv_file_read(path)
  pattern <- "(?:^|\n)\\s*---\\s*(?:$|\n)"
  matches <- gregexpr(pattern, contents, perl = TRUE)[[1L]]

  # check that we have something that looks like a YAML header
  ok <- length(matches) > 1L && matches[[1L]] == 1L
  if (!ok)
    return(renv_dependencies_list(path, packages = deps$data()))

  # require yaml package for parsing YAML header
  name <- case(
    mode == "rmd" ~ "R Markdown",
    mode == "qmd" ~ "Quarto Markdown"
  )

  # validate that we actually have the yaml package available
  if (!renv_dependencies_require("yaml", name)) {
    packages <- deps$data()
    return(renv_dependencies_list(path, packages))
  }

  # extract YAML text
  yamltext <- substring(contents, matches[[1L]] + 4L, matches[[2L]] - 1L)
  yaml <- catch(renv_yaml_load(yamltext))
  if (inherits(yaml, "error"))
    return(renv_dependencies_error(path, error = yaml, packages = "rmarkdown"))

  # check for Shiny runtime
  runtime <- yaml[["runtime"]] %||% ""
  if (pstring(runtime) && grepl("shiny", runtime, fixed = TRUE))
    deps$push("shiny")

  server <- yaml[["server"]] %||% ""
  if (identical(server, "shiny"))
    deps$push("shiny")

  if (is.list(server) && identical(server[["type"]], "shiny"))
    deps$push("shiny")

  pattern <- renv_regexps_package_name()

  # check recursively for package usages of the form 'package::method'
  recurse(yaml, function(node, stack) {
    # 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)) {
        deps$push(as.character(call[[2L]]))
      }
    }

  })

  # check for dependency on bslib
  theme <- catchall(yaml[[c("output", "html_document", "theme")]])
  if (!inherits(theme, "error") && is.list(theme))
    deps$push("bslib")

  # check for parameterized documents
  status <- catch(renv_dependencies_discover_rmd_yaml_header_params(yaml, deps))
  if (inherits(status, "error"))
    renv_dependencies_error_push(path, status)

  # get list of dependencies
  packages <- deps$data()
  renv_dependencies_list(path, packages)

}

renv_dependencies_discover_rmd_yaml_header_params <- function(yaml, deps) {

  # check for declared params
  params <- yaml[["params"]]
  if (!is.list(params))
    return()

  # infer dependency on shiny
  deps$push("shiny")

  # iterate through params, parsing dependencies from R code
  for (param in params) {

    # check for r types
    type <- attr(param, "type", exact = TRUE)
    if (!identical(type, "r"))
      next

    # attempt to parse dependencies
    rdeps <- catch(renv_dependencies_discover_r(text = param))
    if (inherits(rdeps, "error"))
      next

    # add each dependency
    for (package in sort(unique(rdeps$Package)))
      deps$push(package)

  }

}

renv_dependencies_discover_chunks_ignore <- function(chunk) {

  # if renv.ignore is set, respect it
  ignore <- chunk$params[["renv.ignore"]]
  if (!is.null(ignore))
    return(truthy(ignore))

  # skip non-R chunks
  engine <- chunk$params[["engine"]]
  ok <- is.character(engine) && engine %in% c("r", "rscript")
  if (!ok)
    return(TRUE)

  # skip un-evaluated chunks
  if (!truthy(chunk$params[["eval"]], default = TRUE))
    return(TRUE)

  # skip learnr exercises
  if (truthy(chunk$params[["exercise"]], default = FALSE))
    return(TRUE)

  # skip chunks whose labels end in '-display'
  label <- chunk$params[["label"]] %||% ""
  if (grepl("-display$", label))
    return(TRUE)

  # ok, don't ignore this chunk
  FALSE

}

renv_dependencies_discover_chunks <- function(path, mode) {

  # figure out the appropriate begin, end patterns
  type <- tolower(file_ext(path))
  if (type %in% c("rmd", "qmd", "rmarkdown"))
    type <- "md"

  allpatterns <- renv_knitr_patterns()
  patterns <- allpatterns[[type]]
  if (is.null(patterns)) {
    condition <- simpleCondition("not a recognized multi-mode R document")
    return(renv_dependencies_error(path, error = condition))
  }

  # parse the chunks within
  # NOTE: we need to proceed line-by-line since the chunk end pattern might
  # end chunks not started by the chunk begin pattern (sad face)
  encoding <- if (type == "md") "UTF-8" else "unknown"
  contents <- readLines(path, warn = FALSE, encoding = encoding)
  ranges <- renv_dependencies_discover_chunks_ranges(path, contents, patterns)

  # extract chunk code from the used ranges
  chunks <- .mapply(function(lhs, rhs) {

    # parse params in header
    header <- contents[[lhs]]
    params <- renv_knitr_options_header(header, type)

    # extract chunk contents (preserve newlines for nicer error reporting)
    range <- seq.int(lhs + 1, length.out = rhs - lhs - 1)
    code <- rep.int("", length(contents))
    code[range] <- contents[range]

    # also parse chunk options
    params <- overlay(params, renv_knitr_options_chunk(code))

    # return list of outputs
    list(params = params, code = code)

  }, ranges, NULL)

  # iterate over chunks, and attempt to parse dependencies from each
  cdeps <- bapply(chunks, function(chunk) {

    # check whether this chunk should be ignored
    if (renv_dependencies_discover_chunks_ignore(chunk))
      return(character())

    # remove reused chunk placeholders
    pattern <- "<<[^>]+>>"
    code <- gsub(pattern, "", chunk$code)

    # okay, now we can discover deps
    deps <- catch(renv_dependencies_discover_r(path = path, text = code))
    if (inherits(deps, "error"))
      return(renv_dependencies_error(path, error = deps))

    deps

  })

  # check for dependencies in inline chunks as well
  ideps <- renv_dependencies_discover_chunks_inline(path, contents)

  # if this is a .qmd, infer a dependency on rmarkdown if we have any R chunks
  qdeps <- NULL
  if (mode %in% "qmd") {
    for (chunk in chunks) {
      engine <- chunk$params[["engine"]]
      if (is.character(engine) && engine %in% c("r", "rscript")) {
        qdeps <- renv_dependencies_list(path, "rmarkdown")
        break
      }
    }
  }

  # paste them all together
  deps <- bind(list(cdeps, ideps, qdeps))
  if (is.null(deps))
    return(deps)

  deps$Source <- path
  deps

}

renv_dependencies_discover_chunks_inline <- function(path, contents) {

  pasted <- paste(contents, collapse = "\n")
  matches <- gregexpr("`r ([^`]+)`", pasted, perl = TRUE)
  if (identical(c(matches[[1L]]), -1L))
    return(list())

  text <- unlist(regmatches(pasted, matches), use.names = FALSE, recursive = FALSE)
  code <- substring(text, 4L, nchar(text) - 1L)
  deps <- renv_dependencies_discover_r(path = path, text = code)
  if (inherits(deps, "error"))
    return(renv_dependencies_error(path, error = deps))

  deps

}

renv_dependencies_discover_chunks_ranges <- function(path, contents, patterns) {

  output <- list()

  chunk <- FALSE
  start <- 1; end <- 1
  for (i in seq_along(contents)) {

    line <- contents[[i]]

    if (chunk == FALSE && grepl(patterns$chunk.begin, line)) {
      chunk <- TRUE
      start <- i
      next
    }

    if (chunk == TRUE && grepl(patterns$chunk.begin, line)) {
      end <- i
      output[[length(output) + 1]] <- list(lhs = start, rhs = end)
      start <- i
      next
    }

    if (chunk == TRUE && grepl(patterns$chunk.end, line)) {
      chunk <- FALSE
      end <- i
      output[[length(output) + 1]] <- list(lhs = start, rhs = end)
      next
    }

  }

  if (chunk) {
    message <- sprintf("chunk starting on line %i is not closed", start)
    error <- simpleError(message)
    renv_dependencies_error(path, error = error)
  }

  bind(output)

}

renv_dependencies_discover_ipynb <- function(path) {

  json <- renv_json_read(path)
  if (!identical(json$metadata$kernelspec$language, "R"))
    return()

  deps <- stack()
  if (identical(json$metadata$kernelspec$name, "ir"))
    deps$push(renv_dependencies_list(path, "IRkernel"))

  for (cell in json$cells) {
    if (cell$cell_type != "code")
      next

    code <- paste0(cell$source, collapse = "")
    deps$push(renv_dependencies_discover_r(path, text = code))
  }

  bind(deps$data())

}

renv_dependencies_discover_rproj <- function(path) {

  props <- renv_properties_read(path)

  deps <- stack()
  if (identical(props$PackageUseDevtools, "Yes")) {
    deps$push("devtools")
    deps$push("roxygen2")
  }

  renv_dependencies_list(path, deps$data(), dev = TRUE)

}

renv_dependencies_discover_r <- function(path = NULL,
                                         text = NULL,
                                         expr = NULL,
                                         envir = NULL,
                                         dev = FALSE)
{
  expr <- case(
    is.function(expr)  ~ body(expr),
    is.language(expr)  ~ expr,
    is.character(expr) ~ catch(renv_parse_text(expr)),
    is.character(text) ~ catch(renv_parse_text(text)),
    is.character(path) ~ catch(renv_parse_file(path)),
    ~ stop("internal error")
  )

  if (inherits(expr, "error"))
    return(renv_dependencies_error(path, error = expr))

  # update current path
  state <- renv_dependencies_state()
  if (!is.null(state))
    renv_scope_binding(state, "path", path)

  methods <- c(
    renv_dependencies_discover_r_methods,
    renv_dependencies_discover_r_xfun,
    renv_dependencies_discover_r_library_require,
    renv_dependencies_discover_r_require_namespace,
    renv_dependencies_discover_r_colon,
    renv_dependencies_discover_r_pacman,
    renv_dependencies_discover_r_modules,
    renv_dependencies_discover_r_import,
    renv_dependencies_discover_r_box,
    renv_dependencies_discover_r_targets,
    renv_dependencies_discover_r_glue,
    renv_dependencies_discover_r_parsnip,
    renv_dependencies_discover_r_database
  )

  envir <- envir %||% new.env(parent = emptyenv())
  recurse(expr, function(node, stack) {

    # normalize calls (handle magrittr pipes)
    node <- renv_call_normalize(node, stack)

    # invoke methods on call objects
    if (is.call(node))
      for (method in methods)
        method(node, stack, envir)

    # return node
    node

  })

  packages <- ls(envir = envir, all.names = TRUE)
  renv_dependencies_list(path, packages, dev = dev)
}

renv_dependencies_discover_r_methods <- function(node, stack, envir) {

  node <- renv_call_expect(node, "methods", c("setClass", "setGeneric"))
  if (is.null(node))
    return(FALSE)

  envir[["methods"]] <- TRUE
  TRUE

}

renv_dependencies_discover_r_xfun <- function(node, stack, envir) {

  node <- renv_call_expect(node, "xfun", c("pkg_attach", "pkg_attach2"))
  if (is.null(node))
    return(FALSE)

  # attempt to match the call
  prototype <- function(..., install = FALSE, message = TRUE) {}
  matched <- catch(match.call(prototype, node, expand.dots = FALSE))
  if (inherits(matched, "error"))
    return(FALSE)

  # extract character vectors from `...`
  strings <- stack()
  recurse(matched[["..."]], function(node, stack) {
    if (is.character(node))
      strings$push(node)
  })

  # mark packages as known
  packages <- strings$data()
  if (empty(packages))
    return(FALSE)

  for (package in packages)
    envir[[package]] <- TRUE

  TRUE
}

renv_dependencies_discover_r_library_require <- function(node, stack, envir) {

  node <- renv_call_expect(node, "base", c("library", "require"))
  if (is.null(node))
    return(FALSE)

  # attempt to match the call
  matched <- catch(match.call(base::library, node))
  if (inherits(matched, "error"))
    return(FALSE)

  # if the 'package' argument is a character vector of length one, we're done
  if (is.character(matched$package) &&
      length(matched$package) == 1)
  {
    envir[[matched$package]] <- TRUE
    return(TRUE)
  }

  # if it's a symbol, double check character.only argument
  if (is.symbol(matched$package) &&
      identical(matched$character.only %||% FALSE, FALSE))
  {
    envir[[as.character(matched$package)]] <- TRUE
    return(TRUE)
  }

  FALSE

}

renv_dependencies_discover_r_require_namespace <- function(node, stack, envir) {

  node <- renv_call_expect(node, "base", c("requireNamespace", "loadNamespace"))
  if (is.null(node))
    return(FALSE)

  f <- get(as.character(node[[1]]), envir = .BaseNamespaceEnv, inherits = FALSE)
  matched <- catch(match.call(f, node))
  if (inherits(matched, "error"))
    return(FALSE)

  package <- matched$package
  if (is.character(package) && length(package == 1)) {
    envir[[package]] <- TRUE
    return(TRUE)
  }

  FALSE


}

renv_dependencies_discover_r_colon <- function(node, stack, envir) {

  ok <- renv_call_matches(node, name = c("::", ":::"), n_args = 2)

  if (!ok)
    return(FALSE)

  package <- node[[2L]]
  if (is.symbol(package))
    package <- as.character(package)

  if (!is.character(package) || length(package) != 1)
    return(FALSE)

  envir[[package]] <- TRUE
  TRUE

}

renv_dependencies_discover_r_pacman <- function(node, stack, envir) {

  node <- renv_call_expect(node, "pacman", "p_load")
  if (is.null(node) || length(node) < 2)
    return(FALSE)

  # check for character.only
  chonly <- node[["character.only"]] %||% FALSE

  # consider all unnamed arguments
  parts <- as.list(node[-1L])

  # consider packages passed to 'char' parameter
  char <- node[["char"]]

  # detect vector of packages passed as vector
  if (renv_call_matches(char, name = "c"))
    parts <- c(parts, as.list(char[-1L]))

  # detect plain old package name
  if (is.character(char))
    parts <- c(parts, as.list(char))

  # ensure names
  names(parts) <- names(parts) %||% rep.int("", length(parts))
  unnamed <- parts[!nzchar(names(parts))]

  # extract symbols / characters
  for (arg in unnamed) {

    # skip symbols if necessary
    if (chonly && is.symbol(arg))
      next

    # check for character or symbol
    ok <-
      length(arg) == 1 &&
      is.character(arg) ||
      is.symbol(arg)

    if (!ok)
      next

    # add it
    envir[[as.character(arg)]] <- TRUE

  }

  TRUE

}

renv_dependencies_discover_r_modules <- function(node, stack, 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)

  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
      }
    }
  }

  if (!ok)
    return(FALSE)

  # attempt to match the call
  prototype <- function(from, ..., attach = TRUE, where = parent.frame()) {}
  matched <- catch(match.call(prototype, node, expand.dots = FALSE))
  if (inherits(matched, "error"))
    return(FALSE)

  # extract character vector or symbol from `from`
  package <- matched[["from"]]
  if (empty(package))
    return(FALSE)

  # 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) {

  node <- renv_call_expect(node, "import", c("from", "here", "into"))
  if (is.null(node))
    return(FALSE)

  # attempt to match the call
  name <- as.character(node[[1L]])
  matched <- if (name == "from") {
    catch(match.call(function(.from, ...) {}, node, expand.dots = FALSE))
  } else {
    catch(match.call(function(..., .from) {}, node, expand.dots = FALSE))
  }

  if (inherits(matched, "error"))
    return(FALSE)

  # 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 (!ok)
    return(FALSE)

  envir[[from]] <- TRUE
  TRUE

}

renv_dependencies_discover_r_box <- function(node, stack, envir) {

  node <- renv_call_expect(node, "box", "use")
  if (is.null(node))
    return(FALSE)

  for (i in seq.int(2L, length.out = length(node) - 1L))
    renv_dependencies_discover_r_box_impl(node[[i]], stack, envir)

  TRUE

}

renv_dependencies_discover_r_box_impl <- function(node, stack, envir) {

  # if the call uses /, it's a path, not a package
  while (renv_call_matches(node, name = "/"))
    return(FALSE)

  # if the node is just a symbol, then it's the name of a package
  # otherwise, if it's a call to `[`, the first argument is the package name
  name <- if (is.symbol(node) && !identical(node, quote(expr = ))) {
    as.character(node)
  } else if (
    renv_call_matches(node, name = "[") &&
      length(node) > 1L &&
      is.symbol(node[[2L]])) {
    as.character(node[[2L]])
  }

  # the names `.` and `..` are special place holders and don't refer to packages
  if (is.null(name) || name == "." || name == "..")
    return(FALSE)

  envir[[name]] <- TRUE
  TRUE

}

renv_dependencies_discover_r_targets <- function(node, stack, envir) {

  node <- renv_call_expect(node, "targets", "tar_option_set")
  if (is.null(node))
    return(FALSE)

  envir[["targets"]] <- TRUE

  packages <- tryCatch(
    renv_dependencies_eval(node$packages),
    error = identity
  )

  # TODO: evaluation can fail for a multitude of reasons;
  # are any of these worth signalling to the user?
  if (inherits(packages, "error"))
    return(TRUE)

  if (is.character(packages))
    for (package in packages)
      envir[[package]] <- TRUE

  TRUE

}

renv_dependencies_discover_r_glue <- function(node, stack, envir) {

  node <- renv_call_expect(node, "glue", "glue")
  if (is.null(node))
    return(FALSE)

  # analyze all unnamed strings in the call
  args <- as.list(node)[-1L]
  nm <- names(args) %||% rep.int("", length(args))
  strings <- args[!nzchar(nm) & map_lgl(args, is.character)]

  # start iterating through the strings, looking for code chunks
  for (string in strings)
    renv_dependencies_discover_r_glue_impl(string, node, envir)

  TRUE

}

renv_dependencies_discover_r_glue_impl <- function(string, node, envir) {

  # get open, close delimiters
  ropen    <- charToRaw(node$.open    %||% "{")
  rclose   <- charToRaw(node$.close   %||% "}")
  rcomment <- charToRaw(node$.comment %||% "#")

  # constants
  rcomment   <- charToRaw("#")
  rbackslash <- charToRaw("\\")
  rquotes <- c(
    charToRaw("'"),
    charToRaw("\""),
    charToRaw("`")
  )

  # iterate through characters in string
  raw <- c(charToRaw(string), as.raw(0L))
  i <- 0L
  n <- length(raw)
  quote <- raw()

  # index for open delimiter match
  index <- 0L
  count <- 0L

  while (i < n) {

    # ensure we always advance index
    i <- i + 1L

    # handle quoted states
    if (length(quote)) {

      # skip escaped characters
      if (raw[[i]] == rbackslash) {
        i <- i + 1L
        next
      }

      # check for escape from quote
      if (raw[[i]] == quote) {
        quote <- raw()
        next
      }

    }

    # skip comments
    if (raw[[i]] == rcomment) {
      i <- grepRaw("(?:$|\n)", raw, i)
      next
    }

    # skip escaped characters
    if (raw[[i]] == rbackslash) {
      i <- i + 1L
      next
    }

    # check for quotes
    idx <- match(raw[[i]], rquotes, nomatch = 0L)
    if (idx > 0) {
      quote <- rquotes[[idx]]
      next
    }

    # check for open delimiter
    if (i %in% grepRaw(ropen, raw, i, fixed = TRUE)) {

      # check for duplicate (escape)
      j <- i + length(ropen)
      if (j %in% grepRaw(ropen, raw, j, fixed = TRUE)) {
        i <- j + length(ropen) - 1L
        next
      }

      # save index if we're starting a match
      if (count == 0L) {
        index <- i
      }

      # increment match count
      count <- count + 1L
      next

    }

    # check for close delimiter
    if (i %in% grepRaw(rclose, raw, i, fixed = TRUE)) {

      # check for duplicate (escape)
      j <- i + length(rclose)
      if (j %in% grepRaw(rclose, raw, j, fixed = TRUE)) {
        i <- j + length(rclose) - 1L
        next
      }

      if (count > 0L) {

        # decrement count if we have a match
        count <- count - 1L

        # check for match and parse dependencies within
        if (count == 0L) {

          # extract inner code
          lhs <- index + length(ropen)
          rhs <- i - 1L
          code <- rawToChar(raw[lhs:rhs])

          # parse dependencies
          renv_dependencies_discover_r(text = code, envir = envir)

        }

      }

    }

  }

}

renv_dependencies_discover_r_parsnip <- function(node, stack, envir) {

  node <- renv_call_expect(node, "parsnip", "set_engine")
  if (is.null(node))
    return(FALSE)

  matched <- catch(match.call(function(object, engine, ...) {}, node))
  if (inherits(matched, "error"))
    return(FALSE)

  engine <- matched$engine
  if (!is.character(engine) || length(engine) != 1L)
    return(FALSE)

  map <- getOption("renv.parsnip.engines", default = list(
    glm    = "stats",
    glmnet = "glmnet",
    keras  = "keras",
    kknn   = "kknn",
    nnet   = "nnet",
    rpart  = "rpart",
    spark  = "sparklyr",
    stan   = "rstanarm"
  ))

  packages <- if (is.function(map))
    tryCatch(map(engine), error = function(e) NULL)
  else
    map[[engine]]

  if (is.null(packages))
    return(FALSE)

  for (package in packages)
    envir[[package]] <- TRUE

  # TODO: a number of model routines appear to depend on dials;
  # should we just assume it's required by default? or should
  # users normally be using tidymodels instead of parsnip directly?
  TRUE

}

renv_dependencies_discover_r_database <- function(node, stack, envir) {

  found <- FALSE

  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

      found <<- TRUE
      TRUE

    })
  })

  found

}

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
}

renv_dependencies_list <- function(source,
                                   packages,
                                   require = "",
                                   version = "",
                                   dev = FALSE)
{
  if (empty(packages))
    return(renv_dependencies_list_empty())

  source <- source %||% rep.int(NA_character_, length(packages))

  data_frame(
    Source  = as.character(source),
    Package = as.character(packages),
    Require = require,
    Version = version,
    Dev     = dev
  )

}

renv_dependencies_list_empty <- function() {

  data_frame(
    Source  = character(),
    Package = character(),
    Require = character(),
    Version = character(),
    Dev     = logical()
  )

}

renv_dependencies_require <- function(package, type = NULL) {

  if (requireNamespace(package, quietly = TRUE))
    return(TRUE)

  if (once()) {

    fmt <- lines(
      "The '%1$s' package is required to parse dependencies within %2$s",
      "Consider installing it with `install.packages(\"%1$s\")`."
    )

    within <- if (is.null(type)) "this project" else paste(type, "files")
    warningf(fmt, package, within)

  }

  return(FALSE)

}

the$dependencies_state <- NULL

renv_dependencies_state <- function(key = NULL) {
  state <- the$dependencies_state
  if (is.null(key)) state else state[[key]]
}

renv_dependencies_scope <- function(root = NULL, scope = parent.frame()) {
  state <- env(root = root, scanned = env(), problems = stack())
  the$dependencies_state <- state
  defer(the$dependencies_state <- NULL, scope = scope)
}

renv_dependencies_error_push <- function(path = NULL, error = NULL) {

  state <- renv_dependencies_state()
  if (is.null(state))
    return()

  path <- path %||% state$path
  problem <- list(file = path, error = error)
  state$problems$push(problem)

}

renv_dependencies_error <- function(path, error = NULL, packages = NULL) {

  # if no error, return early
  if (is.null(error))
    return(renv_dependencies_list(path, packages))

  # push the error report
  renv_dependencies_error_push(path, error)

  # return dependency list
  renv_dependencies_list(path, packages)

}

renv_dependencies_report <- function(errors) {

  if (identical(errors, "ignored"))
    return(FALSE)

  state <- renv_dependencies_state()
  if (is.null(state))
    return(FALSE)

  problems <- state$problems$data()
  if (empty(problems))
    return(TRUE)

  # bind into list
  bound <- bapply(problems, function(problem) {
    fields <- c(renv_path_aliased(problem$file), problem$line, problem$column)
    header <- paste(fields, collapse = ":")
    message <- conditionMessage(problem$error)
    c(file = problem$file, header = header, message = message)
  })

  # split based on header (group errors from same file)
  splat <- split(bound, bound$file)

  # emit messages
  lines <- enumerate(splat, function(file, problem) {
    messages <- paste("Error", problem$message, sep = ": ", collapse = "\n\n")
    paste(c(header(file), messages, ""), collapse = "\n")
  })

  caution_bullets(
    "WARNING: One or more problems were discovered while enumerating dependencies.",
    c("", lines),
    "Please see `?renv::dependencies` for more information.",
    bullets = FALSE
  )

  if (identical(errors, "fatal")) {
    fmt <- "one or more problems were encountered while enumerating dependencies"
    stopf(fmt)
  }

  renv_condition_signal("renv.dependencies.problems", problems)
  TRUE

}

renv_dependencies_eval <- function(expr) {

  # create environment with small subset of "safe" symbols, that
  # are commonly used for chunk expressions
  syms <- c(
    "list", "c", "T", "F",
    "{", "(", "[", "[[",
    "::", ":::", "$", "@",
    ":",
    "+", "-", "*", "/",
    "<", ">", "<=", ">=", "==", "!=",
    "!",
    "&", "&&", "|", "||"
  )

  vals <- mget(syms, envir = baseenv())
  envir <- list2env(vals, parent = emptyenv())

  # evaluate in that environment
  eval(expr, envir = envir)

}


# description.R --------------------------------------------------------------


renv_description_read <- function(path = NULL,
                                  package = NULL,
                                  subdir = NULL,
                                  field = NULL,
                                  ...)
{
  # if given a package name, construct path to that package
  path <- path %||% find.package(package)

  # normalize non-absolute paths
  if (!renv_path_absolute(path))
    path <- renv_path_normalize(path)

  # if 'path' refers to a directory, try to resolve the DESCRIPTION file
  if (dir.exists(path)) {
    components <- c(path, if (nzchar(subdir %||% "")) subdir, "DESCRIPTION")
    path <- paste(components, collapse = "/")
  }

  # if the DESCRIPTION file doesn't exist, bail
  if (!file.exists(path))
    stopf("DESCRIPTION file %s does not exist", renv_path_pretty(path))

  # read value with filebacked cache
  description <- filebacked(
    context  = "renv_description_read",
    path     = path,
    callback = renv_description_read_impl,
    subdir   = subdir,
    ...
  )

  if (!is.null(field))
    return(description[[field]])

  description

}

renv_description_read_impl <- function(path = NULL, subdir = NULL, ...) {

  # if we have an archive, attempt to unpack the DESCRIPTION
  type <- renv_archive_type(path)
  if (type != "unknown") {

    # list files within the archive
    files <- renv_archive_list(path)

    # find the DESCRIPTION file. note that for some source tarballs (e.g.
    # 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$")
    pattern <- paste(parts, collapse = "/")

    descs <- grep(pattern, files, 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
    # unpack into tempdir location
    file <- descs[[1]]
    exdir <- renv_scope_tempfile("renv-description-")
    renv_archive_decompress(path, files = file, exdir = exdir)

    # update path to extracted DESCRIPTION
    path <- file.path(exdir, file)

  }

  # read DESCRIPTION as dcf
  dcf <- renv_dcf_read(path, ...)
  if (empty(dcf))
    stopf("DESCRIPTION file at '%s' is empty", path)

  dcf

}

renv_description_path <- function(path) {
  childpath <- file.path(path, "DESCRIPTION")
  indirect <- file.exists(childpath)
  path[indirect] <- childpath[indirect]
  path
}

# parse the dependency requirements normally presented in
# Depends, Imports, Suggests, and so on
renv_description_parse_field <- function(field) {

  # check for invalid / unexpected inputs
  if (is.null(field) || is.na(field) || !nzchar(field))
    return(NULL)

  pattern <- paste0(
    "([a-zA-Z0-9._]+)",                      # package name
    "(?:\\s*\\(([><=]+)\\s*([0-9.-]+)\\))?"  # optional version specification
  )

  # split on commas
  parts <- strsplit(field, "\\s*,\\s*")[[1]]

  # drop any empty fields
  x <- parts[nzchar(parts)]

  # match to split on package name, version
  m <- regexec(pattern, x)
  matches <- regmatches(x, m)
  if (empty(matches))
    return(NULL)

  data_frame(
    Package = extract_chr(matches, 2L),
    Require = extract_chr(matches, 3L),
    Version = extract_chr(matches, 4L)
  )

}

renv_description_resolve <- function(path) {

  case(
    is.list(path)      ~ path,
    is.character(path) ~ renv_description_read(path = path)
  )

}

renv_description_built_version <- function(desc = NULL) {

  desc <- renv_description_resolve(desc)

  built <- desc[["Built"]]
  if (is.null(built))
    return(NA)

  substring(built, 3L, regexpr(";", built, fixed = TRUE) - 1L)
}

renv_description_dependency_fields_expand <- function(fields) {

  expanded <- map(fields, function(field) {

    case(

      identical(field, FALSE)
      ~ NULL,

      identical(field, "strong") || is.na(field)
      ~ c("Depends", "Imports", "LinkingTo"),

      identical(field, "most") || identical(field, TRUE)
      ~ c("Depends", "Imports", "LinkingTo", "Suggests"),

      identical(field, "all") ~
        c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances"),

      field

    )

  })

  unique(unlist(expanded, recursive = FALSE, use.names = FALSE))

}

renv_description_dependency_fields <- function(fields, project) {
  fields <- fields %||% settings$package.dependency.fields(project = project)
  renv_description_dependency_fields_expand(fields)
}

renv_description_remotes <- function(path) {

  desc <- catch(renv_description_read(path))
  if (inherits(desc, "error"))
    return(list())

  profile <- renv_profile_get()
  field <- if (is.null(profile))
    "Remotes"
  else
    sprintf("Config/renv/profiles/%s/remotes", profile)

  remotes <- desc[[field]]
  if (is.null(remotes))
    return(list())

  splat <- strsplit(remotes, "[[:space:]]*,[[:space:]]*")[[1]]
  resolved <- lapply(splat, renv_remotes_resolve)
  names(resolved) <- extract_chr(resolved, "Package")
  resolved

}



# diagnostics.R --------------------------------------------------------------


#' Print a diagnostics report
#'
#' Print a diagnostics report, summarizing the state of a project using renv.
#' This report can occasionally be useful when diagnosing issues with renv.
#'
#' @inheritParams renv-params
#'
#' @return This function is normally called for its side effects.
#'
#' @export
diagnostics <- function(project = NULL) {

  renv_scope_error_handler()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  if (renv_file_type(project, symlinks = FALSE) != "directory") {
    fmt <- "project %s is not a directory"
    stopf(fmt, renv_path_pretty(project))
  }

  renv_scope_options(renv.verbose = TRUE)

  reporters <- list(
    renv_diagnostics_session,
    renv_diagnostics_project,
    renv_diagnostics_status,
    renv_diagnostics_packages,
    renv_diagnostics_abi,
    renv_diagnostics_profile,
    renv_diagnostics_settings,
    renv_diagnostics_options,
    renv_diagnostics_envvars,
    renv_diagnostics_path,
    renv_diagnostics_cache
  )

  fmt <- "Diagnostics Report [renv %s]"
  title <- sprintf(fmt, renv_metadata_version_friendly())
  lines <- paste(rep.int("=", nchar(title)), collapse = "")
  writef(c(title, lines, ""))

  for (reporter in reporters) {
    tryCatch(reporter(project), error = renv_error_handler)
    writef()
  }

}

renv_diagnostics_session <- function(project) {
  writef(header("Session Info"))
  renv_scope_options(width = 80)
  print(sessionInfo())
}

renv_diagnostics_project <- function(project) {
  writef(header("Project"))
  writef("Project path: %s", renv_path_pretty(project))
}

renv_diagnostics_status <- function(project) {
  writef(header("Status"))
  status(project = project)
}

renv_diagnostics_packages <- function(project) {

  writef(header("Packages"))

  # collect state of lockfile, library, dependencies
  lockfile <- renv_diagnostics_packages_lockfile(project)
  libstate <- renv_diagnostics_packages_library(project)
  used <- unique(renv_diagnostics_packages_dependencies(project)$Package)

  # collect recursive package dependencies
  recdeps <- renv_package_dependencies(
    packages = used,
    project  = project
  )

  # bundle together
  all <- c(
    names(lockfile$Packages),
    names(libstate$Packages),
    names(recdeps),
    used
  )

  # sort
  all <- csort(unique(all))

  # check which packages are direct, indirect requirements
  deps <- rep.int(NA_character_, length(all))
  names(deps) <- all
  deps[names(recdeps)] <- "indirect"
  deps[used] <- "direct"

  # build libpaths for installed packages
  libpaths <- dirname(map_chr(all, renv_package_find))

  # use short form
  flibpaths <- factor(libpaths, levels = .libPaths())

  # construct integer codes (to be reported in data output)
  libcodes <- as.integer(flibpaths)
  libcodes[!is.na(libcodes)] <- sprintf("[%i]", libcodes[!is.na(libcodes)])

  # add in packages in library
  data <- data_frame(
    Library    = renv_diagnostics_packages_version(libstate, all),
    Source     = renv_diagnostics_packages_sources(libstate, all),
    Lockfile   = renv_diagnostics_packages_version(lockfile, all),
    Source     = renv_diagnostics_packages_sources(lockfile, all),
    Path       = libcodes,
    Dependency = deps
  )

  # we explicitly want to use rownames here
  row.names(data) <- names(deps)

  # print it out
  renv_scope_options(width = 9000)
  print(data, max = 10000)

  # print library codes
  fmt <- "[%s]: %s"
  writef()
  writef(fmt, format(seq_along(levels(flibpaths))), format(levels(flibpaths)))

}

renv_diagnostics_packages_version <- function(lockfile, all) {

  data <- rep.int(NA_character_, length(all))
  names(data) <- all

  formatted <- map_chr(lockfile$Packages, `[[`, "Version")
  data[names(formatted)] <- formatted

  data

}

renv_diagnostics_packages_sources <- function(lockfile, all) {

  data <- rep.int(NA_character_, length(all))
  names(data) <- all

  sources <- map_chr(lockfile$Packages, function(record) {
    record$Repository %||% record$Source %||% "<unknown>"
  })

  data[names(sources)] <- sources
  data

}

renv_diagnostics_packages_lockfile <- function(project) {

  lockpath <- renv_lockfile_path(project = project)
  if (!file.exists(lockpath)) {
    writef("This project has not yet been snapshotted: 'renv.lock' does not exist.")
    return(list())
  }

  renv_lockfile_read(lockpath)

}

renv_diagnostics_packages_library <- function(project) {

  library <- renv_paths_library(project = project)
  if (!file.exists(library)) {
    fmt <- "The project library %s does not exist."
    writef(fmt, renv_path_pretty(library))
  }

  snapshot(project = project, lockfile = NULL, type = "all")

}

renv_diagnostics_packages_dependencies <- function(project) {

  renv_dependencies_impl(
    project,
    errors = "reported",
    dev = TRUE
  )

}

renv_diagnostics_abi <- function(project) {

  writef(header("ABI"))
  tryCatch(
    renv_abi_check(),
    error = function(e) {
      writef(conditionMessage(e))
    }
  )

}

renv_diagnostics_profile <- function(project) {

  writef(header("User Profile"))

  userprofile <- "~/.Rprofile"
  if (!file.exists(userprofile))
    return(writef("[no user profile detected]"))

  deps <- renv_dependencies_impl(
    userprofile,
    errors = "reported",
    dev = TRUE
  )

  if (empty(deps))
    return(writef("[no R packages referenced in user profile"))

  renv_scope_options(width = 200)
  print(deps)

}

renv_diagnostics_settings <- function(project) {
  writef(header("Settings"))
  str(renv_settings_get(project))
}

renv_diagnostics_options <- function(project) {

  writef(header("Options"))

  keys <- c(
    "defaultPackages",
    "download.file.method",
    "download.file.extra",
    "install.packages.compile.from.source",
    "pkgType",
    "repos",
    grep("^renv[.]", names(.Options), value = TRUE)
  )

  vals <- .Options[keys]
  names(vals) <- keys

  str(vals)

}

renv_diagnostics_envvars <- function(project) {

  writef(header("Environment Variables"))

  envvars <- convert(as.list(Sys.getenv()), "character")

  useful <- c(
    "R_LIBS_USER", "R_LIBS_SITE", "R_LIBS",
    "HOME", "LANG", "MAKE",
    grep("^RENV_", names(envvars), value = TRUE)
  )

  matches <- envvars[useful]
  if (empty(matches))
    return(writef("[no renv environment variables available]"))

  names(matches) <- useful
  matches[is.na(matches)] <- "<NA>"
  matches <- matches[order(names(matches))]

  keys <- names(matches)
  vals <- matches
  formatted <- paste(format(keys), vals, sep = " = ")
  writef(formatted)

}

renv_diagnostics_path <- function(project) {
  writef(header("PATH"))
  path <- strsplit(Sys.getenv("PATH"), .Platform$path.sep, fixed = TRUE)[[1]]
  writef(paste("-", path))
}

renv_diagnostics_cache <- function(project) {

  writef(header("Cache"))

  fmt <- "There are a total of %s installed in the renv cache."
  cachelist <- renv_cache_list()
  writef(fmt, nplural("package", length(cachelist)))
  writef("Cache path: %s", renv_path_pretty(renv_paths_cache()))

}


# difftime.R -----------------------------------------------------------------


renv_difftime_format <- function(time, digits = 2L) {

  if (testing())
    return("XXXX seconds")

  units <- attr(time, "units") %||% ""
  if (units == "secs" && time < 0.1) {
    time  <- time * 1000
    units <- "milliseconds"
  }

  units <- switch(
    units,
    secs  = "seconds",
    mins  = "minutes",
    hours = "hours",
    days  = "days",
    weeks = "weeks",
    units
  )

  elapsed <- format(unclass(signif(time, digits = digits)))
  if (elapsed %in% c("1", "1.0"))
    units <- substring(units, 1L, nchar(units) - 1L)

  paste(elapsed, units)

}

renv_difftime_format_short <- function(time, digits = 2L) {

  if (testing())
    return("XXs")

  units <- attr(time, "units") %||% ""
  if (units == "secs" && time < 0.1) {
    time  <- time * 1000
    units <- "ms"
  }

  elapsed <- signif(time, digits = digits)
  if (nchar(elapsed) == 1L)
    elapsed <- paste(elapsed, ".0", sep = "")

  units <- switch(
    attr(time, "units"),
    secs  = "s",
    mins  = "m",
    hours = "h",
    days  = "d",
    weeks = "w",
    units
  )

  paste(elapsed, units, sep = "")

}


# dots.R ---------------------------------------------------------------------


renv_dots_check <- function(...) {

  dots <- list(...)
  parent <- parent.frame()

  # accept 'bioc' as an alias for 'bioconductor'
  bioc <- dots[["bioc"]]
  if (!is.null(bioc) && exists("bioconductor", envir = parent)) {
    if (is.null(parent$bioconductor)) {
      assign("bioconductor", bioc, envir = parent)
      dots[["bioc"]] <- NULL
    }
  }

  # allow 'confirm' as an alias for 'prompt'
  confirm <- dots[["confirm"]]
  if (!is.null(confirm) && exists("prompt", envir = parent)) {
    assign("prompt", confirm, envir = parent)
    dots[["confirm"]] <- NULL
  }

  # check for empty dots
  if (length(dots) == 0)
    return(TRUE)

  call <- sys.call(sys.parent())
  func <- sys.function(sys.parent())
  matched <- match.call(func, call, expand.dots = FALSE)

  dotcall <- format(matched["..."])
  start <- regexpr("(", dotcall, fixed = TRUE)
  end <- nchar(dotcall) - 2L
  args <- substring(dotcall, start, end)
  n <- length(matched[["..."]])

  message <- paste("unused", plural("argument", n), args)
  stop(simpleError(message = message, call = call))

}


# download.R -----------------------------------------------------------------


# download a file from 'url' to file 'destfile'. the 'type'
# argument tells us the remote type, which is used to motivate
# what form of authentication is appropriate; the 'quiet'
# argument is used to display / suppress output. use 'headers'
# (as a named character vector) to supply additional headers
download <- function(url,
                     destfile,
                     preamble = NULL,
                     type = NULL,
                     quiet = FALSE,
                     headers = NULL)
{
  # allow for user-defined overrides
  override <- getOption("renv.download.override")
  if (is.function(override)) {

    result <- catch(
      override(
        url      = url,
        destfile = destfile,
        quiet    = quiet,
        mode     = "wb",
        headers  = headers
      )
    )

    if (inherits(result, "error"))
      renv_download_error(result, "%s", conditionMessage(result))

    if (!file.exists(destfile))
      renv_download_error(url, "%s does not exist", renv_path_pretty(destfile))

    return(destfile)

  }

  if (quiet)
    renv_scope_options(renv.verbose = FALSE)

  # normalize separators (file URIs should normally use forward
  # slashes, even on Windows where the native separator is backslash)
  url      <- chartr("\\", "/", url)
  destfile <- chartr("\\", "/", destfile)

  # notify user we're about to try downloading
  preamble <- preamble %||% sprintf("- Downloading '%s' ... ", url)
  printf(preamble)

  # add custom headers as appropriate for the URL
  custom <- renv_download_custom_headers(url)
  headers[names(custom)] <- custom

  # handle local files by just copying the file
  if (renv_download_local(url, destfile, headers))
    return(destfile)

  # on Windows, try using our local curl binary if available
  renv_scope_downloader()

  # if the file already exists, compare its size with
  # the server's reported size for that file
  info <- renv_file_info(destfile)
  if (identical(info$isdir, FALSE)) {
    size <- renv_download_size(url, type, headers)
    if (info$size == size) {
      writef("OK [file is up to date]")
      return(destfile)
    }
  }

  # back up a pre-existing file if necessary
  callback <- renv_file_backup(destfile)
  defer(callback())

  # form path to temporary file
  tempfile <- renv_scope_tempfile(tmpdir = dirname(destfile))

  # request the download
  before <- Sys.time()

  status <- renv_download_impl(
    url      = url,
    destfile = tempfile,
    type     = type,
    request  = "GET",
    headers  = headers
  )

  after <- Sys.time()

  # check for failure
  if (inherits(status, "condition"))
    renv_download_error(url, "%s", conditionMessage(status))

  if (status != 0L)
    renv_download_error(url, "error code %i", status)

  if (!file.exists(tempfile))
    renv_download_error(url, "%s", "unknown reason")

  # double-check archives are readable
  status <- renv_download_check_archive(tempfile)
  if (inherits(status, "error"))
    renv_download_error(url, "%s", "archive cannot be read")

  # everything looks ok: report success
  elapsed <- difftime(after, before, units = "auto")
  renv_download_report(elapsed, tempfile)

  # move the file to the requested location
  renv_file_move(tempfile, destfile)

  # one final sanity check
  if (!file.exists(destfile)) {
    fmt <- "could not move %s to %s"
    msg <- sprintf(fmt, renv_path_pretty(tempfile), renv_path_pretty(destfile))
    renv_download_error(url, msg)
  }

  # and return path to successfully retrieved file
  destfile
}

# NOTE: only 'GET' and 'HEAD' are supported
#
# each downloader should return 0 on success
renv_download_impl <- function(url, destfile, type = NULL, request = "GET", headers = NULL) {

  # normalize separators (file URIs should normally use forward
  # slashes, even on Windows where the native separator is backslash)
  url      <- chartr("\\", "/", url)
  destfile <- chartr("\\", "/", destfile)

  # check that the destination file is writable
  if (!renv_file_writable(destfile)) {
    fmt <- "destination path '%s' is not writable; cannot proceed"
    stopf(fmt, renv_path_pretty(destfile))
  }

  # select the appropriate downloader
  downloader <- switch(
    renv_download_method(),
    curl = renv_download_curl,
    wget = renv_download_wget,
    renv_download_default
  )

  # run downloader, catching errors and warnings
  catchall(downloader(url, destfile, type, request, headers))

}

renv_download_default_mode <- function(url, method) {

  mode <- "wb"

  fixup <-
    renv_platform_windows() &&
    identical(method, "wininet") &&
    substring(url, 1L, 5L) == "file:"

  if (fixup)
    mode <- "w+b"

  mode

}

renv_download_default <- function(url, destfile, type, request, headers) {

  # custom request types are not supported with the default downloader
  if (request != "GET")
    stopf("the default downloader does not support %s requests", request)

  # try and ensure headers are set for older versions of R
  auth <- renv_download_auth(url, type)
  headers[names(auth)] <- auth
  renv_download_default_agent_scope(headers)

  # on Windows, prefer 'wininet' as most users will have already configured
  # authentication etc. to work with this protocol
  methods <- c(
    Sys.getenv("RENV_DOWNLOAD_METHOD", unset = NA),
    Sys.getenv("RENV_DOWNLOAD_FILE_METHOD", unset = NA),
    if (renv_platform_windows()) "wininet" else "auto"
  )

  method <- Find(Negate(is.na), methods)

  # headers _must_ be NULL rather than zero-length character
  if (length(headers) == 0)
    headers <- NULL

  mode <- renv_download_default_mode(url, method)

  # handle absence of 'headers' argument in older versions of R
  args <- list(url      = url,
               destfile = destfile,
               method   = method,
               headers  = headers,
               mode     = mode,
               quiet    = TRUE)

  fmls <- formals(download.file)
  args <- keep(args, names(fmls))

  renv_download_trace_begin(url, method)
  if (renv_download_trace())
    str(args)

  do.call(download.file, args)

}

renv_download_default_agent_scope <- function(headers, scope = parent.frame()) {

  if (empty(headers))
    return(FALSE)

  if (getRversion() >= "3.6.0")
    return(FALSE)

  renv_download_default_agent_scope_impl(headers, scope)
}

renv_download_default_agent_scope_impl <- function(headers, scope = parent.frame()) {

  utils <- asNamespace("utils")
  makeUserAgent <- utils$makeUserAgent
  ok <-
    is.function(makeUserAgent) &&
    identical(formals(makeUserAgent), pairlist(format = TRUE))

  if (!ok)
    return(FALSE)

  agent <- makeUserAgent(FALSE)
  all <- c("User-Agent" = agent, headers)
  headertext <- paste0(names(all), ": ", all, "\r\n", collapse = "")

  renv_scope_binding(utils, "makeUserAgent", function(format = TRUE) {
    if (format) headertext else agent
  }, scope = scope)

  return(TRUE)

}

renv_download_curl <- function(url, destfile, type, request, headers) {

  renv_download_trace_begin(url, "curl")

  configfile <- renv_scope_tempfile("renv-download-config-")

  fields <- c(
    "user-agent" = renv_http_useragent(),
    "url"        = url,
    "output"     = destfile
  )

  # set connect timeout
  timeout <- config$connect.timeout()
  if (is.numeric(timeout))
    fields[["connect-timeout"]] <- timeout

  # set number of retries
  retries <- config$connect.retry()
  if (is.numeric(retries))
    fields[["retry"]] <- retries

  # set up authentication headers
  auth <- renv_download_auth(url, type)
  if (length(auth)) {
    authtext <- paste(names(auth), auth, sep = ": ")
    names(authtext) <- "header"
    fields <- c(fields, authtext)
  }

  # add other custom headers
  if (length(headers)) {
    lines <- paste(names(headers), headers, sep = ": ")
    names(lines) <- "header"
    fields <- c(fields, lines)
  }

  # join together
  keys <- names(fields)
  vals <- renv_json_quote(fields)
  text <- paste(keys, vals, sep = " = ")

  # add in stand-along flags
  flags <- c("location", "fail", "silent", "show-error")
  if (request == "HEAD")
    flags <- c(flags, "head", "include")

  # put it all together
  text <- c(flags, text)

  writeLines(text, con = configfile)
  renv_download_trace_request(text)

  # generate the arguments to be passed to 'curl'
  args <- stack()

  # include anything provided explicitly in 'download.file.extra' here
  if (identical(getOption("download.file.method"), "curl")) {
    extra <- getOption("download.file.extra")
    if (length(extra))
      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")

  # add in any user configuration files
  userconfig <- getOption(
    "renv.curl.config",
    renv_download_curl_config()
  )

  for (entry in userconfig)
    if (file.exists(entry))
      args$push("--config", renv_shell_path(entry))

  # add in our own config file (the actual request)
  args$push("--config", renv_shell_path(configfile))

  # perform the download
  curl <- renv_curl_exe()
  output <- suppressWarnings(
    system2(curl, args$data(), stdout = TRUE, stderr = TRUE)
  )

  renv_download_trace_result(output)

  # report non-zero status as warning
  status <- attr(output, "status", exact = TRUE) %||% 0L
  if (status != 0L)
    warning(output, call. = FALSE)

  status

}

renv_download_curl_config <- function() {

  rc <- if (renv_platform_windows()) "_curlrc" else ".curlrc"

  homes <- c(
    Sys.getenv("CURL_HOME"),
    Sys.getenv("HOME"),
    Sys.getenv("R_USER"),
    path.expand("~/")
  )

  # nocov start
  if (renv_platform_windows()) {
    extra <- c(
      Sys.getenv("APPDATA"),
      file.path(Sys.getenv("USERPROFILE"), "Application Data"),
      dirname(Sys.which("curl"))
    )
    homes <- c(homes, extra)
  }
  # nocov end

  homes <- Filter(nzchar, homes)

  for (home in homes) {
    path <- file.path(home, rc)
    if (file.exists(path))
      return(path)
  }

  NULL

}

# nocov start

renv_download_wget <- function(url, destfile, type, request, headers) {

  renv_download_trace_begin(url, "wget")

  configfile <- renv_scope_tempfile("renv-download-config-")

  fields <- c(
    "user-agent" = renv_http_useragent(),
    "quiet"      = "on"
  )

  auth <- renv_download_auth(url, type)
  if (length(auth)) {
    authtext <- paste(names(auth), auth, sep = ": ")
    names(authtext) <- "header"
    fields <- c(fields, authtext)
  }

  if (length(headers)) {
    lines <- paste(names(headers), headers, sep = ": ")
    names(lines) <- "header"
    fields <- c(fields, lines)
  }

  keys <- names(fields)
  vals <- unlist(fields)
  text <- paste(keys, vals, sep = " = ")

  writeLines(text, con = configfile)
  renv_download_trace_request(text)

  args <- stack()

  if (identical(getOption("download.file.method"), "wget")) {
    extra <- getOption("download.file.extra")
    if (length(extra))
      args$push(extra)
  }

  args$push("--config", renv_shell_path(configfile))

  # NOTE: '-O' does not write headers to file; we need to manually redirect
  # in that case
  status <- if (request == "HEAD") {
    args$push("--server-response", "--spider")
    args$push(">", renv_shell_path(destfile), "2>&1")
    cmdline <- paste("wget", paste(args$data(), collapse = " "))
    return(suppressWarnings(system(cmdline)))
  }

  args$push("-O", renv_shell_path(destfile))
  args$push(renv_shell_quote(url))

  output <- suppressWarnings(
    system2("wget", args$data(), stdout = TRUE, stderr = TRUE)
  )

  renv_download_trace_result(output)

  status <- attr(output, "status", exact = TRUE) %||% 0L
  if (status != 0L)
    warning(output, call. = FALSE)

  status

}

# nocov end

renv_download_auth_type <- function(url) {

  github_hosts <- c(
    "https://api.github.com/",
    "https://raw.githubusercontent.com/"
  )

  for (host in github_hosts)
    if (startswith(url, host))
      return("github")

  gitlab_hosts <- c(
    "https://gitlab.com/"
  )

  for (host in gitlab_hosts)
    if (startswith(url, host))
      return("gitlab")

  bitbucket_hosts <- c(
    "https://api.bitbucket.org/",
    "https://bitbucket.org/"
  )

  for (host in bitbucket_hosts)
    if (startswith(url, host))
      return("bitbucket")

  "unknown"

}

renv_download_auth <- function(url, type) {

  type <- tolower(type %||% renv_download_auth_type(url))
  switch(
    type,
    bitbucket = renv_download_auth_bitbucket(),
    github = renv_download_auth_github(),
    gitlab = renv_download_auth_gitlab(),
    character()
  )

}

renv_download_auth_bitbucket <- function() {

  user <-
    Sys.getenv("BITBUCKET_USER", unset = NA) %NA%
    Sys.getenv("BITBUCKET_USERNAME", unset = NA)

  pass <-
    Sys.getenv("BITBUCKET_PASS", unset = NA) %NA%
    Sys.getenv("BITBUCKET_PASSWORD", unset = NA)

  if (is.na(user) || is.na(pass))
    return(character())

  userpass <- paste(user, pass, sep = ":")
  c("Authorization" = paste("Basic", renv_base64_encode(userpass)))

}

renv_download_auth_github <- function() {

  pat <- renv_download_auth_github_pat()
  if (is.null(pat))
    return(character())

  c("Authorization" = paste("token", pat))

}

renv_download_auth_github_pat <- function() {

  pat <- Sys.getenv("GITHUB_PAT", unset = NA)
  if (!is.na(pat))
    return(pat)

  token <- tryCatch(gitcreds::gitcreds_get(), error = function(e) NULL)
  if (!is.null(token))
    return(token$password)

}

renv_download_auth_gitlab <- function() {

  pat <- Sys.getenv("GITLAB_PAT", unset = NA)
  if (is.na(pat))
    return(character())

  c("Private-Token" = pat)

}

renv_download_headers <- function(url, type, headers) {

  # check for compatible download method
  method <- renv_download_method()
  if (!method %in% c("libcurl", "curl", "wget"))
    return(list())

  # perform the download
  file <- renv_scope_tempfile("renv-headers-")

  status <- renv_download_impl(
    url      = url,
    destfile = file,
    type     = type,
    request  = "HEAD",
    headers  = headers
  )

  # check for failure
  failed <-
    inherits(status, "error") ||
    !identical(status, 0L) ||
    !file.exists(file)

  if (failed) {
    unlink(file)
    return(list())
  }

  # read the downloaded headers
  contents <- read(file)

  # if redirects were required, each set of headers will
  # be reported separately, so just report the final set
  # of headers (ie: ignore redirects)
  splat <- strsplit(contents, "\n\n", fixed = TRUE)[[1]]
  text <- strsplit(splat[[length(splat)]], "\n", fixed = TRUE)[[1]]

  # keep only header lines
  lines <- grep(":", text, fixed = TRUE, value = TRUE)
  headers <- catch(renv_properties_read(text = lines))
  names(headers) <- tolower(names(headers))
  if (inherits(headers, "error"))
    return(list())

  headers

}

renv_download_size <- function(url, type = NULL, headers = NULL) {

  memoize(
    key   = url,
    value = renv_download_size_impl(url, type, headers)
  )

}

renv_download_size_impl <- function(url, type = NULL, headers = NULL) {

  headers <- catch(renv_download_headers(url, type, headers))
  if (inherits(headers, "error"))
    return(-1L)

  size <- headers[["x-gitlab-size"]]
  if (!is.null(size))
    return(as.numeric(size))

  size <- headers[["content-length"]]
  if (!is.null(size))
    return(as.numeric(size))

  return(-1L)

}

# select an appropriate download file method. we prefer curl
# when available as it's the most user-customizable of all the
# download methods; when not available, we fall back to libcurl
# and wget (in that order). note that we don't want to use the
# internal or wininet downloaders as we cannot set custom headers
# with those methods. users can force a method with the
# RENV_DOWNLOAD_FILE_METHOD environment variable but we generally
# want to override a user-specified 'download.file.method'
renv_download_method <- function() {

  method <- Sys.getenv("RENV_DOWNLOAD_METHOD", unset = NA)
  if (!is.na(method))
    return(method)

  method <- Sys.getenv("RENV_DOWNLOAD_FILE_METHOD", unset = NA)
  if (!is.na(method))
    return(method)

  # prefer curl if available
  if (nzchar(Sys.which("curl")))
    return("curl")

  # if curl is not available, use libcurl if available
  libcurl <- capabilities("libcurl")
  if (length(libcurl) && libcurl)
    return("libcurl")

  # on windows, just use wininet here
  if (renv_platform_windows())
    return("wininet")

  # if neither curl nor libcurl is available, prefer wget
  if (nzchar(Sys.which("wget")))
    return("wget")

  # all else fails, use the internal downloader
  "internal"

}

renv_download_report <- function(elapsed, file) {

  if (!renv_verbose())
    return()

  info <- renv_file_info(file)
  size <- if (testing())
    "XXXX bytes"
  else
    structure(info$size, class = "object_size")

  renv_report_ok(
    message = format(size, units = "auto"),
    elapsed = elapsed
  )

}

renv_download_check_archive <- function(destfile) {

  # validate the file exists
  if (!file.exists(destfile))
    return(FALSE)

  # validate archive type
  type <- renv_archive_type(destfile)
  if (type == "unknown")
    return(FALSE)

  # try listing files in the archive
  tryCatch({renv_archive_list(destfile); TRUE}, error = identity)

}

renv_download_local <- function(url, destfile, headers) {

  # only ever used for downloads from file URIs and server URIs
  ok <-
    grepl("^file:", url) ||
    !grepl("^[a-zA-Z]+://", url)

  if (!ok)
    return(FALSE)

  methods <- list(
    renv_download_local_copy,
    renv_download_local_default
  )

  for (method in methods) {

    # perform the copy
    before <- Sys.time()
    status <- catch(method(url, destfile, headers))
    after  <- Sys.time()

    # check for success
    if (!identical(status, TRUE))
      next

    # report download summary
    elapsed <- difftime(after, before, units = "auto")
    renv_download_report(elapsed, destfile)

    return(TRUE)

  }

  FALSE

}

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),
    TRUE                        ~ url
  )

  # fix up file URIs to local paths on Windows
  if (renv_platform_windows()) {
    badpath <- grepl("^/[a-zA-Z]:", url)
    if (badpath)
      url <- substring(url, 2L)
  }

  # attempt to copy
  ensure_parent_directory(destfile)
  status <- catchall(renv_file_copy(url, destfile, overwrite = TRUE))
  if (!identical(status, TRUE))
    return(FALSE)

  TRUE

}

renv_download_local_default <- function(url, destfile, headers) {

  status <- renv_download_impl(
    url      = url,
    destfile = destfile,
    headers  = headers
  )

  identical(status, 0L)

}

renv_download_custom_headers <- function(url) {
  renv_bootstrap_download_custom_headers(url)
}

renv_download_available <- function(url) {

  # normalize separators (file URIs should normally use forward
  # slashes, even on Windows where the native separator is backslash)
  url <- chartr("\\", "/", url)

  # on Windows, try using our local curl binary if available
  renv_scope_downloader()

  # if we're not using curl, then use fallback method
  method <- renv_download_method()
  if (!identical(method, "curl"))
    return(renv_download_available_fallback(url))

  # otherwise, try a couple candidate methods
  methods <- list(
    renv_download_available_headers,
    renv_download_available_range
  )

  for (method in methods) {
    result <- catch(method(url))
    if (identical(result, TRUE))
      return(TRUE)
  }

  FALSE

}

renv_download_available_headers <- function(url) {

  status <- catchall(
    renv_download_headers(
      url     = url,
      type    = NULL,
      headers = renv_download_custom_headers(url)
    )
  )

  if (inherits(status, "condition"))
    return(FALSE)

  is.list(status) && length(status)

}

renv_download_available_range <- function(url) {

  destfile <- renv_scope_tempfile("renv-download-")

  # instruct curl to request only first byte
  extra <- c(
    if (identical(getOption("download.file.method"), "curl"))
      getOption("download.file.extra"),
    "-r 0-0"
  )

  renv_scope_options(download.file.extra = paste(extra, collapse = " "))

  # perform the download
  status <- catchall(
    renv_download_curl(
      url      = url,
      destfile = destfile,
      type     = NULL,
      request  = "GET",
      headers  = renv_download_custom_headers(url)
    )
  )

  if (inherits(status, "condition"))
    return(FALSE)

  # check for success
  identical(status, 0L)

}

renv_download_available_fallback <- function(url) {

  destfile <- renv_scope_tempfile("renv-download-")

  # just try downloading the requested URL
  status <- catchall(
    renv_download_impl(
      url      = url,
      destfile = destfile,
      type     = NULL,
      request  = "GET",
      headers  = renv_download_custom_headers(url)
    )
  )

  if (inherits(status, "condition"))
    return(FALSE)

  identical(status, 0L)

}

renv_download_error <- function(url, fmt, ...) {
  msg <- sprintf(fmt, ...)
  writef("\tERROR [%s]", msg)
  stopf("error downloading '%s' [%s]", url, msg, call. = FALSE)
}

renv_download_trace <- function() {
  getOption("renv.download.trace", default = FALSE)
}

renv_download_trace_begin <- function(url, type) {

  if (!renv_download_trace())
    return()

  fmt <- "Downloading '%s' [%s]"
  msg <- sprintf(fmt, url, type)

  title <- header(msg, n = 78L)
  writef(c("", title, ""))

}

renv_download_trace_request <- function(text) {

  if (!renv_download_trace())
    return()

  title <- header("Request", n = 78L, prefix = "##")
  writef(c(title, text, ""))

}

renv_download_trace_result <- function(output) {

  if (!renv_download_trace())
    return()

  title <- header("Output", prefix = "##", n = 78L)
  text <- if (empty(output)) "[no output generated]" else output
  all <- c(title, text, "")
  writef(all)

  status <- attr(output, "status", exact = TRUE) %||% 0L
  title <- header("Status", prefix = "##", n = 78L)
  all <- c(title, status, "")
  writef(all)

}


# dynamic.R ------------------------------------------------------------------


#
# Tools for so-called 'dynamic' values. These are values which are computed
# once, and then memoized for the rest of the currently-executing call.
#
# An exit handler placed in the top-most (renv) environment is then responsible
# for cleaning up any objects cached for the duration of that frame.
#
# This is a useful way to cache results for repeatedly-computed values
# that one can reasonably expect not to change in the duration of a
# particular call.
#

the$dynamic_envir <- NULL
the$dynamic_objects <- new.env(parent = emptyenv())

dynamic <- function(key, value, envir = NULL) {

  # allow opt-out just in case
  enabled <- getOption("renv.dynamic.enabled", default = TRUE)
  if (!enabled)
    return(value)

  # get a unique id for the scope where this function was invoked
  caller <- sys.call(sys.parent())[[1L]]
  if (renv_call_matches(caller, name = ":::"))
    caller <- caller[[3L]]

  # handle cases like FUN
  if (is.null(the$envir_self[[as.character(caller)]])) {
    if (!renv_tests_running()) {
      fmt <- "internal error: dynamic() received unexpected call '%s'"
      stopf(fmt, stringify(sys.call(sys.parent())))
    }
  }

  # just return value if this isn't a valid dynamic scope
  if (!is.symbol(caller)) {
    dlog("dynamic", "invalid dynamic scope '%s'", stringify(sys.call(sys.parent())))
    return(value)
  }

  # make sure we have a dynamic scope active
  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 = ", "
  )

  # put it together
  id <- sprintf("%s(%s)", as.character(caller), key)

  # memoize the result of the expression
  the$dynamic_objects[[id]] <- the$dynamic_objects[[id]] %||% {
    dlog("dynamic", "memoizing dynamic value for '%s'", id)
    value
  }

}

renv_dynamic_envir <- function(envir = NULL) {

  envir <- envir %||% renv_dynamic_envir_impl()
  defer(renv_dynamic_reset(), scope = envir)

  dlog("dynamic", "using dynamic environment '%s'", format(envir))
  envir
}

renv_dynamic_envir_impl <- function() {

  frames <- sys.frames()
  for (i in seq_along(frames)) {
    envir <- frames[[i]]
    if (identical(parent.env(envir), the$envir_self))
      return(envir)
  }

  stop("internal error: no renv frame available for dynamic call")

}

renv_dynamic_reset <- function() {
  dlog("dynamic", "resetting dynamic objects")
  the$dynamic_envir <- NULL
  renv_envir_clear(the$dynamic_objects)
}


# embed.R --------------------------------------------------------------------

#' Capture and re-use dependencies within a `.R` or `.Rmd`
#'
#' @description
#' Together, `embed()` and `use()` provide a lightweight way to specify and
#' restore package versions within a file. `use()` is a lightweight lockfile
#' specification that `embed()` can automatically generate and insert into a
#' script or document.
#'
#' Calling `embed()` inspects the dependencies of the specified document then
#' generates and inserts a call to `use()` that looks something like this:
#'
#' ```R
#' renv::use(
#'   "digest@0.6.30",
#'   "rlang@0.3.4"
#' )
#' ```
#'
#' Then, when you next run your R script or render your `.Rmd`, `use()` will:
#'
#' 1. Create a temporary library path.
#'
#' 1. Install the requested packages and their recursive dependencies into that
#'    library.
#'
#' 1. Activate the library, so it's used for the rest of the script.
#'
#' ## Manual usage
#'
#' You can also create calls to `use()` yourself, either specifying the
#' packages needed by hand, or by supplying the path to a lockfile,
#' `renv::use(lockfile = "/path/to/renv.lock")`.
#'
#' This can be useful in projects where you'd like to associate different
#' lockfiles with different documents, as in a blog where you want each
#' post to capture the dependencies at the time of writing. Once you've
#' finished writing each, the post, you can use
#' `renv::snapshot(lockfile = "/path/to/renv.lock")`
#' to "save" the state that was active while authoring that bost, and then use
#' `renv::use(lockfile = "/path/to/renv.lock")` in that document to ensure the
#' blog post always uses those dependencies onfuture renders.
#'
#' `renv::use()` is inspired in part by the [groundhog](https://groundhogr.com/)
#' package, which also allows one to specify a script's \R package requirements
#' within that same \R script.
#'
#' @inherit renv-params
#'
#' @param path
#'   The path to an \R or R Markdown script. The default will use the current
#'   document, if running within RStudio.
#'
#' @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.
#'
#' @export
embed <- function(path = NULL,
                  ...,
                  lockfile = NULL,
                  project = NULL)
{
  path <- path %||% renv_embed_path()

  ext <- tolower(fileext(path))
  method <- case(
    ext == ".r"   ~ renv_embed_r,
    ext == ".rmd" ~ renv_embed_rmd
  )

  if (is.null(method)) {
    fmt <- "don't know how to embed lockfile into file %s"
    stopf(fmt, renv_path_pretty(path))
  }

  method(
    path     = path,
    lockfile = lockfile,
    project  = project,
    ...
  )

}

renv_embed_path <- function() {

  tryCatch(
    renv_embed_path_impl(),
    error = function(e) NULL
  )

}

renv_embed_path_impl <- function() {
  rstudio <- as.environment("tools:rstudio")
  rstudio$.rs.api.documentPath()
}

renv_embed_create <- 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))
  all <- renv_package_dependencies(packages)

  # keep only matched records
  lockfile$Packages <- keep(lockfile$Packages, c("renv", names(all)))

  # write compact use statement
  renv_lockfile_compact(lockfile)
}

renv_embed_r <- function(path, ..., lockfile = NULL, project = NULL) {

  # resolve project
  project <- renv_project_resolve(project)

  # read file contents
  contents <- readLines(path, warn = FALSE, encoding = "UTF-8")

  # generate embed
  embed <- renv_embed_create(
    path     = path,
    lockfile = lockfile,
    project  = project
  )

  # check for existing 'renv::use' statement
  pattern <- "^\\s*(?:renv:{2,3})?use\\(\\s*$"
  index <- grep(pattern, contents, perl = TRUE)

  # if we don't have an index, just insert at start
  if (empty(index)) {
    contents <- c(embed, "", contents)
    writeLines(contents, con = path)
    return(TRUE)
  }

  # otherwise, try to replace an existing embedded lockfile
  start <- index

  # find the end of the block
  n <- length(contents)
  lines <- grep("^\\s*\\)\\s*$", contents, perl = TRUE)
  end <- min(lines[lines > start], n + 1L)

  # inject new lockfile
  contents <- c(
    head(contents, n = start - 1L),
    embed,
    tail(contents, n = n - end)
  )

  writeLines(contents, con = path)
  return(TRUE)

}

renv_embed_create_rmd <- function(path = NULL,
                                  lockfile = NULL,
                                  project = NULL)
{
  # create lockfile
  project  <- renv_project_resolve(project)
  lockfile <- renv_embed_lockfile_resolve(lockfile, project)

  # create embed
  embed <- renv_embed_create(
    path     = path,
    lockfile = lockfile,
    project  = project
  )

  # return embed
  c("```{r lockfile, include=FALSE}", embed, "```")

}


renv_embed_rmd <- function(path,
                           ...,
                           lockfile = NULL,
                           project = NULL)
{
  # resolve project
  project <- renv_project_resolve(project)

  # read file contents
  contents <- readLines(path, warn = FALSE, encoding = "UTF-8")

  # generate embed
  embed <- renv_embed_create_rmd(
    path     = path,
    lockfile = lockfile,
    project  = project
  )

  # check for existing renv.lock in file
  # if it exists, we'll want to replace at this location;
  # otherwise, insert at end of document
  header <- "^\\s*```{r lockfile"
  footer <- "```"
  start <- grep(header, contents, perl = TRUE)

  # if we don't have an index, insert after YAML header (if any)
  if (empty(start)) {
    bounds <- which(trimws(contents) == "---")

    all <- if (length(bounds) >= 2) {
      index <- bounds[[2L]]
      c(
        head(contents, n = index),
        "",
        embed,
        "",
        tail(contents, n = length(contents) - index)
      )
    } else {
      c(embed, "", contents)
    }

    writeLines(all, con = path)
    return(TRUE)
  }

  # otherwise, try to replace an existing embedded lockfile
  ends <- which(contents == footer)
  end <- min(ends[ends > start])

  # inject new lockfile
  contents <- c(
    head(contents, n = start - 1L),
    embed,
    tail(contents, n = length(contents) - end)
  )

  writeLines(contents, con = path)
  return(TRUE)

}

renv_embed_lockfile_resolve <- function(lockfile, project) {

  # if lockfile is character, assume it's the path to a lockfile
  if (is.character(lockfile))
    return(renv_lockfile_read(lockfile))

  # if lockfile is not NULL, assume lockfile object
  if (!is.null(lockfile))
    return(lockfile)

  # check for lockfile in project
  path <- renv_lockfile_path(project)
  if (file.exists(path))
    return(renv_lockfile_read(path))

  # no lockfile available; just snapshot
  snapshot(project = project, lockfile = NULL)

}


# encoding.R -----------------------------------------------------------------


renv_encoding_mark <- function(x, encoding = "UTF-8") {
  Encoding(x) <- "UTF-8"
  x
}


# ensure.R -------------------------------------------------------------------


ensure_existing_path <- function(path) {
  if (!file.exists(path))
    stopf("no file at path '%s'", path)
  invisible(path)
}

ensure_existing_file <- function(path) {
  info <- renv_file_info(path)
  if (is.na(info$isdir))
    stopf("no file at path '%s'", path)
  else if (identical(info$isdir, TRUE))
    stopf("file '%s' exists but is a directory")
  invisible(path)
}

ensure_directory <- function(paths, umask = NULL) {

  # handle zero-path case
  if (empty(paths))
    return(invisible(paths))

  # set umask if necessary
  if (!is.null(umask))
    renv_scope_umask("0")

  # for each path, try to either create the directory, or assert that
  # the directory already exists. this should also help handle cases
  # where 'dir.create()' fails because another process created the
  # directory at the same time we attempted to do so
  for (path in paths) {

    ok <-
      dir.create(path, recursive = TRUE, showWarnings = FALSE) ||
      dir.exists(path)

    if (!ok)
      stopf("failed to create directory at path '%s'", path)

  }

  # return the paths
  invisible(paths)

}

ensure_parent_directory <- function(path) {
  ensure_directory(unique(dirname(path)))
}



# envir.R --------------------------------------------------------------------


renv_envir_self <- function() {
  parent.env(environment())
}

renv_envir_clear <- function(envir) {
  vars <- ls(envir = envir, all.names = TRUE)
  rm(list = vars, envir = envir, inherits = FALSE)
}

renv_envir_unwrap <- function(envir) {
  eapply(envir, function(node) {
    if (is.environment(node))
      renv_envir_unwrap(node)
    else
      node
  })
}


# envvar.R -------------------------------------------------------------------


renv_envvar_path_add <- function(envvar, value, prepend = TRUE) {

  old <- Sys.getenv(envvar, unset = "")
  old <- strsplit(old, .Platform$path.sep)[[1]]

  parts <- if (prepend) union(value, old) else union(old, value)
  new <- paste(parts, collapse = .Platform$path.sep)

  names(new) <- envvar
  do.call(Sys.setenv, as.list(new))

  new

}

renv_envvar_exists <- function(key) {
  !is.na(Sys.getenv(key, unset = NA))
}


# envvars.R ------------------------------------------------------------------


renv_envvars_list <- function() {
  c(
    "R_PROFILE", "R_PROFILE_USER",
    "R_ENVIRON", "R_ENVIRON_USER",
    "R_LIBS_USER", "R_LIBS_SITE", "R_LIBS"
  )
}

renv_envvars_save <- function() {

  # save the common set of environment variables
  keys <- renv_envvars_list()
  vals <- Sys.getenv(keys, unset = "<NA>")

  # check for defaults that have already been set
  defkeys <- paste("RENV_DEFAULT", keys, sep = "_")
  defvals <- Sys.getenv(defkeys, unset = NA)
  if (any(!is.na(defvals)))
    return(FALSE)

  # prepare defaults
  env <- vals
  names(env) <- defkeys
  do.call(Sys.setenv, as.list(env))

  TRUE

}

renv_envvars_restore <- function() {

  # read defaults
  keys <- renv_envvars_list()
  defkeys <- paste("RENV_DEFAULT", renv_envvars_list(), sep = "_")
  defvals <- Sys.getenv(defkeys, unset = "<NA>")

  # remove previously-unset environment variables
  missing <- defvals == "<NA>"
  Sys.unsetenv(keys[missing])

  # restore old values for envvars
  existing <- as.list(defvals[!missing])
  if (length(existing)) {
    names(existing) <- sub("^RENV_DEFAULT_", "", names(existing))
    do.call(Sys.setenv, existing)
  }

  # remove saved RENV_DEFAULT values
  Sys.unsetenv(defkeys)
  TRUE

}

renv_envvars_init <- function() {
  renv_envvars_normalize()
}

renv_envvars_normalize <- function() {

  Sys.setenv(R_LIBS_SITE = .expand_R_libs_env_var(Sys.getenv("R_LIBS_SITE")))
  Sys.setenv(R_LIBS_USER = .expand_R_libs_env_var(Sys.getenv("R_LIBS_USER")))

  keys <- c(
    "RENV_PATHS_ROOT",
    "RENV_PATHS_LIBRARY",
    "RENV_PATHS_LIBRARY_ROOT",
    "RENV_PATHS_LIBRARY_STAGING",
    "RENV_PATHS_LOCAL",
    "RENV_PATHS_CELLAR",
    "RENV_PATHS_SOURCE",
    "RENV_PATHS_BINARY",
    "RENV_PATHS_CACHE",
    "RENV_PATHS_RTOOLS",
    "RENV_PATHS_EXTSOFT",
    "RENV_PATHS_MRAN"
  )

  envvars <- as.list(keep(Sys.getenv(), keys))
  if (empty(envvars))
    return()

  args <- lapply(envvars, renv_path_normalize)
  do.call(Sys.setenv, args)

}


# equip-macos.R --------------------------------------------------------------


renv_equip_macos_specs <- function() {

  list(

    "4.0" = list(
      url = "https://cran.r-project.org/bin/macosx/tools/clang-8.0.0.pkg",
      dst = "/usr/local/clang8"
    ),

    "3.7" = list(
      url = "https://cran.r-project.org/bin/macosx/tools/clang-8.0.0.pkg",
      dst = "/usr/local/clang8"
    ),

    "3.6" = list(
      url = "https://cran.r-project.org/bin/macosx/tools/clang-7.0.0.pkg",
      dst = "/usr/local/clang7"
    ),

    "3.5" = list(
      url = "https://cran.r-project.org/bin/macosx/tools/clang-6.0.0.pkg",
      dst = "/usr/local/clang6"
    )

  )

}

renv_equip_macos_spec <- function(version = getRversion()) {
  renv_equip_macos_specs()[[renv_version_maj_min(version)]]
}

renv_equip_macos <- function() {

  renv_equip_macos_sdk()
  renv_equip_macos_toolchain()

}

renv_equip_macos_sdk <- function() {

  sdk <- "/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk"
  if (file.exists(sdk) || file.exists("/usr/include"))
    return(TRUE)

  system("/usr/bin/xcode-select --install")

  # give the user some time to respond to the dialog)
  Sys.sleep(5)

}

renv_equip_macos_toolchain <- function() {

  if (getRversion() >= "4.1.0")
    return()

  spec <- renv_equip_macos_spec()
  if (is.null(spec)) {
    fmt <- "no known toolchain recorded in renv for R %s"
    warningf(fmt, getRversion())
    return(FALSE)
  }

  url <- spec$url
  dst <- spec$dst

  clang <- file.path(dst, "bin/clang")
  if (file.exists(clang)) {
    fmt <- "- LLVM toolchain for R %s is already installed at %s."
    writef(fmt, getRversion(), shQuote(dst))
    return(TRUE)
  }

  destfile <- file.path(tempdir(), basename(url))
  download(url, destfile = destfile)

  if (renv_equip_macos_rstudio(spec, destfile))
    return(TRUE)

  command <- paste("sudo /usr/sbin/installer -pkg", shQuote(destfile), "-target /")
  caution_bullets(
    "The R LLVM toolchain has been successfully downloaded. Please execute:",
    command,
    "in a separate terminal to complete installation."
  )

  TRUE

}

renv_equip_macos_rstudio <- function(spec, destfile) {

  rstudio <-
    renv_rstudio_available() &&
    requireNamespace("rstudioapi", quietly = TRUE)

  if (!rstudio)
    return(FALSE)

  command <- paste("sudo -kS /usr/sbin/installer -pkg", shQuote(destfile), "-target /")
  prompt <- paste(
    "Installation of the R LLVM toolchain requires sudo.",
    "Please enter your account password.",
    sep = "\n"
  )

  installed <- local({

    password <- rstudioapi::askForPassword(prompt)
    if (is.null(password))
      return(FALSE)

    status <- system(command, input = password)
    if (status != 0L)
      return(FALSE)

    TRUE

  })

  if (!installed)
    return(FALSE)

  caution_bullets(
    "The R LLVM toolchain has been downloaded and installed to:",
    spec$dst,
    "This toolchain will be used by renv when installing packages from source."
  )

  return(TRUE)

}


# equip.R --------------------------------------------------------------------


#' Install required system libraries
#'
#' Equip your system with libraries commonly-used during compilation of
#' base and recommended \R packages. This was previously useful with older
#' versions of R on windows, but is no longer terribly helpful.
#'
#' @return This function is normally called for its side effects.
#' @export
#' @keywords internal
#' @examples
#' \dontrun{
#'
#' # download useful build tools
#' renv::equip()
#'
#' }
equip <- function() {

  renv_scope_error_handler()

  case(
    renv_platform_windows() ~ renv_equip_windows(),
    renv_platform_macos()   ~ renv_equip_macos(),
    renv_platform_linux()   ~ renv_equip_linux()
  )

  invisible(NULL)

}

renv_equip_windows <- function() {
  invisible(renv_extsoft_install() && renv_extsoft_use())
}

renv_equip_linux <- function() {
  stopf("renv::equip() not yet implemented for Linux")
}


# errors.R -------------------------------------------------------------------


renv_error_format_srcref <- function(call, srcref) {

  srcfile <- attr(srcref, "srcfile", exact = TRUE)

  if (inherits(srcfile, c("srcfilecopy", "srcfilealias"))) {
    start <- srcref[7L]
    end   <- srcref[8L]
  } else {
    start <- srcref[1L]
    end   <- srcref[3L]
  }

  srclines <- getSrcLines(srcfile, start, end)
  index <- regexpr("[^[:space:]]", srclines)
  indent <- min(index)
  code <- substring(srclines, indent)

  if (length(code) >= 8L) {
    simplified <- renv_error_simplify(call)
    if (!identical(simplified, call))
      code <- format(simplified)
  }

  n <- length(code)
  postfix <- sprintf("at %s#%i", basename(srcfile$filename), srcref[1L])
  code[n] <- paste(code[n], postfix)

  code

}

renv_error_simplify <- function(object) {

  case(
    is.function(object)  ~ renv_error_simplify_function(object),
    is.recursive(object) ~ renv_error_simplify_recursive(object),
    TRUE                 ~ object
  )

}

renv_error_simplify_function <- function(object) {
  f <- function() {}
  formals(f) <- formals(object)
  body(f) <- quote({ ... })
  f
}

renv_error_simplify_recursive <- function(object) {

  longcall <- renv_call_matches(object, name = "{") && length(object) >= 8

  if (longcall)
    return(quote(...))

  for (i in seq_along(object))
    if (!is.null(object[[i]]))
      object[[i]] <- renv_error_simplify(object[[i]])

  object

}

renv_error_format <- function(calls, frames) {

  # first, format calls
  formatted <- lapply(calls, function(call) {

    srcref <- attr(call, "srcref", exact = TRUE)
    if (!is.null(srcref)) {
      formatted <- catch(renv_error_format_srcref(call, srcref))
      if (!inherits(formatted, "error"))
        return(formatted)
    }

    if (is.function(call[[1]]))
      return("<condition-handler>(...)")

    format(renv_error_simplify(call))

  })

  # compute prefixes
  numbers <- format(seq_along(formatted))
  prefixes <- sprintf("%s: ", rev(numbers))

  # generate indent
  indent <- paste(rep.int(" ", min(nchar(prefixes))), collapse = "")

  # attach prefixes + indent
  annotated <- uapply(seq_along(formatted), function(i) {
    code <- formatted[[i]]
    prefix <- c(prefixes[[i]], rep.int(indent, length(code) - 1L))
    paste(prefix, code, sep = "")
  })

  header <- "Traceback (most recent calls last):"
  c(header, annotated)

}

renv_error_find <- function(calls, frames) {

  for (i in rev(seq_along(frames))) {

    fn <- sys.function(which = i)
    if (!identical(fn, stop))
      next

    frame <- frames[[i]]
    args <- frame[["args"]]
    if (is.null(args) || empty(args))
      next

    first <- args[[1L]]
    if (!inherits(first, "condition"))
      next

    return(first)

  }

}

renv_error_handler <- function(...) {

  calls <- head(sys.calls(), n = -1L)
  frames <- head(sys.frames(), n = -1L)

  error <- renv_error_find(calls, frames)
  if (identical(error$traceback, FALSE))
    return(character())

  formatted <- renv_error_format(calls, frames)
  caution(formatted)

  formatted

}

the$traceback <- NULL

renv_error_capture <- function(e) {
  calls <- head(sys.calls(), n = -2L)
  frames <- head(sys.frames(), n = -2L)
  traceback <- renv_error_format(calls, frames)
  the$traceback <- traceback
}

renv_error_tag <- function(e) {
  e$traceback <- the$traceback
  e
}

renv_error_handler_call <- function() {
  as.call(list(renv_error_handler))
}


# extsoft.R ------------------------------------------------------------------


renv_extsoft_curl_version <- function() {
  Sys.getenv("RENV_EXTSOFT_CURL_VERSION", unset = "7.77.0")
}

renv_extsoft_install <- function(quiet = FALSE) {

  extsoft <- renv_paths_extsoft()

  ensure_directory(extsoft)
  ensure_directory(file.path(extsoft, "lib/i386"))
  ensure_directory(file.path(extsoft, "lib/x64"))

  root <- "https://s3.amazonaws.com/rstudio-buildtools/extsoft"

  files <- c(
    sprintf("curl-%s-win32-mingw.zip", renv_extsoft_curl_version()),
    "glpk32.zip",
    "glpk64.zip",
    "local323.zip",
    "nlopt-2.4.2.zip",
    "spatial324.zip"
  )

  # check for missing installs
  files <- Filter(renv_extsoft_install_required, files)
  if (empty(files)) {
    if (!quiet) writef("- External software is up to date.")
    return(TRUE)
  }

  if (interactive()) {

    caution_bullets(
      "The following external software tools will be installed:",
      files,
      sprintf("Tools will be installed into %s.", renv_path_pretty(extsoft))
    )

    cancel_if(!proceed())

  }

  for (file in files) {

    # download the file
    url <- file.path(root, file)
    destfile <- renv_scope_tempfile("renv-archive-", fileext = ".zip")
    download(url, destfile = destfile, quiet = quiet)

    # write manifest
    manifest <- renv_extsoft_manifest_path(file)
    ensure_parent_directory(manifest)

    before <- list.files(extsoft, recursive = TRUE)

    # unpack archive
    if (file == "glpk32.zip") {

      unzip(destfile, files = "include/glpk.h", exdir = extsoft)
      unzip(destfile, exdir = file.path(extsoft, "lib/i386"), junkpaths = TRUE)

    } else if (file == "glpk64.zip") {

      unzip(destfile, files = "include/glpk.h", exdir = extsoft)
      unzip(destfile, exdir = file.path(extsoft, "lib/x64"), junkpaths = TRUE)

    } else if (file == "nlopt-2.4.2.zip") {

      unzip(destfile, exdir = extsoft)

      file.copy(file.path(extsoft, "nlopt-2.4.2/include"), extsoft, recursive = TRUE)
      file.copy(file.path(extsoft, "nlopt-2.4.2/lib"), extsoft, recursive = TRUE)
      unlink(file.path(extsoft, "nlopt-2.4.2"), recursive = TRUE)


    } else {

      unzip(destfile, exdir = extsoft)

    }

    after <- list.files(extsoft, recursive = TRUE)
    writeLines(setdiff(after, before), con = manifest)

  }

  writef("- External software successfully updated.")
  TRUE

}

renv_extsoft_install_required <- function(file) {

  manifest <- renv_extsoft_manifest_path(file)
  if (!file.exists(manifest))
    return(TRUE)

  files <- catch(readLines(manifest, warn = FALSE))
  if (inherits(files, "error"))
    return(FALSE)

  paths <- renv_paths_extsoft(files)
  !all(file.exists(paths))

}

renv_extsoft_use <- function(quiet = FALSE) {

  extsoft <- renv_paths_extsoft()
  path <- "~/.R/Makevars"

  ensure_parent_directory(path)
  original <- if (file.exists(path))
    readLines(path, warn = FALSE)
  else
    character()

  contents <- original

  localsoft <- paste("LOCAL_SOFT", extsoft, sep = " = ")
  contents <- inject(contents, "^#?LOCAL_SOFT", localsoft)

  localcpp <- "LOCAL_CPPFLAGS = -I\"$(LOCAL_SOFT)/include\""
  contents <- inject(contents, "^#?LOCAL_CPPFLAGS", localcpp)

  locallibs <- "LOCAL_LIBS = -L\"$(LOCAL_SOFT)/lib$(R_ARCH)\" -L\"$(LOCAL_SOFT)/lib\""
  contents <- inject(contents, "^#?LOCAL_LIBS", locallibs)

  libxml <- paste("LIB_XML", extsoft, sep = " = ")
  contents <- inject(contents, "^#?LIB_XML", libxml)

  if (identical(original, contents))
    return(TRUE)

  if (interactive()) {

    caution_bullets(
      "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."
    )

    cancel_if(!proceed())

  }

  if (!quiet) writef("- '%s' has been updated.", path)
  writeLines(contents, con = path)
  TRUE

}

renv_extsoft_manifest_path <- function(file) {
  name <- paste(file, "manifest", sep = ".")
  renv_paths_extsoft("manifests", name)
}


# filebacked.R ---------------------------------------------------------------


# tools for caching values read from a file, and invalidating those values if
# the file mtime changes. use `renv_filebacked_set()` to associate some value
# with a file at a particular point in time; `renv_filebacked_get()` will return
# that value, or NULL of the file mtime has changed
the$filebacked_cache <- new.env(parent = emptyenv())

renv_filebacked_clear <- function(context, path = NULL) {

  # get cache associated with this context
  envir <- renv_filebacked_envir(context)

  # list all available cached results
  existing <- ls(envir = envir, all.names = TRUE)

  # if path is set, use it; otherwise remove everything
  path <- path %||% existing

  # validate the requested paths exist in the environment
  removable <- renv_vector_intersect(path, existing)

  # remove them
  rm(list = removable, envir = envir)
}

renv_filebacked_set <- function(context, path, value) {

  # validate the path
  stopifnot(renv_path_absolute(path))

  # create our cache entry
  info <- renv_file_info(path)
  entry <- list(value = value, info = info)

  # store it
  envir <- renv_filebacked_envir(context)
  assign(path, entry, envir = envir)
  invisible(value)

}

renv_filebacked_get <- function(context, path) {

  # validate the path
  if (!renv_path_absolute(path))
    stopf("internal error: '%s' is not an absolute path", path)

  # get contextd sub-environment
  envir <- renv_filebacked_envir(context)

  # check for entry in the cache
  entry <- envir[[path]]
  if (is.null(entry))
    return(NULL)

  # extract pieces of interest
  value   <- entry$value
  oldinfo <- entry$info
  newinfo <- renv_file_info(path)

  # if the file didn't exist when we set the entry,
  # check and see if it's still not there
  if (is.na(oldinfo$isdir) && is.na(newinfo$isdir))
    return(value)

  # compare on fields of interest
  fields <- c("size", "isdir", "mtime")
  if (!identical(oldinfo[fields], newinfo[fields]))
    return(NULL)

  # looks good
  value

}

renv_filebacked_envir <- function(context) {
  the$filebacked_cache[[context]] <-
    the$filebacked_cache[[context]] %||%
    new.env(parent = emptyenv())
}

filebacked <- function(context, path, callback, ...) {

  # don't use filebacked cache when disabled
  config <- config$filebacked.cache()
  if (identical(config, FALSE))
    return(callback(path, ...))

  # check for cache entry -- if available, use it
  cache <- renv_filebacked_get(context, path)
  if (!is.null(cache))
    return(cache)

  # otherwise, generate our value and cache it
  result <- callback(path, ...)
  renv_filebacked_set(context, path, result)

  result

}

renv_filebacked_invalidate <- function(path) {
  renv_scope_options(warn = -1L)
  eapply(the$filebacked_cache, function(context) {
    rm(list = path, envir = context)
  })
}


# files.R --------------------------------------------------------------------


# NOTE: all methods here should either return TRUE if they were able to
# operate successfully, or throw an error if not
#
# TODO: some of these operations are a bit racy
renv_file_preface <- function(source, target, overwrite) {

  callback <- function() {}
  if (!renv_file_exists(source))
    stopf("source file '%s' does not exist", source)

  if (overwrite)
    callback <- renv_file_backup(target)

  if (renv_file_exists(target))
    stopf("target file '%s' already exists", target)

  callback

}

renv_file_copy <- function(source, target, overwrite = FALSE) {

  if (renv_file_same(source, target))
    return(TRUE)

  callback <- renv_file_preface(source, target, overwrite)
  defer(callback())

  # check to see if we're copying a plain file -- if so, things are simpler
  if (dir.exists(source))
    renv_file_copy_dir(source, target)
  else
    renv_file_copy_file(source, target)

}

renv_file_copy_file <- function(source, target) {

  # copy to temporary path
  tmpfile <- renv_scope_tempfile(".renv-copy-", tmpdir = dirname(target))
  status <- catchall(file.copy(source, tmpfile))
  if (inherits(status, "condition"))
    stop(status)

  # move from temporary path to final target
  status <- catchall(renv_file_move(tmpfile, target))
  if (inherits(status, "condition"))
    stop(status)

  # validate that the target file exists
  if (!renv_file_exists(target)) {
    fmt <- "attempt to copy file %s to %s failed (unknown reason)"
    stopf(fmt, renv_path_pretty(source), renv_path_pretty(target))
  }

  invisible(TRUE)

}

renv_file_copy_dir_robocopy <- function(source, target) {
  renv_robocopy_copy(source, target)
}

# TODO: the version of rsync distributed with macOS
# does not reliably copy file modified times, etc.
renv_file_copy_dir_rsync <- function(source, target) {
  source <- sub("/*$", "/", source)
  flags <- if (renv_platform_macos()) "-aAX" else "-a"
  args <- c(flags, renv_shell_path(source), renv_shell_path(target))
  renv_system_exec("rsync", args, action = "copying directory")
}

renv_file_copy_dir_cp <- function(source, target) {

  # ensure 'source' ends with a single trailing slash
  source <- sub("/*$", "/", source)

  # ensure tildes are path-expanded
  source <- path.expand(source)
  target <- path.expand(target)

  # build 'cp' arguments
  args <- c("-PR", renv_shell_path(source), renv_shell_path(target))

  # execute command
  renv_system_exec("cp", args, action = "copying directory")

}

renv_file_copy_dir_r <- function(source, target) {

  # create sub-directory to host copy attempt
  tempdir <- renv_scope_tempfile(".renv-copy-", tmpdir = dirname(target))
  ensure_directory(tempdir)

  # attempt to copy to generated folder
  status <- catchall(
    file.copy(
      source,
      tempdir,
      recursive = TRUE,
      copy.mode = TRUE,
      copy.date = TRUE
    )
  )

  if (inherits(status, "error"))
    stop(status)

  # R will copy the directory to a sub-directory in the
  # requested folder with the same filename as the source
  # folder, so peek into that folder to grab it and rename
  tempfile <- file.path(tempdir, basename(source))
  status <- catchall(renv_file_move(tempfile, target))
  if (inherits(status, "condition"))
    stop(status)

}

renv_file_copy_dir_impl <- function(source, target) {

  methods <- list(
    cp       = renv_file_copy_dir_cp,
    r        = renv_file_copy_dir_r,
    robocopy = renv_file_copy_dir_robocopy,
    rsync    = renv_file_copy_dir_rsync
  )

  copy <- config$copy.method()
  if (is.function(copy))
    return(copy(source, target))

  method <- methods[[tolower(copy)]]
  if (!is.null(method))
    return(method(source, target))

  if (renv_platform_windows())
    renv_file_copy_dir_robocopy(source, target)
  else if (renv_platform_unix())
    renv_file_copy_dir_cp(source, target)
  else
    renv_file_copy_dir_r(source, target)

  file.exists(target)

}

renv_file_copy_dir <- function(source, target) {

  # create temporary sub-directory
  tmpdir <- dirname(target)
  ensure_directory(tmpdir)
  tempdir <- renv_scope_tempfile(".renv-copy-", tmpdir = tmpdir)

  # copy to that directory
  status <- catchall(renv_file_copy_dir_impl(source, tempdir))
  if (inherits(status, "condition"))
    stop(status)

  # move directory to final location
  status <- catchall(renv_file_move(tempdir, target))
  if (inherits(status, "condition"))
    stop(status)

  # validate that the target file exists
  if (!renv_file_exists(target)) {
    fmt <- "attempt to copy directory %s to %s failed (unknown reason)"
    stopf(fmt, renv_path_pretty(source), renv_path_pretty(target))
  }

  invisible(TRUE)

}

renv_file_move <- function(source, target, overwrite = FALSE) {

  if (renv_file_same(source, target))
    return(TRUE)

  callback <- renv_file_preface(source, target, overwrite)
  defer(callback())

  # first, attempt to do a plain rename
  # use catchall since this might fail for e.g. cross-device links
  # (note that junction points on Windows will be copies as-is)
  move <- catchall(file.rename(source, target))
  if (renv_file_exists(target))
    return(TRUE)

  # expand tildes
  source <- path.expand(source)
  target <- path.expand(target)

  # on unix, try using 'mv' command directly
  # (can handle cross-device copies / moves a bit more efficiently)
  if (renv_platform_unix()) {
    args <- c(renv_shell_path(source), renv_shell_path(target))
    status <- catchall(system2("mv", args, stdout = FALSE, stderr = FALSE))
    if (renv_file_exists(target))
      return(TRUE)
  }

  # on Windows, similarly try 'robocopy' command
  # (should be faster than 'move' for large directories)
  if (renv_platform_windows()) {
    status <- catchall(renv_robocopy_move(source, target))
    if (renv_file_exists(target))
      return(TRUE)
  }

  # nocov start
  # rename failed; fall back to copying
  # (and be sure to remove the source file / directory on success)
  copy <- catchall(renv_file_copy(source, target, overwrite = overwrite))
  if (identical(copy, TRUE) && file.exists(target)) {
    unlink(source, recursive = TRUE)
    return(TRUE)
  }

  # rename and copy both failed: inform the user
  fmt <- stack()
  fmt$push("could not copy / move file '%s' to '%s'")
  if (inherits(move, "condition"))
    fmt$push(paste("move:", conditionMessage(move)))
  if (inherits(copy, "condition"))
    fmt$push(paste("copy:", conditionMessage(copy)))

  text <- paste(fmt$data(), collapse = "\n")
  stopf(text, source, target)
  # nocov end

}

renv_file_link <- function(source, target, overwrite = FALSE) {

  if (renv_file_same(source, target))
    return(TRUE)

  callback <- renv_file_preface(source, target, overwrite)
  defer(callback())

  if (renv_platform_windows()) {

    # use junction points on Windows by default as symlinks
    # are unreliable / un-deletable in some circumstances
    status <- catchall(Sys.junction(source, target))
    if (identical(status, TRUE))
      return(TRUE)

    # if Sys.junction() fails, it may leave behind an empty
    # directory. this may occur if the source and target files
    # reside on different volumes. either way, remove an empty
    # left-behind directory on failure
    unlink(target, recursive = TRUE, force = TRUE)

  } else {

    # on non-Windows, we can try to create a symlink
    status <- catchall(file.symlink(source, target))
    if (identical(status, TRUE))
      return(TRUE)

  }

  # all else fails, just perform a copy
  renv_file_copy(source, target, overwrite = overwrite)

}

renv_file_junction <- function(source, target) {

  if (!renv_platform_windows())
    stopf("'renv_file_junction()' is only available on Windows")

  if (renv_file_exists(target))
    stopf("file '%s' already exists")

  status <- catchall(Sys.junction(source, target))
  if (inherits(status, "condition")) {
    unlink(target, recursive = TRUE, force = TRUE)
    stop(status)
  }

  TRUE

}

renv_file_same <- function(source, target) {

  # if the paths are the same, we can return early
  if (identical(source, target))
    return(TRUE)

  # check to see if they're equal after normalization
  # (e.g. for symlinks pointing to same file)
  source <- renv_path_normalize(source)
  target <- renv_path_normalize(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)
  tinfo <- renv_file_info(target)
  if (!identical(c(sinfo), c(tinfo)))
    return(FALSE)

  TRUE

}

# NOTE: returns a callback which should be used in e.g. an defer handler
# to restore the file if the attempt to update the file failed
renv_file_backup <- function(path) {

  # if no file exists then nothing to backup
  if (!renv_file_exists(path))
    return(function() {})

  # normalize the path (since the working directory could change
  # by the time the callback is invoked). note that the file may
  # be a broken symlink so construct the path by normalizing the
  # parent directory and building path relative to that
  parent <- renv_path_normalize(dirname(path), mustWork = TRUE)
  path <- file.path(parent, basename(path))

  # attempt to rename the file
  pattern <- sprintf(".renv-backup-%i-%s", Sys.getpid(), basename(path))
  tempfile <- tempfile(pattern, tmpdir = dirname(path))
  if (!renv_file_move(path, tempfile))
    return(function() {})

  # return callback that will restore if needed
  function() {

    if (!renv_file_exists(path))
      renv_file_move(tempfile, path)
    else
      unlink(tempfile, recursive = TRUE)

  }

}

renv_file_info <- function(paths, extra_cols = FALSE) {
  suppressWarnings(file.info(paths, extra_cols = extra_cols))
}

renv_file_mode <- function(paths) {
  suppressWarnings(file.mode(paths))
}

# NOTE: returns true for files that are broken symlinks
renv_file_exists <- function(path) {

  if (renv_platform_windows())
    renv_file_exists_win32(path)
  else
    renv_file_exists_unix(path)

}

renv_file_exists_win32 <- function(path) {
  file.exists(path)
}

renv_file_exists_unix <- function(path) {
  !is.na(Sys.readlink(path)) | file.exists(path)
}

renv_file_list <- function(path, full.names = TRUE) {

  # list files
  files <- renv_file_list_impl(path)

  # NOTE: paths may be marked with UTF-8 encoding;
  # if that's the case we need to use paste rather
  # than file.path to preserve the encoding
  if (full.names && length(files))
    files <- paste(path, files, sep = "/")

  files

}

renv_file_list_impl <- function(path) {
  if (renv_platform_unix())
    renv_file_list_impl_unix(path)
  else
    renv_file_list_impl_win32(path)
}

renv_file_list_impl_unix <- function(path) {
  list.files(path, all.files = TRUE, no.. = TRUE)
}

# nocov start
renv_file_list_impl_win32 <- function(path) {

  # first, try a plain list.files to see if we can get away with that
  files <- list.files(path, all.files = TRUE, no.. = TRUE)
  if (!any(grepl("?", files, fixed = TRUE)))
    return(files)

  # otherwise, try some madness ...
  #
  # change working directory (done just to avoid encoding issues
  # when submitting path to cmd shell)
  renv_scope_wd(path)

  # NOTE: a sub-shell is required here in some contexts; e.g. when running
  # tests non-interactively or building in the RStudio pane
  command <- paste(comspec(), "/U /C dir /B")
  conn <- pipe(command, open = "rb", encoding = "native.enc")
  defer(close(conn))

  # read binary output from connection
  output <- stack()

  while (TRUE) {

    data <- readBin(conn, what = "raw", n = 1024L)
    if (empty(data))
      break

    output$push(data)

  }

  # join into single raw vector
  encoded <- unlist(output$data(), recursive = FALSE, use.names = FALSE)

  # convert raw data (encoded as UTF-16LE) to UTF-8
  converted <- iconv(list(encoded), from = "UTF-16LE", to = "UTF-8")

  # split on (Windows) newlines
  paths <- strsplit(converted, "\r\n", fixed = TRUE)[[1]]

  # just in case?
  paths[nzchar(paths)]

}
# nocov end

renv_file_type <- function(paths, symlinks = TRUE) {

  info <- renv_file_info(paths)

  types <- character(length(paths))
  types[info$isdir %in% FALSE] <- "file"
  types[info$isdir %in% TRUE ] <- "directory"

  if (symlinks && !renv_platform_windows()) {
    links <- Sys.readlink(paths)
    types[!is.na(links) & nzchar(links)] <- "symlink"
  }

  types

}

# nocov start
renv_file_edit <- function(path) {

  # https://github.com/rstudio/renv/issues/44
  dlls <- getLoadedDLLs()
  if (is.null(dlls[["(embedding)"]]))
    return(utils::file.edit(path))

  routines <- getDLLRegisteredRoutines("(embedding)")
  routine <- routines[[".Call"]][["rs_editFile"]]
  if (is.null(routine))
    return(utils::file.edit(path))

  do.call(.Call, list(routine, path, PACKAGE = "(embedding)"))

}
# nocov end

renv_file_find <- function(path, predicate) {

  # canonicalize path
  # (note: don't normalize as we don't want to follow symlinks)
  path <- renv_path_canonicalize(path)
  parent <- dirname(path)

  # compute number of slashes
  # (avoid searching beyond home directory, unless we're virtualized)
  virtualized <- renv_virtualization_type() != "native"
  slashes <- gregexpr("/", path, fixed = TRUE)[[1L]]
  n <- length(slashes) - if (virtualized) 0L else 2L

  for (i in 1:n) {

    if (file.exists(path)) {
      status <- predicate(path)
      if (!is.null(status))
        return(status)
    }

    path <- parent
    parent <- dirname(path)

  }

  predicate(path)

}

renv_file_read <- function(path) {
  renv_scope_options(warn = -1L)
  contents <- readLines(path, warn = FALSE, encoding = "UTF-8")
  paste(contents, collapse = "\n")
}

renv_file_shebang <- function(path) {

  # NOTE: we use 'condition' as a cheap way to capture both errors and warnings
  # since 'file()' may just report a warning rather than an error if it fails
  # to open a file due to inadequate permissions
  tryCatch(
    renv_file_shebang_impl(path),
    condition = function(e) ""
  )

}

renv_file_shebang_impl <- function(path) {

  renv_scope_options(warn = -1L)

  # open connection to file
  con <- file(path, open = "rb", encoding = "native.enc")
  defer(close(con))

  # validate file starts with '#!' -- read using 'raw' vector to avoid
  # issues which files that might start with null bytes
  bytes <- readBin(con, what = "raw", n = 2L)
  expected <- as.raw(c(0x23L, 0x21L))
  if (!identical(bytes, expected))
    return("")

  # read a single line from the connection
  readLines(con, n = 1L, warn = FALSE)

}

# here, 'broken' implies a file which is a link pointing to a file that
# doesn't exist, so only returns true if the file is "link"-y and the
# file it points to doesn't exist
renv_file_broken <- function(paths) {
  if (renv_platform_unix())
    renv_file_broken_unix(paths)
  else
    renv_file_broken_win32(paths)
}

renv_file_broken_unix <- function(paths) {
  # a symlink is broken if:
  # - the file is a symlink (tested via Sys.readlink)
  # - the file it points to does not exist (tested via file.exists)
  !is.na(Sys.readlink(paths)) & !file.exists(paths)
}

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)
  }
}

renv_file_size <- function(path) {
  file.info(path, extra_cols = FALSE)$size
}

renv_file_remove <- function(paths) {
  if (renv_platform_windows())
    renv_file_remove_win32(paths)
  else
    renv_file_remove_unix(paths)
}

renv_file_remove_win32 <- function(paths) {
  for (path in paths) {
    command <- paste("rmdir /S /Q", renv_shell_path(path))
    shell(command)
  }
}

renv_file_remove_unix <- function(paths) {
  unlink(paths, recursive = TRUE, force = TRUE)
}

renv_file_writable <- function(path) {

  # allow users to opt-out just in case
  override <- getOption("renv.download.check_writable", default = TRUE)
  if (!identical(override, TRUE))
    return(TRUE)

  # if we're given the path to a file, use the parent directory instead
  info <- renv_file_info(path)
  if (!identical(info$isdir, TRUE))
    path <- dirname(path)

  # if we still don't have a directory, bail
  info <- renv_file_info(path)
  if (!identical(info$isdir, TRUE))
    return(FALSE)

  # try creating and removing a temporary file in this directory
  tempfile <- renv_scope_tempfile(".renv-write-test-", tmpdir = path)
  ok <- dir.create(tempfile, showWarnings = FALSE)

  # return ok if we succeeded
  ok

}


# git.R ----------------------------------------------------------------------


git <- function() {

  gitpath <- Sys.which("git")
  if (!nzchar(gitpath))
    stop("failed to find git executable on the PATH")

  gitpath

}


renv_git_preflight <- function() {
  if (!nzchar(Sys.which("git")))
    stopf("'git' is not available on the PATH")
}

renv_git_root <- function(project) {

  project <- renv_path_normalize(project)
  renv_file_find(project, function(parent) {
    gitroot <- file.path(parent, ".git")
    if (file.exists(gitroot))
      return(gitroot)
  })

}


# graph.R --------------------------------------------------------------------


#' Generate a Package Dependency Graph
#'
#' Generate a package dependency graph.
#'
#' @inheritParams renv-params
#'
#' @param root The top-most package dependencies of interest in the dependency graph.
#'
#' @param leaf The bottom-most package dependencies of interest in the dependency graph.
#'
#' @param suggests Should suggested packages be included within
#'   the dependency graph?
#'
#' @param enhances Should enhanced packages be included within
#'   the dependency graph?
#'
#' @param resolver An \R function accepting a package name, and returning the
#'   contents of its `DESCRIPTION` file (as an \R `data.frame` or `list`).
#'   When `NULL` (the default), an internal resolver is used.
#'
#' @param renderer Which package should be used to render the resulting graph?
#'
#' @param attributes An \R list of graphViz attributes, mapping node names to
#'   attribute key-value pairs. For example, to ask graphViz to prefer orienting
#'   the graph from left to right, you can use `list(graph = c(rankdir = "LR"))`.
#'
#' @examples
#'
#' \dontrun{
#' # graph the relationship between devtools and rlang
#' graph(root = "devtools", leaf = "rlang")
#'
#' # figure out why a project depends on 'askpass'
#' graph(leaf = "askpass")
#' }
#'
#' @keywords internal
graph <- function(root = NULL,
                  leaf = NULL,
                  ...,
                  suggests   = FALSE,
                  enhances   = FALSE,
                  resolver   = NULL,
                  renderer   = c("DiagrammeR", "visNetwork"),
                  attributes = list(),
                  project    = NULL)
{
  renv_scope_error_handler()
  project <- renv_project_resolve(project)

  # figure out packages to try and read
  root <- root %||% renv_graph_roots(project)

  # resolve fields
  fields <- c(
    "Depends", "Imports", "LinkingTo",
    if (suggests) "Suggests",
    if (enhances) "Enhances"
  )

  # resolve renderer
  renderer <- renv_graph_renderer(renderer)

  # find dependencies
  envir <- new.env(parent = emptyenv())
  revdeps <- new.env(parent = emptyenv())
  for (package in root)
    renv_graph_build(package, fields, resolver, envir, revdeps)

  # prune the tree
  tree <- renv_graph_prune(root, leaf, envir, revdeps)

  # compute the graph
  graph <- enumerate(tree, function(package, dependencies) {

    enumerate(dependencies, function(field, packages) {
      attrs <- renv_graphviz_attrs(field, renderer)
      renv_graphviz_edge(package, packages, attrs)
    })

  })

  # figure out which packages remain part of the graph after pruning
  ok <- map_lgl(graph, function(items) {
    any(map_int(items, length) > 0)
  })

  remaining <- intersect(root, names(graph)[ok])
  if (empty(remaining)) {
    fmt <- "- Could not find any relationship between the requested packages."
    writef(fmt)
    return(invisible(NULL))
  }

  defaults <- renv_graphviz_defaults(renderer)
  attributes <- overlay(defaults, attributes)

  # render attributes
  attrtext <- renv_graphviz_render(attributes, TRUE)

  # fill package names which are top-level dependencies
  topattrs <- renv_graphviz_render(
    map(named(remaining), function(name) {
      list(
        style     = "filled",
        fillcolor = "#b3cde3"
      )
    }),
    asis = FALSE
  )

  botattrs <- renv_graphviz_render(
    map(named(leaf), function(name) {
      list(
        style     = "filled",
        fillcolor = "#ccebc5"
      )
    }),
    asis = FALSE
  )

  # collapse into text
  parts <- c(
    'digraph {', '',
    attrtext, '',
    topattrs, '',
    botattrs, '',
    unlist(graph), '',
    '}'
  )

  diagram <- paste(parts, collapse = "\n")

  renderer <- case(

    identical(renderer, "DiagrammeR") ~ function(dot) {
      DiagrammeR <- renv_namespace_load("DiagrammeR")
      DiagrammeR$grViz(diagram = dot)
    },

    identical(renderer, "visNetwork") ~ function(dot) {

      visNetwork <- renv_namespace_load("visNetwork")
      graph <- visNetwork$visNetwork(dot = dot)

      graph$x$options$edges$font$background <- "white"

      # TODO: allow hierarchical layout via option?
      # graph$x$options$layout = list(
      #   hierarchical = list(
      #     blockShifting   = TRUE,
      #     levelSeparation = 50,
      #     nodeSpacing     = 1,
      #     shakeTowards    = "roots",
      #     sortMethod      = "directed"
      #   )
      # )

      graph

    },

    is.function(renderer) ~ renderer,

    ~ stop("unrecognized renderer")

  )

  renderer(diagram)
}

renv_graph_build <- function(package, fields, resolver, envir, revdeps) {

  # check if we've already scanned this package
  if (exists(package, envir = envir))
    return()

  # read package dependencies
  deps <- renv_graph_dependencies(package, fields, resolver)

  # add dependencies to graph
  assign(package, deps, envir = envir)

  # recurse
  children <- sort(unique(unlist(deps)))
  for (child in children) {
    assign(child, c(package, revdeps[[child]]), envir = revdeps)
    renv_graph_build(child, fields, resolver, envir, revdeps)
  }

}

renv_graph_revdeps <- function(packages, revdeps) {

  envir <- new.env(parent = emptyenv())
  for (package in packages)
    renv_graph_revdeps_impl(package, envir, revdeps)

  ls(envir = envir)

}

renv_graph_revdeps_impl <- function(package, envir, revdeps) {

  if (visited(package, envir))
    return()

  for (child in revdeps[[package]])
    renv_graph_revdeps_impl(child, envir, revdeps)

}

renv_graph_roots <- function(project) {

  deps <- renv_dependencies_impl(project, errors = "ignored")
  sort(unique(deps$Package))

}

renv_graph_dependencies <- function(package, fields, resolver) {

  base <- installed_packages(priority = "base")

  desc <- local({

    # try using the resolver if supplied
    if (!is.null(resolver)) {
      desc <- catch(resolver(package))
      if (inherits(desc, "error"))
        warning(desc)
      else if (!is.null(desc))
        return(desc)
    }

    # check for (and prefer) a locally-installed package
    path <- renv_package_find(package)
    if (nzchar(path))
      return(renv_description_read(path))

    # otherwise, try and see if this is a known CRAN package
    as.list(renv_available_packages_entry(package))

  })

  # parse the fields
  values <- map(fields, function(field) {

    item <- desc[[field]]
    if (is.null(item))
      return(NULL)

    parsed <- renv_description_parse_field(item)
    packages <- parsed$Package

    setdiff(packages, c("R", base$Package))

  })

  names(values) <- fields
  values

}

renv_graph_prune <- function(root, leaf, envir, revdeps) {

  # grab all computed dependencies
  all <- as.list(envir)

  # if we don't have any leaves, then just return everything
  if (empty(leaf))
    return(all)

  # otherwise, find recursive dependencies of the requested packages
  rrd <- renv_graph_revdeps(leaf, revdeps)
  map(all, function(children) {
    map(children, intersect, rrd)
  })

}

renv_graphviz_node <- function(nodes, asis, attrs) {

  keys <- names(attrs)
  vals <- renv_json_quote(attrs)
  attrtext <- paste(keys, vals, sep = "=", collapse = ", ")

  fmt <- if (asis) '%s [%s]' else '"%s" [%s]'
  sprintf(fmt, nodes, attrtext)

}

renv_graphviz_edge <- function(lhs, rhs, attrs) {

  if (empty(lhs) || empty(rhs))
    return(character())

  keys <- names(attrs)
  vals <- renv_json_quote(attrs)
  attrtext <- paste(keys, vals, sep = "=", collapse = ", ")

  fmt <- '"%s" -> "%s" [%s]'
  sprintf(fmt, lhs, rhs, attrtext)

}

renv_graphviz_attrs <- function(field, renderer) {

  dil <- "#c0c0c0"

  defaults <- list(

    Depends = list(
      color = dil,
      style = "solid"
    ),

    Imports = list(
      color = dil,
      style = "solid"
    ),

    LinkingTo = list(
      color = dil,
      style = "dashed"
    ),

    Suggests = list(
      color = "darkgreen",
      style = "dashed"
    ),

    Enhances = list(
      color = "darkblue",
      style = "dashed"
    )

  )

  attrs <- defaults[[field]]
  if (identical(renderer, "visNetwork")) {

    extra <- c(
      font.align = "middle"
    )

    attrs <- c(attrs, extra)

  }

  attrs

}

renv_graphviz_defaults <- function(renderer) {

  case(
    identical(renderer, "visNetwork") ~ renv_graphviz_defaults_visnetwork(),
    identical(renderer, "DiagrammeR") ~ renv_graphviz_defaults_diagrammer(),
  )

}

renv_graphviz_defaults_visnetwork <- function() {

  list(

    node = list(
      style     = "filled",
      shape     = "ellipse",
      color     = "black",
      fillcolor = "#e5d8bd",
      fontname  = "Helvetica"
    )

  )

}

renv_graphviz_defaults_diagrammer <- function() {

  list(

    graph = list(
      nodesep = 0.10
    ),

    node = list(
      style     = "filled",
      shape     = "ellipse",
      fillcolor = "#e5d8bd",
      fontname  = "Helvetica"
    )

  )

}

renv_graphviz_render <- function(attributes, asis) {

  rendered <- enumerate(attributes, function(key, value) {

    if (is.null(names(value))) {
      lhs <- if (asis) key else renv_json_quote(key)
      rhs <- renv_graphviz_render_value(value)
      if (length(lhs) && length(rhs))
        paste(lhs, rhs, sep = " = ")
    } else {
      keys <- names(value)
      vals <- renv_graphviz_render_value(value)
      fmt <- if (asis) '%s [%s]' else '"%s" [%s]'
      sprintf(fmt, key, paste(keys, vals, sep = "=", collapse = ", "))
    }

  })

  unlist(rendered, recursive = TRUE, use.names = FALSE)

}

renv_graphviz_render_value <- function(value) {
  if (is.numeric(value))
    format(value)
  else if (is.logical(value))
    tolower(as.character(value))
  else
    renv_json_quote(value)
}

renv_graph_renderer <- function(renderer) {

  # allow functions as-is
  if (is.function(renderer))
    return(renderer)

  # otherwise, match
  renderer <- match.arg(renderer, choices = c("DiagrammeR", "visNetwork"))
  if (!renv_package_installed(renderer)) {
    fmt <- "package '%s' is required to render graphs but is not installed"
    stopf(fmt, renderer)
  }

  renderer

}



# hash.R ---------------------------------------------------------------------


renv_hash_text <- function(text) {
  renv_bootstrap_hash_text(text)
}

renv_hash_description <- function(path) {
  filebacked(
    context  = "renv_hash_description",
    path     = path,
    callback = renv_hash_description_impl
  )
}

renv_hash_description_impl <- function(path) {

  dcf <- case(
    is.character(path) ~ renv_description_read(path),
    is.list(path)      ~ path,
    ~ stop("unexpected path '%s'", path)
  )

  # include default fields
  fields <- c(
    "Package", "Version", "Title", "Author", "Maintainer", "Description",
    "Depends", "Imports", "Suggests", "LinkingTo"
  )

  # add remotes fields
  remotes <- renv_hash_description_remotes(dcf)

  # retrieve these fields
  subsetted <- dcf[renv_vector_intersect(c(fields, remotes), names(dcf))]

  # 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-")
  contents <- paste(names(ordered), ordered, sep = ": ", collapse = "\n")

  # remove whitespace -- it's possible that tools (e.g. Packrat) that
  # mutate a package's DESCRIPTION file may also inadvertently change
  # the structure of whitespace within some fields; that whitespace is
  # normally not semantically meaningful so we remove that so such
  # DESCRIPTIONS can obtain the same hash value. (this ultimately
  # arises as 'write.dcf()' allows both 'indent' and 'width' to be
  # 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)

}


# history.R ------------------------------------------------------------------


#' View and revert to a historical lockfile
#'
#' @description
#' `history()` uses your version control system to show prior versions of the
#' lockfile and `revert()` allows you to restore one of them.
#'
#' These functions are currently only implemented for projects that use git.
#'
#' @inherit renv-params
#'
#' @export
#'
#' @return `history()` returns a `data.frame` summarizing the commits in which
#'   `renv.lock` has been changed. `revert()` is usually called for its
#'   side-effect but also invisibly returns the `commit` used.
#'
#' @examples
#' \dontrun{
#'
#' # get history of previous versions of renv.lock in VCS
#' db <- renv::history()
#'
#' # choose an older commit
#' commit <- db$commit[5]
#'
#' # revert to that version of the lockfile
#' renv::revert(commit = commit)
#'
#' }
history <- function(project = NULL) {

  renv_scope_error_handler()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  lockpath <- renv_lockfile_path(project)
  if (!file.exists(lockpath))
    return(data_frame())

  renv_git_preflight()

  renv_scope_wd(project)

  args <- c("log", "--pretty=format:%H\031%at\031%ct\031%s", renv_shell_path(lockpath))
  data <- renv_system_exec("git", args, action = "retrieving git log")

  parts <- strsplit(data, "\031", fixed = TRUE)
  tbl <- bind(parts, names = c("commit", "author_date", "committer_date", "subject"))
  tbl$author_date <- as.POSIXct(as.numeric(tbl$author_date), origin = "1970-01-01")
  tbl$committer_date <- as.POSIXct(as.numeric(tbl$committer_date), origin = "1970-01-01")

  tbl

}

#' @param commit The commit associated with a prior version of the lockfile.
#' @param ... Optional arguments; currently unused.
#' @export
#' @rdname history
revert <- function(commit = "HEAD", ..., project = NULL) {

  renv_scope_error_handler()
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  renv_git_preflight()

  renv_scope_wd(project)

  lockpath <- renv_lockfile_path(project = project)
  system2("git", c("checkout", commit, "--", renv_shell_path(lockpath)))
  system2("git", c("reset", "HEAD", renv_shell_path(lockpath)), stdout = FALSE, stderr = FALSE)
  system2("git", c("diff", "--", renv_shell_path(lockpath)))

  writef("- renv.lock from commit %s has been checked out.", commit)
  invisible(commit)

}


# homebrew.R -----------------------------------------------------------------


renv_homebrew_root <- function() {

  # allow override
  root <- Sys.getenv("RENV_HOMEBREW_ROOT", unset = NA)
  if (!is.na(root))
    return(root)

  # indirection for arm64 macOS
  if (renv_platform_macos() && renv_platform_machine() != "x86_64")
    return("/opt/homebrew")

  # default to /usr/local
  "/usr/local"

}


# http.R ---------------------------------------------------------------------


renv_http_useragent <- function() {
  agent <- getOption("renv.http.useragent", default = getOption("HTTPUserAgent"))
  agent %||% renv_http_useragent_default()
}

renv_http_useragent_default <- function() {
  version <- getRversion()
  platform <- with(R.version, paste(version, platform, arch, os))
  sprintf("R/%s R (%s)", version, platform)
}


# hydrate.R ------------------------------------------------------------------


#' Copy packages from user libraries to a project library
#'
#' @description
#' `hydrate()` installs missing packages from a user library into the project
#' library. `hydrate()` is called automatically by [init()], and it is rare
#' 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
#' 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,
#' then call [snapshot()] to record updated package versions in the lockfile.
#'
#' @inherit renv-params
#'
#' @param packages The set of \R packages to install. When `NULL`, the
#'   packages found by [dependencies()] are used.
#'
#' @param library The \R library to be hydrated. When `NULL`, the active
#'   library as reported by `.libPaths()` is used.
#'
#' @param repos The \R repositories to be used. If the project depends on any
#'   \R packages which cannot be found within the user library paths, then
#'   those packages will be installed from these repositories instead.
#'
#' @param update Boolean; should `hydrate()` attempt to update already-installed
#'   packages if the requested package is already installed in the project
#'   library? Set this to `"all"` if you'd like _all_ packages to be refreshed
#'   from the source library if possible.
#'
#' @param sources A vector of library paths where renv should look for packages.
#'   When `NULL` (the default), `hydrate()` will look in the system libraries
#'   (the user library, the site library and the default library) then the
#'   renv cache.
#'
#'   If a package is not found in any of these locations, `hydrate()`
#'   will try to install it from the active R repositories.
#'
#' @param prompt Boolean; prompt the user before taking any action? Ignored
#'   when `report = FALSE`.
#'
#' @param report Boolean; display a report of what packages will be installed
#'   by `renv::hydrate()`?
#'
#' @return A named \R list, giving the packages that were used for hydration
#'   as well as the set of packages which were not found.
#'
#' @export
#'
#' @keywords internal
#'
#' @examples
#' \dontrun{
#'
#' # hydrate the active library
#' renv::hydrate()
#'
#' }
hydrate <- function(packages = NULL,
                    ...,
                    library = NULL,
                    repos   = getOption("repos"),
                    update  = FALSE,
                    sources = NULL,
                    prompt  = interactive(),
                    report  = TRUE,
                    project = NULL)
{
  renv_scope_error_handler()
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_scope_verbose_if(prompt)

  renv_activate_prompt("hydrate", library, prompt, project)

  renv_scope_options(repos = repos)
  library <- renv_path_normalize(library %||% renv_libpaths_active())
  packages <- packages %||% renv_hydrate_packages(project)

  # find packages used in this project, and the dependencies of those packages
  deps <- renv_hydrate_dependencies(project, packages, sources)

  # remove 'renv' since it's managed separately
  deps$renv <- NULL

  # 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
  linkable <- renv_cache_linkable(project = project, library = library)

  # get and construct path to library
  ensure_directory(library)

  # only hydrate with packages that are either not currently installed,
  # or (if update = TRUE) the version in the library is newer
  packages <- renv_hydrate_filter(packages, library, update)

  # inform user about changes
  if (report) {
    renv_hydrate_report(packages, missing, linkable)
    if (length(packages) || length(missing))
      cancel_if(prompt && !proceed())
  }

  # check for nothing to be done
  if (empty(packages) && empty(missing)) {
    if (report)
      writef("- No new packages were discovered in this project; nothing to do.")
    return(invisible(list(packages = list(), missing = list())))
  }

  # copy packages from user library to cache
  before <- Sys.time()
  if (length(packages)) {
    if (linkable)
      renv_hydrate_link_packages(packages, library, project)
    else
      renv_hydrate_copy_packages(packages, library, project)
  }
  after <- Sys.time()

  if (report) {
    time <- difftime(after, before, units = "auto")
    fmt <- "- Hydrated %s packages in %s."
    writef(fmt, length(packages), renv_difftime_format(time))
  }

  # attempt to install missing packages (if any)
  missing <- renv_hydrate_resolve_missing(project, library, missing)

  # we're done!
  result <- list(packages = packages, missing = missing)
  invisible(result)
}

renv_hydrate_filter <- function(packages, library, update) {

  # run filter
  keep <- enumerate(
    packages,
    renv_hydrate_filter_impl,
    library = library,
    update = update,
    FUN.VALUE = logical(1)
  )

  # filter based on kept packages
  packages[keep]

}

renv_hydrate_filter_impl <- function(package, path, library, update) {

  # if user has requested hydration of all packages, respect that
  if (identical(update, "all"))
    return(TRUE)

  # is the package already installed in the requested library?
  # if not, then we'll want to hydrate this package
  # if so, we'll want to compare the version first and
  # hydrate only if the requested version is newer than the current
  descpath <- file.path(library, package, "DESCRIPTION")
  if (file.exists(descpath)) {
    desc <- catch(renv_description_read(path = descpath))
    if (inherits(desc, "error"))
      return(TRUE)
  }

  # get the current package version
  current <- catch(numeric_version(desc[["Version"]]))
  if (inherits(current, "error"))
    return(TRUE)

  # if the package is already installed and we're not updating, stop here
  if (identical(update, FALSE))
    return(FALSE)

  # check to-be-copied package version
  requested <- catch({
    desc <- renv_description_read(path = path)
    numeric_version(desc[["Version"]])
  })

  # only hydrate with a newer version
  requested > current

}

renv_hydrate_packages <- function(project) {
  renv_snapshot_dependencies(project, dev = TRUE)
}

renv_hydrate_dependencies <- function(project,
                                      packages = NULL,
                                      libpaths = NULL)
{
  ignored <- renv_project_ignored_packages(project = project)
  packages <- renv_vector_diff(packages, ignored)
  libpaths <- libpaths %||% renv_hydrate_libpaths()
  renv_package_dependencies(packages, libpaths = libpaths, project = project)
}

# NOTE: we don't want to look in user / site libraries when testing
# on CRAN, as we may accidentally find versions of packages available
# on CRAN but not that we want to use during tests
renv_hydrate_libpaths <- function() {

  conf <- config$hydrate.libpaths()
  if (is.character(conf) && length(conf))
    conf <- unlist(strsplit(conf, ":", fixed = TRUE))

  libpaths <- case(
    renv_tests_running() ~ character(),
    length(conf) ~ conf,
    ~ c(
      renv_libpaths_default(),
      renv_libpaths_user(),
      renv_libpaths_site(),
      renv_libpaths_system()
    )
  )

  libpaths <- .expand_R_libs_env_var(libpaths)
  unique(renv_path_normalize(libpaths))

}

# takes a package called 'package' installed at location 'location',
# copies that package into the cache, and then links from the cache
# to the (private) library 'library'
renv_hydrate_link_package <- function(package, location, library) {

  # construct path to cache
  record <- catch(renv_snapshot_description(location))
  if (inherits(record, "error"))
    return(FALSE)

  cache <- renv_cache_find(record)
  if (!nzchar(cache))
    return(FALSE)

  # copy package into the cache
  if (!file.exists(cache)) {
    ensure_parent_directory(cache)
    renv_file_copy(location, cache)
  }

  # link package back from cache to library
  target <- file.path(library, package)
  ensure_parent_directory(target)
  renv_file_link(cache, target, overwrite = TRUE)

}

renv_hydrate_link_packages <- function(packages, library, project) {

  if (renv_path_same(library, renv_paths_library(project = project)))
    printf("- Linking packages into the project library ... ")
  else
    printf("- Linking packages into %s ... ", renv_path_pretty(library))

  callback <- renv_progress_callback(renv_hydrate_link_package, length(packages))
  cached <- enumerate(packages, callback, library = library)
  writef("Done!")
  cached

}

# takes a package called 'package' installed at location 'location',
# and copies it to the library 'library'
renv_hydrate_copy_package <- function(package, location, library) {
  target <- file.path(library, package)
  renv_file_copy(location, target, overwrite = TRUE)
}

renv_hydrate_copy_packages <- function(packages, library, project) {

  if (renv_path_same(library, renv_paths_library(project = project)))
    printf("- Copying packages into the project library ... ")
  else
    printf("- Copying packages into %s ... ", renv_path_pretty(library))

  callback <- renv_progress_callback(renv_hydrate_copy_package, length(packages))
  copied <- enumerate(packages, callback, library = library)
  writef("Done!")
  copied
}

renv_hydrate_resolve_missing <- function(project, library, na) {

  # 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
  #
  # 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))
    return()

  writef("- Resolving missing dependencies ... ")

  # define a custom error handler for packages which we cannot retrieve
  errors <- stack()
  handler <- function(package, action) {
    error <- catch(action)
    if (inherits(error, "error"))
      errors$push(list(package = package, error = error))
  }

  # perform the restore
  renv_scope_restore(
    project  = project,
    library  = library,
    packages = packages,
    handler  = handler
  )

  records <- retrieve(packages)
  renv_install_impl(records)

  # if we failed to restore anything, warn the user
  data <- errors$data()
  if (empty(data))
    return()

  if (renv_verbose()) {

    text <- map_chr(data, function(item) {
      package <- item$package
      message <- conditionMessage(item$error)
      short <- trunc(paste(message, collapse = ";"), 60L)
      sprintf("[%s]: %s", package, short)
    })

    caution_bullets(
      "The following package(s) were not installed successfully:",
      text,
      "You may need to manually download and install these packages."
    )

  }

  invisible(data)

}

renv_hydrate_report <- function(packages, na, linkable) {

  if (renv_bootstrap_tests_running())
    return()

  if (length(packages)) {

    # this is mostly a hacky way to get a list of records that the existing
    # record pretty-printer can handle in a clean way
    records <- enumerate(packages, function(package, library) {
      descpath <- file.path(library, "DESCRIPTION")
      record <- renv_snapshot_description(descpath)
      record$Repository <- NULL
      record$Source <- renv_path_aliased(dirname(library))
      record
    })

    preamble <- "The following packages were discovered:"
    postamble <- sprintf(
      "They will be %s into the project library.",
      if (linkable) "linked" else "copied"
    )

    formatter <- function(lhs, rhs) {
      renv_record_format_short(rhs, versioned = TRUE)
    }

    renv_pretty_print_records_pair(
      preamble = preamble,
      old = list(),
      new = records,
      postamble = postamble,
      formatter = formatter
    )

  }

  if (length(na)) {
    caution_bullets(
      "The following packages are used in this project, but not available locally:",
      csort(names(na)),
      "renv will attempt to download and install these packages."
    )
  }

}


# id.R -----------------------------------------------------------------------


renv_id_path <- function(project) {
  file.path(project, "renv/project-id")
}

renv_id_generate <- function() {

  methods <- list(
    renv_id_generate_r,
    renv_id_generate_kernel,
    renv_id_generate_uuidgen,
    renv_id_generate_cscript,
    renv_id_generate_powershell,
    renv_id_generate_csc
  )

  for (method in methods) {
    id <- catch(method())
    if (is.character(id) && length(id) == 1 && nzchar(id)) {
      id <- toupper(id)
      return(id)
    }
  }

  stop("could not generate project id for this system")

}

renv_id_generate_kernel <- function() {

  uuidpath <- "/proc/sys/kernel/random/uuid"
  if (!file.exists(uuidpath)) {
    fmt <- "%s does not exist on this operating system"
    stopf(fmt, renv_path_pretty(uuidpath))
  }

  readLines(uuidpath, n = 1L, warn = FALSE)

}

renv_id_generate_uuidgen <- function() {

  if (!nzchar(Sys.which("uuidgen"))) {
    fmt <- "program %s does not exist on this system"
    stopf(fmt, shQuote("uuidgen"))
  }

  system("uuidgen", intern = TRUE)

}

renv_id_generate_cscript <- function() {

  if (!renv_platform_windows()) {
    fmt <- "this method is only available on Windows"
    stopf(fmt)
  }

  if (!nzchar(Sys.which("cscript.exe"))) {
    fmt <- "could not find cscript.exe"
    stopf(fmt)
  }

  # create temporary directory
  dir <- renv_scope_tempfile("renv-id-")
  dir.create(dir)

  # move to it
  renv_scope_wd(dir)

  # write helper script
  script <- c(
    "set object = CreateObject(\"Scriptlet.TypeLib\")",
    "WScript.StdOut.WriteLine object.GUID"
  )

  # invoke it
  writeLines(script, con = "uuid.vbs")
  args <- c("//NoLogo", "uuid.vbs")
  id <- renv_system_exec("cscript.exe", args, "generating UUID")

  # remove braces
  gsub("(?:^\\{|\\}$)", "", id)

}

renv_id_generate_powershell <- function() {

  if (!renv_platform_windows()) {
    fmt <- "this method is only available on Windows"
    stopf(fmt)
  }

  if (!nzchar(Sys.which("powershell.exe"))) {
    fmt <- "could not find powershell.exe"
    stopf(fmt)
  }

  command <- "[guid]::NewGuid().ToString()"
  args <- c("-Command", shQuote(command))
  renv_system_exec("powershell.exe", args, "generating UUID")

}

renv_id_generate_r <- function() {

  if ("uuid" %in% loadedNamespaces())
    return(uuid::UUIDgenerate())

  libpaths <- c(
    .libPaths(),
    renv_libpaths_user(),
    renv_libpaths_site(),
    renv_libpaths_system()
  )

  if (!requireNamespace("uuid", lib.loc = libpaths, quietly = TRUE))
    stop("could not load package 'uuid'")

  id <- uuid::UUIDgenerate()
  catchall(unloadNamespace("uuid"))
  id

}

renv_id_generate_csc <- function() {

  csc <- local({

    csc <- Sys.which("csc.exe")
    if (nzchar(csc))
      return(csc)

    frameworks <- file.path(
      Sys.getenv("SYSTEMDRIVE", unset = "C:"),
      "Windows/Microsoft.NET",
      c("Framework", "Framework64")
    )

    versions <- list.files(frameworks, full.names = TRUE)
    candidates <- file.path(versions, "csc.exe")
    candidates[file.exists(candidates)]

  })

  if (empty(csc) || !file.exists(csc))
    stop("could not find csc.exe")


  code <- "
class GenerateUUID {
  static void Main(string[] args) {
    System.Console.WriteLine(System.Guid.NewGuid().ToString());
  }
}
"

  renv_scope_tempdir("renv-uuid-")
  writeLines(code, con = "program.cs")

  renv_system_exec(
    csc[[1]],
    c("/nologo", "/out:program.exe", "program.cs"),
    "compiling uuid helper"
  )

  renv_system_exec("program.exe", character(), "generating uuid")

}


# imbue.R --------------------------------------------------------------------


#' Imbue an renv Installation
#'
#' Imbue an renv installation into a project, thereby making the requested
#' version of renv available within.
#'
#' Normally, this function does not need to be called directly by the user; it
#' will be invoked as required by [init()] and [activate()].
#'
#' @inherit renv-params
#'
#' @param version The version of renv to install. If `NULL`, the version
#'   of renv currently installed will be used. The requested version of
#'   renv will be retrieved from the renv public GitHub repository,
#'   at <https://github.com/rstudio/renv>.
#'
#' @param quiet Boolean; avoid printing output during install of renv?
#'
imbue <- function(project = NULL,
                  version = NULL,
                  quiet   = FALSE)
{
  renv_scope_error_handler()
  project <- renv_project_resolve(project)

  renv_scope_options(renv.verbose = !quiet)

  vtext <- version %||% renv_metadata_version()
  writef("Installing renv [%s] ...", vtext)
  status <- renv_imbue_impl(project, version)
  writef("- Done! renv has been successfully installed.")

  invisible(status)

}

renv_imbue_impl <- function(project,
                            library = NULL,
                            version = NULL,
                            force = FALSE)
{
  # don't imbue during tests unless explicitly requested
  if (renv_tests_running() && !force)
    return(NULL)

  # resolve library path
  library <- library %||% renv_paths_library(project = project)
  ensure_directory(library)

  # NULL version means imbue this version of renv
  if (is.null(version))
    return(renv_imbue_self(project, library = library))

  # otherwise, try to download and install the requested version
  # of renv from GitHub
  remote <- paste("rstudio/renv", version %||% "main", sep = "@")
  record <- renv_remotes_resolve(remote)
  records <- list(renv = record)

  renv_scope_restore(
    project = project,
    library = library,
    records = records,
    packages = "renv",
    recursive = FALSE
  )

  records <- retrieve("renv")
  renv_install_impl(records)

  record <- records[["renv"]]
  invisible(record)
}

renv_imbue_self <- function(project,
                            library = NULL,
                            source = NULL)
{
  # construct source, target paths
  # (check if 'renv' is loaded to handle embedded case)
  source <- source %||% {
    if ("renv" %in% loadedNamespaces()) {
      renv_namespace_path("renv")
    } else {
      renv_package_find("renv")
    }
  }

  if (!file.exists(source))
    stop("internal error: could not find where 'renv' is installed")

  library <- library %||% renv_paths_library(project = project)
  target <- file.path(library, "renv")
  if (renv_file_same(source, target))
    return(TRUE)

  type <- renv_package_type(source, quiet = TRUE)
  case(
    type == "source" ~ renv_imbue_self_source(source, target),
    type == "binary" ~ renv_imbue_self_binary(source, target)
  )

}

renv_imbue_self_source <- function(source, target) {

  # if the package already exists, just skip
  if (file.exists(target))
    return(TRUE)

  # otherwise, install it
  library <- dirname(target)
  ensure_directory(library)
  r_cmd_install("renv", source, library)

}

renv_imbue_self_binary <- function(source, target) {
  ensure_parent_directory(target)
  renv_file_copy(source, target, overwrite = TRUE)
}


# imports.R ------------------------------------------------------------------


#' @importFrom tools
#'   file_ext pskill psnice write_PACKAGES
#'
#' @importFrom utils
#'   adist available.packages browseURL citation contrib.url download.file
#'   download.packages file.edit getCRANmirrors head help install.packages
#'   installed.packages modifyList old.packages packageDescription
#'   packageVersion read.table remove.packages Rprof sessionInfo summaryRprof
#'   str tail tar toBibtex untar update.packages unzip URLencode zip
NULL


# index.R --------------------------------------------------------------------


the$index <- new.env(parent = emptyenv())

index <- function(scope, key = NULL, value = NULL, limit = 3600L) {

  enabled <- renv_index_enabled(scope, key)
  if (!enabled)
    return(value)

  # resolve the root directory
  root <- renv_paths_index(scope)

  # make sure the directory we're indexing exists
  memoize(
    key   = root,
    value = ensure_directory(root, umask = "0")
  )

  # make sure the directory is readable / writable
  # otherwise, attempts to lock will fail
  # https://github.com/rstudio/renv/issues/1171
  if (!renv_index_writable(root))
    return(value)

  # resolve other variables
  key <- if (!is.null(key)) renv_index_encode(key)
  now <- as.integer(Sys.time())

  # acquire index lock
  lockfile <- file.path(root, "index.lock")
  renv_scope_lock(lockfile)

  # load the index file
  index <- tryCatch(renv_index_load(root, scope), error = identity)
  if (inherits(index, "error"))
    return(value)

  # return index as-is when key is NULL
  if (is.null(key))
    return(index)

  # check for an index entry, and return it if it exists
  item <- renv_index_get(root, scope, index, key, now, limit)
  if (!is.null(item))
    return(item)

  # otherwise, update the index
  renv_index_set(root, scope, index, key, value, now, limit)

}

renv_index_load <- function(root, scope) {

  filebacked(
    context  = "renv_index_load",
    path     = file.path(root, "index.json"),
    callback = renv_index_load_impl
  )

}

renv_index_load_impl <- function(path) {

  json <- tryCatch(
    withCallingHandlers(
      renv_json_read(path),
      warning = function(w) invokeRestart("muffleWarning")
    ),
    error = identity
  )

  if (inherits(json, "error")) {
    unlink(path)
    return(list())
  }

  json

}

renv_index_get <- function(root, scope, index, key, now, limit) {

  # check for index entry
  entry <- index[[key]]
  if (is.null(entry))
    return(NULL)

  # see if it's expired
  if (renv_index_expired(entry, now, limit))
    return(NULL)

  # check for in-memory cached value
  value <- the$index[[scope]][[key]]
  if (!is.null(value))
    return(value)

  # otherwise, try to read from disk
  data <- file.path(root, entry$data)
  if (!file.exists(data))
    return(NULL)

  # read data from disk
  value <- readRDS(data)

  # add to in-memory cache
  the$index[[scope]] <-
    the$index[[scope]] %||%
    new.env(parent = emptyenv())

  the$index[[scope]][[key]] <- value

  # return value
  value

}

renv_index_set <- function(root, scope, index, key, value, now, limit) {

  # force promises
  force(value)

  # files being written here should be shared
  renv_scope_umask("0")

  # write data into index
  data <- tempfile("data-", tmpdir = root, fileext = ".rds")
  ensure_parent_directory(data)
  saveRDS(value, file = data, version = 2L)

  # clean up stale entries
  index <- renv_index_clean(root, scope, index, now, limit)

  # add index entry
  index[[key]] <- list(time = now, data = basename(data))

  # update index file
  path <- file.path(root, "index.json")
  ensure_parent_directory(path)

  # write to tempfile and then copy to minimize risk of collisions
  tempfile <- tempfile(".index-", tmpdir = dirname(path), fileext = ".json")
  renv_json_write(index, file = tempfile)
  file.rename(tempfile, path)

  # return value
  value

}

renv_index_encode <- function(key) {
  key <- stringify(key)
  memoize(key, renv_hash_text(key))
}

renv_index_clean <- function(root, scope, index, now, limit) {

  # figure out what cache entries have expired
  ok <- enum_lgl(
    index,
    renv_index_clean_impl,
    root  = root,
    scope = scope,
    index = index,
    now   = now,
    limit = limit
  )

  # return the existing cache entries
  index[ok]

}

renv_index_clean_impl <- function(key, entry, root, scope, index, now, limit) {

  # check if cache entry has expired
  expired <- renv_index_expired(entry, now, limit)
  if (!expired)
    return(TRUE)

  # remove from in-memory cache
  cache <- the$index[[scope]]
  cache[[key]] <- NULL

  # remove from disk
  unlink(file.path(root, entry$data), force = TRUE)

  FALSE

}

renv_index_expired <- function(entry, now, limit) {
  now - entry$time >= limit
}

renv_index_enabled <- function(scope, key) {
  getOption("renv.index.enabled", default = TRUE)
}

renv_index_writable <- function(root) {
  memoize(
    key   = root,
    value = unname(file.access(root, 7L) == 0L)
  )
}

# in case of emergency, break glass
renv_index_reset <- function(root = NULL) {
  root <- root %||% renv_paths_index()
  lockfiles <- list.files(root, pattern = "^index\\.lock$", full.names = TRUE)
  unlink(lockfiles)
}


# infrastructure.R -----------------------------------------------------------


# tools for writing / removing renv-related infrastructure
renv_infrastructure_write <- function(project = NULL,
                                      profile = NULL,
                                      version = NULL)
{
  # don't do anything in embedded mode
  if (renv_metadata_embedded())
    return()

  project <- renv_project_resolve(project)

  renv_infrastructure_write_profile(project, profile = profile)
  renv_infrastructure_write_rprofile(project)
  renv_infrastructure_write_rbuildignore(project)
  renv_infrastructure_write_gitignore(project)
  renv_infrastructure_write_activate(project, version = version)
}

renv_infrastructure_write_profile <- function(project, profile = NULL) {

  path <- renv_paths_renv("profile", profile = FALSE, project = project)
  profile <- renv_profile_normalize(profile)
  if (is.null(profile))
    return(unlink(path))

  ensure_parent_directory(path)
  writeLines(profile, con = path)

}

renv_infrastructure_write_rprofile <- function(project) {

  if (!config$autoloader.enabled())
    return()

  # NOTE: intentionally leave project NULL to compute relative path
  path <- renv_paths_activate(project = NULL)
  add <- sprintf("source(%s)", renv_json_quote(path))

  renv_infrastructure_write_entry_impl(
    add    = add,
    remove = character(),
    file   = file.path(project, ".Rprofile"),
    create = TRUE
  )

}

renv_infrastructure_write_rbuildignore <- function(project) {

  lines <- c("^renv$", "^renv\\.lock$")

  if (file.exists(file.path(project, "requirements.txt")))
    lines <- c(lines, "^requirements\\.txt$")

  if (file.exists(file.path(project, "environment.yml")))
    lines <- c(lines, "^environment\\.yml$")

  renv_infrastructure_write_entry_impl(
    add    = lines,
    remove = character(),
    file   = file.path(project, ".Rbuildignore"),
    create = renv_project_type(project) == "package"
  )

}

renv_infrastructure_write_gitignore <- function(project) {

  if (!settings$vcs.manage.ignores())
    return()

  add    <- stack(mode = "character")
  remove <- stack(mode = "character")

  stk <- if (settings$vcs.ignore.library()) add else remove
  stk$push("library/")

  stk <- if (settings$vcs.ignore.local()) add else remove
  stk$push("local/")

  stk <- if (settings$vcs.ignore.cellar()) add else remove
  stk$push("cellar/")

  add$push("lock/", "python/", "sandbox/", "staging/")

  renv_infrastructure_write_entry_impl(
    add    = as.character(add$data()),
    remove = as.character(remove$data()),
    file   = renv_paths_renv(".gitignore", project = project),
    create = TRUE
  )

}

renv_infrastructure_write_activate <- function(project = NULL,
                                               version = NULL,
                                               create  = TRUE)
{
  project <- renv_project_resolve(project)
  version <- version %||% renv_activate_version(project)
  sha <- attr(version, "sha", exact = TRUE)

  source <- system.file("resources/activate.R", package = "renv")
  target <- renv_paths_activate(project = project)

  if (!create && !file.exists(target))
    return(FALSE)

  template <- renv_file_read(source)
  new <- renv_template_replace(
    text = template,
    replacements = list(
      version = stringify(as.character(version)),
      sha = stringify(sha)
    ),
    format = "..%s.."
  )

  if (file.exists(target)) {
    old <- renv_file_read(target)
    if (old == new)
      return(TRUE)
  }

  ensure_parent_directory(target)
  writeLines(new, con = target)
}


renv_infrastructure_write_entry_impl <- function(add, remove, file, create) {

  # check to see if file doesn't exist
  if (!file.exists(file)) {

    # if we're not forcing file creation, just bail
    if (!create)
      return(TRUE)

    # otherwise, write the file
    ensure_parent_directory(file)
    writeLines(add, con = file)
    return(TRUE)

  }

  # if the file already has the requested line, nothing to do
  before <- readLines(file, warn = FALSE)
  after <- before

  # add requested entries
  for (item in rev(add)) {

    # check to see if the requested line exists (either commented
    # or uncommented). if it exists, we'll attempt to uncomment
    # any commented lines
    cpattern <- sprintf("^\\s*#?\\s*\\Q%s\\E\\s*(?:#|\\s*$)", item)
    matches <- grepl(cpattern, after, perl = TRUE)
    if (any(matches))
      after[matches] <- gsub("^(\\s*)#\\s*", "\\1", after[matches])
    else
      after <- c(item, after)

  }

  # remove requested entries
  for (item in rev(remove)) {
    pattern <- sprintf("^\\s*\\Q%s\\E\\s*(?:#|\\s*$)", item)
    matches <- grepl(pattern, after, perl = TRUE)
    if (any(matches)) {
      replacement <- gsub("^(\\s*)", "\\1# ", after[matches], perl = TRUE)
      after[matches] <- replacement
    }
  }

  # write to file if we have changes
  if (!identical(before, after))
    writeLines(after, con = file)

  TRUE

}



renv_infrastructure_remove <- function(project = NULL) {
  project <- renv_project_resolve(project)

  renv_infrastructure_remove_rprofile(project)
  renv_infrastructure_remove_rbuildignore(project)

  unlink(file.path(project, "renv"), recursive = TRUE)
}


renv_infrastructure_remove_rprofile <- function(project) {

  # NOTE: intentionally leave project NULL to compute relative path
  path <- renv_paths_activate(project = NULL)
  line <- sprintf("source(%s)", renv_json_quote(path))

  renv_infrastructure_remove_entry_impl(
    line      = line,
    file      = file.path(project, ".Rprofile"),
    removable = TRUE
  )

}

renv_infrastructure_remove_rbuildignore <- function(project) {

  renv_infrastructure_remove_entry_impl(
    line      = "^renv$",
    file      = file.path(project, ".Rbuildignore"),
    removable = FALSE
  )

}

renv_infrastructure_remove_entry_impl <- function(line, file, removable) {

  # if the file doesn't exist, nothing to do
  if (!file.exists(file))
    return(TRUE)

  # find and comment out the line
  contents <- readLines(file, warn = FALSE)
  pattern <- sprintf("^\\s*\\Q%s\\E\\s*(?:#|\\s*$)", line)
  matches <- grepl(pattern, contents, perl = TRUE)

  # if this file is removable, check to see if we matched all non-blank
  # lines; if so, remove the file
  if (removable) {
    rest <- contents[!matches]
    if (all(grepl("^\\s*$", rest)))
      return(unlink(file))
  }

  # otherwise, just mutate the file
  replacement <- gsub("^(\\s*)", "\\1# ", contents[matches], perl = TRUE)
  contents[matches] <- replacement
  writeLines(contents, con = file)

  TRUE

}




# init.R ---------------------------------------------------------------------


the$init_running <- FALSE

#' Use renv in a project
#'
#' @description
#' Call `renv::init()` to start using renv in the current project. This will:
#'
#' 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.
#'
#' 1. Discover the packages that are currently being used in your project 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()]).
#'
#' 1. Restarts 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.
#'
#' # Repositories
#'
#' If the default \R repositories have not already been set, renv will use
#' the [Posit Public Package Manager](https://packagemanager.posit.co/) CRAN
#' mirror for package installation. The primary benefit to using this mirror is
#' that it can provide pre-built binaries for \R packages on a variety of
#' commonly-used Linux distributions. This behavior can be configured or
#' disabled if desired -- see the options in [renv::config()] for more details.
#'
#' @inherit renv-params
#'
#' @param project The project directory. When `NULL` (the default), the current
#'   working directory will be used. The \R working directory will be
#'   changed to match the requested project directory.
#'
#' @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 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()`.
#'
#' @param repos The \R repositories to be used in this project.
#'   See **Repositories** for more details.
#'
#' @param bioconductor The version of Bioconductor to be used with this project.
#'   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.
#'
#' @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.
#'
#' @export
#'
#' @example examples/examples-init.R
init <- function(project = NULL,
                 ...,
                 profile      = NULL,
                 settings     = NULL,
                 bare         = FALSE,
                 force        = FALSE,
                 repos        = NULL,
                 bioconductor = NULL,
                 load         = TRUE,
                 restart      = interactive())
{
  renv_consent_check()
  renv_scope_error_handler()
  renv_dots_check(...)

  renv_scope_binding(the, "init_running", TRUE)

  project <- renv_path_normalize(project %||% getwd())
  renv_project_lock(project = project)

  # initialize profile
  if (!is.null(profile))
    renv_profile_set(profile)

  # normalize repos
  repos <- renv_repos_normalize(repos %||% renv_init_repos())

  # form path to lockfile, library
  library  <- renv_paths_library(project = project)
  lockfile <- renv_lockfile_path(project)

  # ask user what type of project this is
  type <- settings$snapshot.type %||% renv_init_type(project)
  settings$snapshot.type <- type

  # initialize bioconductor pieces
  biocver <- renv_init_bioconductor(bioconductor, project)
  if (!is.null(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)

    # notify user
    writef("- Using Bioconductor version '%s'.", biocver)
    settings[["bioconductor.version"]] <- biocver

  }

  # prepare and move into project directory
  renv_init_validate_project(project, force)
  renv_init_settings(project, settings)

  # for bare inits, just activate the project
  if (bare) {
    renv_imbue_impl(project)
    return(renv_init_fini(project, profile, load, restart))
  }

  # compute and cache dependencies to (a) reveal problems early and (b) compute once
  deps <- renv_snapshot_dependencies(project, type = type, dev = TRUE)

  # determine appropriate action
  action <- renv_init_action(project, library, lockfile, bioconductor)
  cancel_if(empty(action) || identical(action, "cancel"))

  # compute library paths for this project
  libpaths <- renv_init_libpaths(project = project)

  # perform the action
  if (action == "init") {
    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)
  } else if (action == "restore") {
    ensure_directory(library)
    restore(project = project, library = libpaths, repos = repos, prompt = FALSE)
  }

  # activate the newly-hydrated project
  renv_init_fini(project, profile, load, restart)

}

renv_init_fini <- function(project, profile, load, restart) {

  renv_activate_impl(
    project = project,
    profile = profile,
    version = renv_metadata_version(),
    load    = load,
    restart = restart
  )

  invisible(project)

}

renv_init_action <- function(project, library, lockfile, bioconductor) {

  # if the user has asked for bioconductor, treat this as a re-initialization
  if (!is.null(bioconductor))
    return("init")

  # figure out appropriate action
  case(

    # if both the library and lockfile exist, ask user for intended action
    file.exists(lockfile)
      ~ renv_init_action_conflict_lockfile(project, library, lockfile),

    # if a private library exists but no lockfile, ask whether we should use it
    file.exists(library)
      ~ renv_init_action_conflict_library(project, library, lockfile),

    # otherwise, we just want to initialize the project
    ~ "init"

  )

}

renv_init_action_conflict_lockfile <- function(project, library, lockfile) {

  if (!interactive())
    return("nothing")

  title <- "This project already has a lockfile. What would you like to do?"
  choices <- c(
    restore = "Restore the project from the lockfile.",
    init    = "Discard the lockfile and re-initialize the project.",
    nothing = "Activate the project without snapshotting or installing any packages.",
    cancel  = "Abort project initialization."
  )

  selection <- tryCatch(
    utils::select.list(choices, title = title, graphics = FALSE),
    interrupt = identity
  )

  if (inherits(selection, "interrupt"))
    return(NULL)

  names(selection)

}

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,
  # 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"))
    return("init")

  title <- "This project already has a private library. What would you like to do?"
  choices <- c(
    nothing = "Activate the project and use the existing library.",
    init    = "Re-initialize the project with a new library.",
    cancel  = "Abort project initialization."
  )

  selection <- tryCatch(
    utils::select.list(choices, title = title, graphics = FALSE),
    interrupt = identity
  )

  if (inherits(selection, "interrupt"))
    return(NULL)

  names(selection)

}

renv_init_validate_project <- function(project, force) {

  # allow all project directories when force = TRUE
  if (force)
    return(TRUE)

  # disallow attempts to initialize renv in the home directory
  home <- path.expand("~/")
  msg <- if (renv_file_same(project, home))
    "refusing to initialize project in home directory"
  else if (renv_path_within(home, project))
    sprintf("refusing to initialize project in directory '%s'", project)

  if (!is.null(msg)) {
    msg <- paste(msg, "-- use renv::init(force = TRUE) to override")
    stopf(msg)
  }

}

renv_init_settings <- function(project, settings) {

  defaults <- renv_settings_get(project)
  merged <- renv_settings_merge(defaults, settings)
  renv_settings_persist(project, merged)
  invisible(merged)

}

renv_init_bioconductor <- function(bioconductor, project) {

  # if we're re-initializing a project that appears to depend
  # on Bioconductor, then use the latest Bioconductor release
  if (is.null(bioconductor)) {
    lockpath <- renv_paths_lockfile(project = project)
    if (file.exists(lockpath)) {
      lockfile <- renv_lockfile_read(lockpath)
      bioconductor <- !is.null(lockfile$Bioconductor)
    }
  }

  # resolve bioconductor argument
  case(
    is.character(bioconductor)     ~ bioconductor,
    identical(bioconductor, TRUE)  ~ renv_bioconductor_version(project, refresh = TRUE),
    identical(bioconductor, FALSE) ~ NULL
  )

}

renv_init_repos <- function() {

  # if PPM is disabled, just use default repositories
  repos <- convert(getOption("repos"), "list")
  if (!renv_ppm_enabled())
    return(repos)

  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@"))) {
    repos[["CRAN"]] <- config$ppm.url()
    return(repos)
  }

  # repos appears to have been configured separately; just use it
  repos

}

renv_init_type <- function(project) {

  # check if the user has already requested a snapshot type
  type <- renv_settings_get(project, name = "snapshot.type", default = NULL)
  if (!is.null(type))
    return(type)

  # if we don't have a DESCRIPTION file, use the default
  if (!file.exists(file.path(project, "DESCRIPTION")))
    return(settings$snapshot.type(project = project))

  # otherwise, ask the user if they want to explicitly enumerate their
  # R package dependencies in the DESCRIPTION file
  choice <- menu(

    title = c(
      "This project contains a DESCRIPTION file.",
      "Which files should renv use for dependency discovery in this project?"
    ),

    choices = c(
      explicit = "Use only the DESCRIPTION file. (explicit mode)",
      implicit = "Use all files in this project. (implicit mode)"
    )

  )

  if (identical(choice, "cancel"))
    cancel()

  writef("- Using '%s' snapshot type. Please see `?renv::snapshot` for more details.\n", choice)
  choice

}


# install.R ------------------------------------------------------------------


# an explicitly-requested package type in a call to 'install()'
the$install_pkg_type <- NULL

# an explicitly-requested dependencies field in a call to 'install()'
the$install_dependency_fields <- NULL

# the formatted width of installation steps printed to the console
the$install_step_width <- 48L

#' Install packages
#'
#' @description
#' Install one or more \R packages, from a variety of remote sources.
#' `install()` uses the same machinery as [restore()] (i.e. it uses cached
#' packages where possible) but it does not respect the lockfile, instead
#' installing the latest versions available from CRAN.
#'
#' See `vignette("package-install")` for more details.
#'
#' # `Remotes`
#'
#' `install()` (called without arguments) will respect the `Remotes` field
#' of the `DESCRIPTION` file (if present). This allows you to specify places
#' to install a package other than the latest version from CRAN.
#' See <https://remotes.r-lib.org/articles/dependencies.html> for details.
#'
#' # Bioconductor
#'
#' Packages from Bioconductor can be installed by using the `bioc::` prefix.
#' For example,
#'
#' ```
#' renv::install("bioc::Biobase")
#' ```
#'
#' will install the latest-available version of Biobase from Bioconductor.
#'
#' renv depends on BiocManager (or, for older versions of \R, BiocInstaller)
#' for the installation of packages from Bioconductor. If these packages are
#' not available, renv will attempt to automatically install them before
#' fulfilling the installation request.
#'
#' @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 <https://remotes.r-lib.org/articles/dependencies.html> 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 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.
#'
#' @return A named list of package records which were installed by renv.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # install the latest version of 'digest'
#' renv::install("digest")
#'
#' # install an old version of 'digest' (using archives)
#' renv::install("digest@@0.6.18")
#'
#' # install 'digest' from GitHub (latest dev. version)
#' renv::install("eddelbuettel/digest")
#'
#' # install a package from GitHub, using specific commit
#' renv::install("eddelbuettel/digest@@df55b00bff33e945246eff2586717452e635032f")
#'
#' # install a package from Bioconductor
#' # (note: requires the BiocManager package)
#' renv::install("bioc::Biobase")
#'
#' # install a package, specifying path explicitly
#' renv::install("~/path/to/package")
#'
#' # install packages as declared in the project DESCRIPTION file
#' renv::install()
#'
#' }
install <- function(packages = NULL,
                    ...,
                    exclude      = NULL,
                    library      = NULL,
                    type         = NULL,
                    rebuild      = FALSE,
                    repos        = NULL,
                    prompt       = interactive(),
                    dependencies = NULL,
                    project      = NULL)
{
  renv_consent_check()
  renv_scope_error_handler()

  # 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))])
  }

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_scope_verbose_if(prompt)

  # handle 'dependencies'
  if (!is.null(dependencies)) {
    fields <- renv_description_dependency_fields(dependencies, project = project)
    renv_scope_binding(the, "install_dependency_fields", fields)
  }

  # set up library paths
  libpaths <- renv_libpaths_resolve(library)
  renv_scope_libpaths(libpaths)

  # 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)
  }

  # override repositories if requested
  repos <- repos %||% config$repos.override()
  if (length(repos))
    renv_scope_options(repos = repos)

  # 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))
  }

  # resolve remotes from explicitly-requested packages
  remotes <- if (length(packages)) {
    remotes <- map(packages, renv_remotes_resolve)
    names(remotes) <- map_chr(remotes, `[[`, "Package")
    remotes
  }

  # figure out which packages we should install
  packages <- names(remotes) %||% renv_snapshot_dependencies(project, dev = TRUE)

  # apply exclude parameter
  if (length(exclude))
    packages <- setdiff(packages, exclude)

  if (empty(packages)) {
    writef("- There are no packages to install.")
    return(invisible(list()))
  }

  # add bioconductor packages if necessary
  if (renv_bioconductor_required(remotes)) {
    bioc <- c(renv_bioconductor_manager(), "BiocVersion")
    packages <- unique(c(packages, bioc))
  }

  # don't update renv unless it was explicitly requested
  if (!"renv" %in% names(remotes))
    packages <- setdiff(packages, "renv")

  # start building a list of records; they should be resolved this priority:
  #
  # 1. explicit requests from the user
  # 2. remotes declarations from the DESCRIPTION file
  # 3. existing version in library, if any
  # 4. fallback to package repositories
  #
  # we overlay 1 and 2 here, and then do 3 and 4 dynamically if required
  # during the retrieve + install stages
  records <- overlay(renv_project_remotes(project), remotes)

  # run install preflight checks
  if (!renv_install_preflight(project, libpaths, records))
    cancel_if(prompt && !proceed())

  # we're now ready to start installation
  renv_scope_restore(
    project  = project,
    library  = renv_libpaths_active(),
    packages = names(remotes),
    records  = records,
    rebuild  = rebuild
  )

  # retrieve packages
  records <- retrieve(packages)
  if (empty(records)) {
    writef("- There are no packages to install.")
    return(invisible(list()))
  }

  if (prompt || renv_verbose()) {
    renv_install_report(records, library = renv_libpaths_active())
    cancel_if(prompt && !proceed())
  }

  # install retrieved records
  before <- Sys.time()
  renv_install_impl(records)
  after <- Sys.time()

  time <- renv_difftime_format(difftime(after, before))
  n <- length(records)
  writef("Successfully installed %s in %s.", nplural("package", n), time)

  # check loaded packages and inform user if out-of-sync
  renv_install_postamble(names(records))

  invisible(records)
}

renv_install_impl <- function(records) {

  staged <- renv_config_install_staged()

  writef(header("Installing packages"))

  if (staged)
    renv_install_staged(records)
  else
    renv_install_default(records)

  invisible(TRUE)

}

renv_install_staged <- function(records) {

  # get current libpaths
  libpaths <- renv_libpaths_all()

  # set up a dummy library path for installation
  templib <- renv_install_staged_library_path()
  defer(unlink(templib, recursive = TRUE))
  renv_scope_libpaths(c(templib, libpaths))

  # perform the install
  renv_install_default(records)

  # migrate packages into true library
  library <- nth(libpaths, 1L)
  sources <- list.files(templib, full.names = TRUE)
  targets <- file.path(library, basename(sources))
  names(targets) <- sources
  enumerate(targets, renv_file_move, overwrite = TRUE)

  # clear filebacked cache entries
  descpaths <- file.path(targets, "DESCRIPTION")
  renv_filebacked_clear("renv_description_read", descpaths)
  renv_filebacked_clear("renv_hash_description", descpaths)

  invisible(targets)

}

renv_install_staged_library_path_impl <- function() {

  # get current library path
  libpath <- renv_libpaths_active()

  # retrieve current project, library path
  stagedlib <- local({

    # allow user configuration of staged library location
    override <- Sys.getenv("RENV_PATHS_LIBRARY_STAGING", unset = NA)
    if (!is.na(override))
      return(override)

    # if we have an active project, use that path
    project <- renv_project_get(default = NULL)
    if (!is.null(project))
      return(renv_paths_renv("staging", project = project))

    # otherwise, stage within library path
    file.path(libpath, ".renv")

  })

  # attempt to create it
  ok <- catch(ensure_directory(stagedlib))
  if (inherits(ok, "error"))
    return(tempfile("renv-staging-"))

  # resolve a unique staging directory in this path
  # we want to keep paths short just in case; it's easy to blow up the
  # path length limit (hence we don't use tempfile below)
  for (i in 1:100) {
    path <- file.path(stagedlib, i)
    if (dir.create(path, showWarnings = FALSE))
      return(path)
  }

  # all else fails, use tempfile
  tempfile("renv-staging-")

}

# NOTE: on Windows, installing packages into very long paths
# can fail, as R's internal unzip utility does not handle
# long Windows paths well. in addition, an renv project's
# library path tends to be long, exasperating the issue.
# for that reason, we try to use a shorter staging directory
#
# part of the challenge here is that the R temporary directory
# and R library path might reside on different mounts, and so
# we may want to try and avoid installing on one mount and then
# copying to another mount (as that could be slow).
#
# note that using the renv folder might be counter-productive,
# since users will want to use renv in projects sync'ed via
# OneDrive and friends, and we don't want those to lock files
# in the staging directory
renv_install_staged_library_path <- function() {

  # compute path
  path <- renv_install_staged_library_path_impl()

  # create library directory
  ensure_directory(path)

  # try to make sure it has the same permissions as the library itself
  if (!renv_platform_windows()) {
    libpath <- renv_libpaths_active()
    umask <- Sys.umask("0")
    defer(Sys.umask(umask))
    info <- renv_file_info(libpath)
    Sys.chmod(path, info$mode)
  }

  # return the created path
  return(path)

}

renv_install_default <- function(records) {
  state <- renv_restore_state()
  handler <- state$handler

  for (record in records) {
    package <- record$Package
    handler(package, renv_install_package(record))
  }
}

renv_install_package <- function(record) {

  # get active project (if any)
  state <- renv_restore_state()
  project <- state$project

  # figure out whether we can use the cache during install
  # use library path recorded in restore state as staged installs will have
  # mutated the library path, placing a staging library at the front
  library <- renv_restore_state("library")
  linkable <- renv_cache_linkable(project = project, library = library)
  linker <- if (linkable) renv_file_link else renv_file_copy

  cacheable <-
    renv_cache_config_enabled(project = project) &&
    renv_record_cacheable(record) &&
    !renv_restore_rebuild_required(record)

  if (cacheable) {

    # check for cache entry and install if there
    path <- renv_cache_find(record)
    if (renv_cache_package_validate(path))
      return(renv_install_package_cache(record, path, linker))

  }

  # install the package
  before <- Sys.time()
  withCallingHandlers(
    renv_install_package_impl(record),
    error = function(e) writef("FAILED")
  )
  after <- Sys.time()

  path <- record$Path
  type <- renv_package_type(path, quiet = TRUE)
  feedback <- renv_install_package_feedback(path, type)


  # link into cache
  if (renv_cache_config_enabled(project = project)) {
    renv_cache_synchronize(record, linkable = linkable)
    feedback <- paste0(feedback, " and cached")
  }

  elapsed <- difftime(after, before, units = "auto")
  renv_install_step_ok(feedback, elapsed = elapsed)

  invisible()

}

renv_install_package_feedback <- function(path, type) {

  if (identical(type, "source"))
    return("built from source")

  if (renv_file_type(path, symlinks = FALSE) == "directory")
    return("copied local binary")

  "installed binary"

}

renv_install_package_cache <- function(record, cache, linker) {

  if (renv_install_package_cache_skip(record, cache))
    return(TRUE)

  library <- renv_libpaths_active()
  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)

  before <- Sys.time()
  linker(cache, target)
  after <- Sys.time()

  type <- case(
    identical(linker, renv_file_copy) ~ "copied from cache",
    identical(linker, renv_file_link) ~ "linked from cache"
  )

  elapsed <- difftime(after, before, units = "auto")
  renv_install_step_ok(type, elapsed = elapsed)

  return(TRUE)

}

renv_install_package_cache_skip <- function(record, cache) {

  # don't skip if installation was explicitly requested
  if (record$Package %in% renv_restore_state("packages"))
    return(FALSE)

  # check for matching cache + target paths
  library <- renv_restore_state("library") %||% renv_libpaths_active()
  target <- file.path(library, record$Package)

  renv_file_same(cache, target)

}

renv_install_package_impl_prebuild <- function(record, path, quiet) {

  # check whether user wants us to build before install
  if (!identical(config$install.build(), TRUE))
    return(path)

  # if this package already appears to be built, nothing to do
  if (renv_package_built(path))
    return(path)

  # if this is an archive, we'll need to unpack it first
  info <- renv_file_info(path)
  if (identical(info$isdir, FALSE)) {

    # find the package directory
    files <- renv_archive_list(path)
    descpath <- grep("(?:^|/)DESCRIPTION$", files, value = TRUE)
    pkgpath <- dirname(descpath)[nchar(descpath) == min(nchar(descpath))]

    # extract to temporary directory
    exdir <- tempfile("renv-build-")
    ensure_directory(exdir)
    renv_archive_decompress(path, exdir = exdir)

    # update path to package
    path <- file.path(exdir, pkgpath)

    # and ensure we build in this directory
    renv_scope_wd(path)

  }

  # if this package depends on a VignetteBuilder that is not installed,
  # then we can't proceed
  descpath <- file.path(path, "DESCRIPTION")
  desc <- renv_description_read(descpath)
  builder <- desc[["VignetteBuilder"]]
  if (!is.null(builder) && !renv_package_installed(builder)) {
    fmt <- "Skipping package build: vignette builder '%s' is not installed"
    writef(fmt, builder)
    return(path)
  }

  renv_install_step_start("Building", record$Package)

  before <- Sys.time()
  package <- record$Package
  newpath <- r_cmd_build(package, path)
  after <- Sys.time()
  elapsed <- difftime(after, before, units = "auto")

  renv_install_step_ok("from source", elapsed = elapsed)

  newpath

}

renv_install_package_impl <- function(record, quiet = TRUE) {

  package <- record$Package

  # get path for package
  path <- record$Path

  # check if it's an archive (versus an unpacked directory)
  info <- renv_file_info(path)
  isarchive <- identical(info$isdir, FALSE)

  subdir <- record$RemoteSubdir %||% ""
  if (isarchive) {
    # re-pack archives if they appear to have their package
    # sources contained as part of a sub-directory
    path <- renv_package_unpack(package, path, subdir = subdir)
  } else if (nzchar(subdir)) {
    # for directories, we may need to use subdir to find the package path
    components <- c(path, subdir)
    path <- paste(components, collapse = "/")
  }

  # check whether we should build before install
  path <- renv_install_package_impl_prebuild(record, path, quiet)
  renv_install_step_start("Installing", record$Package)

  # run user-defined hooks before, after install
  options <- renv_install_package_options(package)
  before <- options$before.install %||% identity
  after  <- options$after.install %||% identity

  before(package)
  defer(after(package))

  # backup an existing installation of the package if it exists
  library <- renv_libpaths_active()
  destination <- file.path(library, package)
  callback <- renv_file_backup(destination)
  defer(callback())

  # normalize paths
  path <- renv_path_normalize(path, mustWork = TRUE)

  # get library path
  library <- renv_libpaths_active()

  # if a package already exists at that path, back it up first
  # this avoids problems with older versions of R attempting to
  # overwrite a pre-existing symlink
  #
  # https://github.com/rstudio/renv/issues/611
  installpath <- file.path(library, package)
  callback <- renv_file_backup(installpath)
  defer(callback())

  # if this failed for some reason, just remove it
  if (renv_file_broken(installpath))
    renv_file_remove(installpath)

  # if this is the path to an unpacked binary archive,
  # we can just copy the folder over
  isdir <- renv_file_type(path, symlinks = FALSE) == "directory"
  isbin <- renv_package_type(path, quiet = TRUE) == "binary"
  copyable <- isdir && isbin

  # shortcut via copying a binary directory if possible,
  # otherwise, install the package
  if (copyable)
    renv_file_copy(path, installpath, overwrite = TRUE)
  else
    r_cmd_install(package, path)

  # if we just installed a binary package, check that it can be loaded
  # (source packages are checked by default on install)
  withCallingHandlers(
    if (isbin) renv_install_test(package),
    error = function(err) unlink(installpath, recursive = TRUE)
  )

  # augment package metadata after install
  renv_package_augment(installpath, record)

  # return the path to the package
  invisible(installpath)

}

renv_install_test <- function(package) {

  # add escape hatch, just in case
  # (test binaries by default on Linux, but not Windows or macOS)
  enabled <- Sys.getenv("RENV_INSTALL_TEST_LOAD", unset = renv_platform_linux())
  if (!truthy(enabled))
    return(TRUE)

  # check whether we should skip installation testing
  opts <- r_cmd_install_option(package, c("install.opts", "INSTALL_opts"), FALSE)
  if (is.character(opts)) {
    flags <- unlist(strsplit(opts, "\\s+", perl = TRUE))
    if ("--no-test-load" %in% flags)
      return(TRUE)
  }

  # make sure we use the current library paths in the launched process
  rlibs <- paste(renv_libpaths_all(), collapse = .Platform$path.sep)
  renv_scope_envvars(R_LIBS = rlibs, R_LIBS_USER = "NULL", R_LIBS_SITE = "NULL")

  # also hide from user .Renviron files
  # https://github.com/wch/r-source/blob/1c0a2dc8ce6c05f68e1959ffbe6318a309277df3/src/library/tools/R/check.R#L273-L276
  renv_scope_envvars(R_ENVIRON_USER = "NULL")

  # make sure R_TESTS is unset here, just in case
  # https://github.com/wch/r-source/blob/1c0a2dc8ce6c05f68e1959ffbe6318a309277df3/src/library/tools/R/install.R#L76-L79
  renv_scope_envvars(R_TESTS = NULL)

  # the actual code we'll run in the other process
  # 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({
    options(warn = 1L)
    loadNamespace(package)
  }, list(package = package))

  # write it to a tempfile
  script <- renv_scope_tempfile("renv-install-", fileext = ".R")
  writeLines(deparse(code), con = script)

  # check that the package can be loaded in a separate process
  renv_system_exec(
    command = R(),
    args    = c("--vanilla", "-s", "-f", renv_shell_path(script)),
    action  = sprintf("testing if '%s' can be loaded", package)
  )

  # return TRUE to indicate successful validation
  TRUE

}

renv_install_package_options <- function(package) {
  options <- getOption("renv.install.package.options")
  options[[package]]
}

# nocov start
renv_install_preflight_requirements <- function(records) {

  deps <- bapply(records, function(record) {
    renv_dependencies_discover_description(record$Path)
  }, index = "ParentPackage")

  splat <- split(deps, deps$Package)
  bad <- enumerate(splat, function(package, requirements) {

    # skip NULL records (should be handled above)
    record <- records[[package]]
    if (is.null(record))
      return(NULL)

    version <- record$Version

    # drop packages without explicit version requirement
    requirements <- requirements[nzchar(requirements$Require), ]
    if (nrow(requirements) == 0)
      return(NULL)

    # add in requested version
    requirements$RequestedVersion <- version

    # generate expressions to evaluate
    fmt <- "package_version('%s') %s package_version('%s')"
    code <- with(requirements, sprintf(fmt, RequestedVersion, Require, Version))
    parsed <- parse(text = code)
    ok <- map_lgl(parsed, eval, envir = baseenv())

    # return requirements that weren't satisfied
    requirements[!ok, ]

  })

  bad <- bind(unname(bad))
  if (empty(bad))
    return(TRUE)

  package  <- bad$ParentPackage
  requires <- sprintf("%s (%s %s)", bad$Package, bad$Require, bad$Version)
  actual   <- sprintf("%s %s", bad$Package, bad$RequestedVersion)

  fmt <- "Package '%s' requires '%s', but '%s' will be installed"
  text <- sprintf(fmt, format(package), format(requires), format(actual))
  if (renv_verbose()) {
    caution_bullets(
      "The following issues were discovered while preparing for installation:",
      text,
      "Installation of these packages may not succeed."
    )
  }

  if (interactive() && !proceed())
    return(FALSE)

  TRUE

}
# nocov end

renv_install_postamble <- function(packages) {

  # only diagnose packages currently loaded
  packages <- renv_vector_intersect(packages, loadedNamespaces())

  installed <- map_chr(packages, renv_package_version)
  loaded <- map_chr(packages, renv_namespace_version)

  caution_bullets(
    c("", "The following loaded package(s) have been updated:"),
    packages[installed != loaded],
    "Restart your R session to use the new versions."
  )

  TRUE

}

renv_install_preflight_unknown_source <- function(records) {
  renv_check_unknown_source(records)
}

renv_install_preflight_permissions <- function(library) {

  # try creating and deleting a directory in the library folder
  file <- renv_scope_tempfile(".renv-write-test-", tmpdir = library)
  dir.create(file, recursive = TRUE, showWarnings = FALSE)

  # check if we created the directory successfully
  info <- renv_file_info(file)
  if (identical(info$isdir, TRUE))
    return(TRUE)

  # nocov start
  if (renv_verbose()) {

    # construct header for message
    preamble <- "renv appears to be unable to access the requested library path:"

    # construct footer for message
    info <- as.list(Sys.info())
    fmt <- "Check that the '%s' user has read / write access to this directory."
    postamble <- sprintf(fmt, info$effective_user %||% info$user)

    # print it
    caution_bullets(
      preamble = preamble,
      values = library,
      postamble = postamble
    )

  }
  # nocov end

  FALSE

}

renv_install_preflight <- function(project, libpaths, records) {

  library <- nth(libpaths, 1L)

  all(
    renv_install_preflight_unknown_source(records),
    renv_install_preflight_permissions(library)
  )

}

renv_install_report <- function(records, library) {
  renv_pretty_print_records(
    "The following package(s) will be installed:",
    records,
    sprintf("These packages will be installed into %s.", renv_path_pretty(library))
  )
}

renv_install_step_start <- function(action, package) {
  message <- sprintf("- %s %s ... ", action, package)
  printf(format(message, width = the$install_step_width))
}

renv_install_step_ok <- function(..., elapsed = NULL) {
  renv_report_ok(
    message = paste(..., collapse = ""),
    elapsed = elapsed
  )
}


# installed-packages.R -------------------------------------------------------


installed_packages <- function(lib.loc = NULL,
                               priority = NULL,
                               field = NULL)
{
  lib.loc <- lib.loc %||% .libPaths()

  result <- dynamic(
    key = list(lib.loc = lib.loc, priority = priority),
    value = {
      packages <- installed.packages(lib.loc = lib.loc, priority = priority)
      as_data_frame(packages)
    }
  )

  take(result, field)

}


# isolate.R ------------------------------------------------------------------


#' Isolate a project
#'
#' Copy packages from the renv cache directly into the project library, so
#' that the project can continue to function independently of the renv cache.
#'
#' After calling `isolate()`, renv will still be able to use the cache on
#' future [install()]s and [restore()]s. If you'd prefer that renv copy
#' packages from the cache, rather than use symlinks, you can set the renv
#' configuration option:
#'
#' ```
#' options(renv.config.cache.symlinks = FALSE)
#' ```
#'
#' to force renv to copy packages from the cache, as opposed to symlinking
#' them. If you'd like to disable the cache altogether for a project, you can
#' use:
#'
#' ```
#' settings$use.cache(FALSE)
#' ```
#'
#' to explicitly disable the cache for the project.
#'
#' @inherit renv-params
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # isolate a project
#' renv::isolate()
#'
#' }
isolate <- function(project = NULL) {

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  if (renv_platform_windows())
    renv_isolate_windows(project)
  else
    renv_isolate_unix(project)

  invisible(project)

}

renv_isolate_unix <- function(project) {

  library <- renv_paths_library(project = project)
  targets <- list.files(library, full.names = TRUE)

  sources <- Sys.readlink(targets)
  islink <- !is.na(sources) & nzchar(sources)

  sources <- sources[islink]
  targets <- targets[islink]
  names(targets) <- sources

  if (length(targets)) {
    printf("- Copying packages into the private library ... ")
    unlink(targets)
    copy <- renv_progress_callback(renv_file_copy, length(targets))
    enumerate(targets, copy, overwrite = TRUE)
    writef("Done!")
  }

  writef("- This project has been isolated from the cache.")
  invisible(project)

}

renv_isolate_windows <- function(project) {

  library <- renv_paths_library(project = project)
  targets <- list.files(library, full.names = TRUE)

  sources <- map_chr(targets, renv_cache_path)
  names(targets) <- sources

  if (length(targets)) {
    printf("- Copying packages into the private library ... ")
    targets <- targets[file.exists(sources)]
    unlink(targets)
    copy <- renv_progress_callback(renv_file_copy, length(targets))
    enumerate(targets, copy, overwrite = TRUE)
    writef("Done!")
  }

  writef("- This project has been isolated from the cache.")
  invisible(project)

}


# json-read.R ----------------------------------------------------------------


renv_json_read <- function(file = NULL, text = NULL) {

  jlerr <- NULL

  # if jsonlite is loaded, use that instead
  if ("jsonlite" %in% loadedNamespaces()) {

    json <- catch(renv_json_read_jsonlite(file, text))
    if (!inherits(json, "error"))
      return(json)

    jlerr <- json

  }

  # otherwise, fall back to the default JSON reader
  json <- catch(renv_json_read_default(file, text))
  if (!inherits(json, "error"))
    return(json)

  # report an error
  if (!is.null(jlerr))
    stop(jlerr)
  else
    stop(json)

}

renv_json_read_jsonlite <- function(file = NULL, text = NULL) {
  text <- paste(text %||% read(file), collapse = "\n")
  jsonlite::fromJSON(txt = text, simplifyVector = FALSE)
}

renv_json_read_default <- function(file = NULL, text = NULL) {

  # find strings in the JSON
  text <- paste(text %||% read(file), collapse = "\n")
  pattern <- '["](?:(?:\\\\.)|(?:[^"\\\\]))*?["]'
  locs <- gregexpr(pattern, text, perl = TRUE)[[1]]

  # if any are found, replace them with placeholders
  replaced <- text
  strings <- character()
  replacements <- character()

  if (!identical(c(locs), -1L)) {

    # get the string values
    starts <- locs
    ends <- locs + attr(locs, "match.length") - 1L
    strings <- substring(text, starts, ends)

    # only keep those requiring escaping
    strings <- grep("[[\\]{}:]", strings, perl = TRUE, value = TRUE)

    # 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)

  }

  # 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")

  # parse it
  json <- parse(text = text, keep.source = FALSE, srcfile = NULL)[[1L]]

  # construct map between source strings, replaced strings
  map <- as.character(parse(text = strings))
  names(map) <- as.character(parse(text = replacements))

  # convert to list
  map <- as.list(map)

  # remap strings in object
  remapped <- renv_json_remap(json, map)

  # evaluate
  eval(remapped, envir = baseenv())

}

renv_json_remap <- function(json, map) {

  # 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]
  }

  # fix values
  if (is.character(json))
    return(map[[json]] %||% json)

  # 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))
    }
  }

  json

}


# json-write.R ---------------------------------------------------------------


# @param box A vector of names, whose values should be boxed. By default,
#   scalar values are unboxed.
renv_json_config <- function(box = character()) {
  list(box = box)
}

renv_json_write <- function(object,
                            config = NULL,
                            file = stdout())
{
  config <- config %||% renv_json_config()
  json <- renv_json_convert_impl(NULL, object, config, 0L)
  if (is.null(file))
    return(json)

  writeLines(json, con = file)

}

renv_json_convert <- function(object, config = renv_json_config()) {
  renv_json_convert_impl(NULL, object, config, 0L)
}

renv_json_convert_impl <- function(key, value, config, depth) {

  if (is.list(value) || !is.null(names(value)))
    return(renv_json_convert_list(key, value, config, depth))

  json <- renv_json_convert_atom(key, value, config, depth)
  indent <- renv_json_convert_indent(depth)
  paste0(indent, json)

}

renv_json_convert_list <- function(key, value, config, depth) {
  indent <- renv_json_convert_indent(depth)
  if (empty(value)) {
    json <- if (is.null(names(value))) "[]" else "{}"
    paste0(indent, json)
  } else if (is.null(names(value))) {
    json <- enum_chr(value, renv_json_convert_impl, config = config, depth = depth + 1L)
    paste0(indent, "[", "\n", paste(json, collapse = ",\n"), "\n", indent, "]")
  } else {
    keys <- renv_json_quote(names(value))
    vals <- enum_chr(value, renv_json_convert_impl, config = config, depth = depth + 1L)
    idx  <- regexpr("[^[:space:]]", vals)
    json <- paste0(substring(vals, 1L, idx - 1L), keys, ": ", substring(vals, idx))
    paste0(indent, "{", "\n", paste(json, collapse = ",\n"), "\n", indent, "}")
  }
}

renv_json_convert_atom <- function(key, value, config, depth) {

  unbox <- is.null(key) || !key %in% config$box || inherits(value, "AsIs")
  if (is.null(value))
    return(if (unbox) "null" else "[]")

  n <- length(value)
  if (n == 0L)
    return("[]")

  if (is.character(value)) {
    value <- renv_json_quote(value)
    value[value %in% c("NA")] <- "null"
  }

  if (is.logical(value)) {
    value <- ifelse(value, "true", "false")
    value[is.na(value)] <- "null"
  }

  if (unbox && n == 1L)
    return(if (is.na(value)) "null" else paste0(value))

  indent <- renv_json_convert_indent(depth)
  json <- paste0(renv_json_convert_indent(depth + 1L), value)
  paste0("[", "\n", paste(json, collapse = ",\n"), "\n", indent, "]")

}

renv_json_convert_indent <- function(level) {
  paste(rep("  ", level), collapse = "")
}


# json.R ---------------------------------------------------------------------


renv_json_quote <- function(text) {
  encodeString(text, quote = "\"", justify = "none")
}


# knitr.R --------------------------------------------------------------------


renv_knitr_options_header <- function(text, type) {

  # extract the inner options from the header
  patterns <- renv_knitr_patterns()
  rest <- sub(patterns[[type]]$chunk.begin, "\\1", text)

  # if this is an R Markdown document, parse the initial engine chunk
  # (default to 'r' when not set)
  engine <- "r"
  if (type == "md") {
    idx <- regexpr("(?:[ ,]|$)", rest)
    engine <- substring(rest, 1, idx - 1)
    rest <- sub("^,*\\s*", "", substring(rest, idx + 1))
  }

  # parse the params
  params <- renv_knitr_options_header_impl(rest)

  # ensure an engine is set, if any
  params[["engine"]] <- params[["engine"]] %||% engine

  # return parsed params
  params

}

renv_knitr_options_header_impl <- function(rest) {

  # extract an unquoted label
  label <- ""
  pattern <- "(^\\s*[^=]+)(,|\\s*$)"
  matches <- regexec(pattern, rest)[[1]]
  if (!identical(c(matches), -1L)) {
    submatches <- regmatches(rest, list(matches))[[1]]
    label <- trimws(submatches[[2L]])
    rest <- substring(rest, matches[[3L]] + 1L)
  }

  # parse as alist
  params <- catch(parse(text = sprintf("alist(%s)", rest))[[1]])
  if (inherits(params, "error"))
    return(list())

  # inject the label back in
  names(params) <- names(params) %||% rep.int("", length(params))
  if (length(params) > 1 && names(params)[[2L]] == "")
    names(params)[[2L]] <- "label"

  # fix up 'label' if it's a missing value
  if (identical(params[["label"]], quote(expr = )))
    params[["label"]] <- NULL

  # if we parsed a label, add it in
  if (is.null(params[["label"]]) && nzchar(label))
    params[["label"]] <- label

  # evaluate the alist
  eval(params, envir = parent.frame())

}

renv_knitr_options_chunk <- function(code) {

  # find chunk option lines
  pattern <- "^[[:space:]]*#+[|]"
  matches <- grep(pattern, code[nzchar(code)], value = TRUE)

  # remove prefix
  text <- gsub(pattern, "", matches)

  # try to guess whether it's YAML
  isyaml <- any(grepl("^[[:space:]]*[^[:space:]:]+:", text))

  # first, try to parse as YAML, then as R code
  params <- if (isyaml) {

    # validate that we actually have the yaml package available
    if (!renv_dependencies_require("yaml"))
      return(list())

    catch(renv_yaml_load(text))

  } else {
    code <- paste(text, collapse = ", ")
    catch(renv_knitr_options_header_impl(code))
  }

  # check for error and report if this is in dependency discovery
  if (inherits(params, "error")) {

    state <- renv_dependencies_state()
    if (!is.null(state)) {
      problem <- list(file = state$path %||% "<unknown>", error = params)
      state$problems$push(problem)
    }

    return(list())

  }

  # return parsed params
  params

}

renv_knitr_patterns <- function() {

  list(

    rnw = list(
      chunk.begin = "^\\s*<<(.*)>>=.*$",
      chunk.end = "^\\s*@\\s*(%+.*|)$",
      inline.code = "\\\\Sexpr\\{([^}]+)\\}",
      inline.comment = "^\\s*%.*",
      ref.chunk = "^\\s*<<(.+)>>\\s*$",
      header.begin = "(^|\n)\\s*\\\\documentclass[^}]+\\}",
      document.begin = "\\s*\\\\begin\\{document\\}"
    ),

    tex = list(
      chunk.begin = "^\\s*%+\\s*begin.rcode\\s*(.*)",
      chunk.end = "^\\s*%+\\s*end.rcode",
      chunk.code = "^\\s*%+",
      ref.chunk = "^%+\\s*<<(.+)>>\\s*$",
      inline.comment = "^\\s*%.*",
      inline.code = "\\\\rinline\\{([^}]+)\\}",
      header.begin = "(^|\n)\\s*\\\\documentclass[^}]+\\}",
      document.begin = "\\s*\\\\begin\\{document\\}"
    ),

    html = list(
      chunk.begin = "^\\s*<!--\\s*begin.rcode\\s*(.*)",
      chunk.end = "^\\s*end.rcode\\s*-->",
      ref.chunk = "^\\s*<<(.+)>>\\s*$",
      inline.code = "<!--\\s*rinline(.+?)-->",
      header.begin = "\\s*<head>"
    ),

    md = list(
      chunk.begin = "^[\t >]*```+\\s*\\{([a-zA-Z0-9_]+( *[ ,].*)?)\\}\\s*$",
      chunk.end = "^[\t >]*```+\\s*$",
      ref.chunk = "^\\s*<<(.+)>>\\s*$",
      inline.code = "(?<!(^|\n)``)`r[ #]([^`]+)\\s*`"
    ),

    rst = list(
      chunk.begin = "^\\s*[.][.]\\s+\\{r(.*)\\}\\s*$",
      chunk.end = "^\\s*[.][.]\\s+[.][.]\\s*$",
      chunk.code = "^\\s*[.][.]",
      ref.chunk = "^\\.*\\s*<<(.+)>>\\s*$",
      inline.code = ":r:`([^`]+)`"
    ),

    asciidoc = list(
      chunk.begin = "^//\\s*begin[.]rcode(.*)$",
      chunk.end = "^//\\s*end[.]rcode\\s*$",
      chunk.code = "^//+",
      ref.chunk = "^\\s*<<(.+)>>\\s*$",
      inline.code = "`r +([^`]+)\\s*`|[+]r +([^+]+)\\s*[+]",
      inline.comment = "^//.*"
    ),

    textile = list(
      chunk.begin = "^###[.]\\s+begin[.]rcode(.*)$",
      chunk.end = "^###[.]\\s+end[.]rcode\\s*$",
      ref.chunk = "^\\s*<<(.+)>>\\s*$",
      inline.code = "@r +([^@]+)\\s*@",
      inline.comment = "^###[.].*"
    )

  )

}


# l10n.R ---------------------------------------------------------------------


renv_l10n_mbcs <- function() {
  info <- l10n_info()
  info$MBCS
}

renv_l10n_utf8 <- function() {
  info <- l10n_info()
  info$`UTF-8`
}

renv_l10n_latin1 <- function() {
  info <- l10n_info()
  info$`Latin-1`
}


# libpaths.R -----------------------------------------------------------------


the$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)
}

renv_libpaths_active <- function() {
  .libPaths()[[1L]]
}

renv_libpaths_all <- function() {
  .libPaths()
}

renv_libpaths_system <- function() {
  get(".Library", envir = the$libpaths)
}

renv_libpaths_site <- function() {
  get(".Library.site", envir = the$libpaths)
}

renv_libpaths_external <- function(project) {
  projlib <- settings$external.libraries(project = project)
  conflib <- config$external.libraries(project)
  .expand_R_libs_env_var(c(projlib, conflib))
}

# on Windows, attempting to use a library path containing
# characters considered special by cmd.exe will fail.
# to guard against this, we try to create a junction point
# from the temporary directory to the target library path
#
# https://github.com/rstudio/renv/issues/334
renv_libpaths_safe <- function(libpaths) {

  if (renv_libpaths_safe_check(libpaths))
    return(libpaths)

  map_chr(libpaths, renv_libpaths_safe_impl)

}

renv_libpaths_safe_check <- function(libpaths) {

  # if any of the paths have single quotes,
  # then we need to use a safe path
  # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17973
  if (any(grepl("'", libpaths, fixed = TRUE)))
    return(FALSE)

  # on Windows, we need to use safe library paths for R < 4.0.0
  # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=17709
  if (renv_platform_windows() && getRversion() < "4.0.0")
    return(FALSE)

  # otherwise, we're okay
  return(TRUE)

}

renv_libpaths_safe_impl <- function(libpath) {

  # check for an unsafe library path
  unsafe <-
    Encoding(libpath) == "UTF-8" ||
    grepl("[&<>^|'\"]", libpath)

  # if the path appears safe, use it as-is
  if (!unsafe)
    return(libpath)

  # try to form a safe library path
  methods <- c(
    renv_libpaths_safe_tempdir,
    renv_libpaths_safe_userlib
  )

  for (method in methods) {
    safelib <- catchall(method(libpath))
    if (is.character(safelib))
      return(safelib)
  }

  # could not form a safe library path;
  # just use the existing library path as-is
  libpath

}

renv_libpaths_safe_tempdir <- function(libpath) {
  safelib <- tempfile("renv-safelib-")

  if (renv_platform_windows())
    renv_file_junction(libpath, safelib)
  else
    file.symlink(libpath, safelib)

  safelib
}

renv_libpaths_safe_userlib <- function(libpath) {

  # form path into user library
  userlib <- renv_libpaths_user()[[1]]
  base <- file.path(userlib, ".renv-links")
  ensure_directory(base)

  # create name for actual junction point
  name <- renv_hash_text(libpath)
  safelib <- file.path(base, name)

  # if the junction already exists, use it
  if (renv_file_same(libpath, safelib))
    return(safelib)

  # otherwise, try to create it. note that junction
  # points can be removed with a non-recursive unlink
  unlink(safelib)

  if (renv_platform_windows())
    renv_file_junction(libpath, safelib)
  else
    file.symlink(libpath, safelib)

  safelib

}

renv_libpaths_set <- function(libpaths) {
  oldlibpaths <- .libPaths()
  safepaths <- renv_libpaths_safe(libpaths)
  .libPaths(safepaths)
  oldlibpaths
}

renv_libpaths_default <- function() {
  the$libpaths$`.libPaths()`
}

# NOTE: may return more than one library path!
renv_libpaths_user <- function() {

  # if renv is active, the user library will be saved
  envvars <- c("RENV_DEFAULT_R_LIBS_USER", "R_LIBS_USER")
  for (envvar in envvars) {

    value <- Sys.getenv(envvar, unset = NA)
    if (is.na(value) || value %in% c("", "<NA>", "NULL"))
      next

    parts <- strsplit(value, .Platform$path.sep, fixed = TRUE)[[1L]]
    return(parts)

  }

  # otherwise, default to active library
  # (shouldn't happen but best be safe)
  renv_libpaths_active()

}

renv_init_libpaths <- function(project) {

  projlib <- renv_paths_library(project = project)
  extlib <- renv_libpaths_external(project = project)
  userlib <- if (config$user.library())
    renv_libpaths_user()

  libpaths <- c(projlib, extlib, userlib)
  lapply(libpaths, ensure_directory)

  libpaths

}

renv_libpaths_restore <- function() {
  libpaths <- get(".libPaths()", envir = the$libpaths)
  renv_libpaths_set(libpaths)
}

# We need to ensure the system library is included, for cases where users have
# provided an explicit 'library' argument in calls to functions like
# 'renv::restore(library = <...>)')
#
# https://github.com/rstudio/renv/issues/1544
renv_libpaths_resolve <- function(library = NULL) {

  if (is.null(library))
    return(renv_libpaths_all())

  unique(c(library, .Library))

}


# library.R ------------------------------------------------------------------


# check for problems in the project's private library (e.g. broken symlinks
# to the cache or similar)
renv_library_diagnose <- function(project, libpath) {

  children <- list.files(libpath, full.names = TRUE)
  if (empty(children))
    return(TRUE)

  # if all symlinks are broken, assume the cache is missing or has been moved
  missing <- !file.exists(children)
  if (all(missing)) {
    msg <- lines(
      "The project library's symlinks to the cache are all broken.",
      "Has the cache been removed, or is it otherwise inaccessible?",
      paste("Cache root:", shQuote(renv_paths_cache()[[1L]]))
    )
    warning(msg, call. = FALSE)
    return(FALSE)
  }

  # if only some symlinks are broken, report to user
  if (any(missing)) {

    caution_bullets(
      "The following package(s) are missing entries in the cache:",
      basename(children[missing]),
      "These packages will need to be reinstalled."
    )

    return(FALSE)

  }

  TRUE

}


# license.R ------------------------------------------------------------------


# used to generate the CRAN-compatible license file in R CMD build
renv_license_generate <- function() {

  # only done if we're building
  if (!building())
    return(FALSE)

  contents <- c(
    paste("YEAR:", format(Sys.Date(), "%Y")),
    "COPYRIGHT HOLDER: Posit Software, PBC"
  )

  writeLines(contents, con = "LICENSE")
  return(TRUE)

}

if (identical(.packageName, "renv"))
  renv_license_generate()



# load.R ---------------------------------------------------------------------


# are we currently running 'load()'?
the$load_running <- FALSE

#' Load a project
#'
#' @description
#' `renv::load()` sets the library paths to use a project-local library,
#' sets up the system library [sandbox], if needed, and creates shims
#' for `install.packages()`, `update.packages()`, and `remove.packages()`.
#'
#' You should not generally need to call `renv::load()` yourself, as it's
#' called automatically by the project auto-loader created by [renv::init()]/
#' [renv::activate()]. However, if needed, you can use `renv::load("<project>")`
#' to explicitly load an renv project located at a particular path.
#'
#' # Shims
#'
#' To help you take advantage of the package cache, renv places a couple of
#' shims on the search path:
#'
#' * `install.packages()` instead calls `renv::install()`.
#' * `remove.packages()` instead calls `renv::remove()`.
#' * `update.packages()` instead calls `renv::update()`.
#'
#' This allows you to keep using your existing muscle memory for installing,
#' updating, and remove packages, while taking advantage of renv features
#' like the package cache.
#'
#' If you'd like to bypass these shims within an \R session, you can explicitly
#' call the version of these functions from the utils package, e.g. with
#' `utils::install.packages(<...>)`.
#'
#' If you'd prefer not to use the renv shims at all, they can be disabled by
#' setting the R option `options(renv.config.shims.enabled = FALSE)` or by
#' setting the environment variable `RENV_CONFIG_SHIMS_ENABLED = FALSE`. See
#' `?config` for more details.
#'
#' @inherit renv-params
#'
#' @param quiet Boolean; be quiet during load?
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # load a project -- note that this is normally done automatically
#' # by the project's auto-loader, but calling this explicitly to
#' # load a particular project may be useful in some circumstances
#' renv::load()
#'
#' }
load <- function(project = NULL, quiet = FALSE) {

  renv_scope_error_handler()

  project <- renv_path_normalize(
    project %||% renv_project_find(project),
    mustWork = TRUE
  )

  action <- renv_load_action(project)
  if (action[[1L]] == "cancel") {
    cancel()
  } else if (action[[1L]] == "init") {
    return(init(project))
  } else if (action[[1L]] == "alt") {
    project <- action[[2L]]
  }

  renv_project_lock(project = project)

  # indicate that we're now loading the project
  renv_scope_binding(the, "load_running", TRUE)

  # 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))
    renv_project_clear()

  # if we're loading a project different from the one currently loaded,
  # then unload the current project and reload the requested one
  switch <-
    !renv_metadata_embedded() &&
    !is.null(the$project_path) &&
    !identical(project, the$project_path)

  if (switch)
    return(renv_load_switch(project))

  if (quiet || renv_load_quiet())
    renv_scope_options(renv.verbose = FALSE)

  renv_envvars_save()

  # load a minimal amount of state when testing
  if (renv_tests_running())
    return(renv_load_minimal(project))

  # load rest of renv components
  renv_load_init(project)
  renv_load_path(project)
  renv_load_shims(project)
  renv_load_renviron(project)
  renv_load_profile(project)
  renv_load_settings(project)
  renv_load_project(project)
  renv_load_sandbox(project)
  renv_load_libpaths(project)
  renv_load_rprofile(project)
  renv_load_cache(project)

  # load components encoded in lockfile
  lockfile <- renv_lockfile_load(project)
  if (length(lockfile)) {
    renv_load_r(project, lockfile$R)
    renv_load_python(project, lockfile$Python)
    renv_load_bioconductor(project, lockfile$Bioconductor)
  }

  # allow failure to write infrastructure here to be non-fatal
  # https://github.com/rstudio/renv/issues/574#issuecomment-731159197
  catch({
    renv_infrastructure_write_rbuildignore(project)
    renv_infrastructure_write_gitignore(project)
  })

  renv_load_finish(project, lockfile)

  invisible(project)
}

renv_load_action <- function(project) {

  # don't do anything in non-interactive sessions
  if (!interactive())
    return("load")

  # if this project already contains an 'renv' folder, assume it's
  # already been initialized and we can directly load it
  renv <- renv_paths_renv(project = project, profile = FALSE)
  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)
  })

  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")

  choices <- c(
    init    = "Initialize this project with `renv::init()`.",
    load    = "Continue loading this project as-is.",
    cancel  = "Cancel loading this project."
  )

  if (!is.null(path)) {
    fmt <- "Load the project located at %s instead."
    msg <- sprintf(fmt, renv_path_pretty(path))
    choices <- c(choices, alt = msg)
  }

  selection <- tryCatch(
    utils::select.list(choices, title = title, graphics = FALSE),
    interrupt = identity
  )

  if (inherits(selection, "interrupt")) {
    writef()
    selection <- choices["cancel"]
  }

  list(names(selection), path)

}

renv_load_minimal <- function(project) {

  renv_load_libpaths(project)

  lockfile <- renv_lockfile_load(project)
  if (length(lockfile)) {
    renv_load_r(project, lockfile$R)
    renv_load_python(project, lockfile$Python)
  }

  renv_load_finish(project, lockfile)
  invisible(project)

}

renv_load_r <- function(project, fields) {

  # check for missing fields
  if (is.null(fields)) {
    warning("missing required [R] section in lockfile")
    return(NULL)
  }

  # load repositories
  renv_load_r_repos(fields$Repositories)

  # load (check) version
  version <- fields$Version
  if (is.null(version)) {
    warning("no R version recorded in this lockfile")
    return(NULL)
  }

  # normalize versions as strings
  requested <- renv_version_maj_min(version)
  current <- renv_version_maj_min(getRversion())

  # only compare major, minor versions
  if (!identical(requested, current)) {
    fmt <- "%s Using R %s (lockfile was generated with R %s)"
    writef(fmt, info_bullet(), getRversion(), version)
  }

}

renv_load_r_repos <- function(repos) {

  # force a character vector (https://github.com/rstudio/renv/issues/127)
  repos <- convert(repos, "character")

  # remove trailing slashes
  nms <- names(repos)
  repos <- sub("/+$", "", repos)
  names(repos) <- nms

  # transform PPM URLs if enabled
  # this ensures that install.packages() uses binaries by default on Linux,
  # where 'getOption("pkgType")' is "source" by default
  if (renv_ppm_enabled())
    repos <- renv_ppm_transform(repos)

  # normalize option
  repos <- renv_repos_normalize(repos)

  # set sanitized repos
  options(repos = repos)

  # and return
  repos

}

renv_load_init <- function(project) {

  # warn if the project path cannot be translated into the native encoding,
  # as (especially on Windows) this will likely prevent renv from working
  actual <- enc2utf8(project)
  expected <- catch(enc2utf8(enc2native(actual)))
  if (identical(actual, expected))
    return(TRUE)

  msg <- paste(
    "the project path cannot be represented in the native encoding;",
    "renv may not function as expected"
  )

  warning(msg)

}

renv_load_path <- function(project) {

  # only required when running in RStudio
  if (!renv_rstudio_available())
    return(FALSE)

  # on macOS, read paths from /etc/paths and friends

  # nocov start
  if (renv_platform_macos()) {

    # read the current PATH
    old <- Sys.getenv("PATH", unset = "") %>%
      strsplit(split = .Platform$path.sep, fixed = TRUE) %>%
      unlist()

    # get the new PATH entries
    files <- c(
      if (file.exists("/etc/paths")) "/etc/paths",
      list.files("/etc/paths.d", full.names = TRUE)
    )

    new <- uapply(files, readLines, warn = FALSE)

    # mix them together, preferring things in /etc/paths
    mix <- unique(c(new, old))

    # update the PATH
    Sys.setenv(PATH = paste(mix, collapse = .Platform$path.sep))

  }
  # nocov end

}

renv_load_shims <- function(project) {
  if (renv_shims_enabled())
    renv_shims_activate()
}

renv_load_renviron <- function(project) {

  environs <- c(
    renv_paths_root(".Renviron"),
    if (config$user.environ())
      Sys.getenv("R_ENVIRON_USER", unset = "~/.Renviron"),
    file.path(project, ".Renviron")
  )

  for (environ in environs)
    if (file.exists(environ))
      readRenviron(environ)

  renv_envvars_normalize()

}

renv_load_profile <- function(project) {

  renv_bootstrap_profile_load(project = project)

}

renv_load_settings <- function(project) {

  # migrate settings.dcf => settings.json
  renv_settings_migrate(project = project)

  # load settings.R
  settings <- renv_paths_renv("settings.R", project = project)
  if (!file.exists(settings))
    return(FALSE)

  tryCatch(
    eval(parse(settings), envir = baseenv()),
    error = warnify
  )

  TRUE

}

renv_load_project <- function(project) {

  # update project list if enabled
  if (renv_cache_config_enabled(project = project)) {
    project <- renv_path_normalize(project)
    renv_load_project_projlist(project)
  }

  TRUE

}

renv_load_project_projlist <- function(project) {

  # read project list
  projects <- renv_paths_root("projects")
  projlist <- character()
  if (file.exists(projects))
    projlist <- readLines(projects, warn = FALSE, encoding = "UTF-8")

  # if the project is already recorded, nothing to do
  if (project %in% projlist)
    return(TRUE)

  # sort with C locale (ensure consistent sorting across OSes)
  projlist <- csort(c(projlist, project))

  # update the project list
  ensure_parent_directory(projects)
  catchall(writeLines(enc2utf8(projlist), con = projects, useBytes = TRUE))

  TRUE

}

renv_load_rprofile <- function(project = NULL) {

  project <- renv_project_resolve(project)

  # bail if not enabled by user
  enabled <- identical(config$user.profile(), TRUE)
  if (!enabled)
    return(FALSE)

  # callr will manage sourcing of user profile, so don't try
  # to source the user profile if we're in callr
  callr <- Sys.getenv("CALLR_CHILD_R_LIBS", unset = NA)
  if (!is.na(callr))
    return(FALSE)

  # check for existence of profile
  profile <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile")
  if (!file.exists(profile))
    return(FALSE)

  renv_scope_libpaths()
  renv_load_rprofile_impl(profile)

  TRUE

}

renv_load_rprofile_impl <- function(profile) {

  # NOTE: We'd like to use a regular tryCatch() handler here, but
  # that will cause issues for user profiles which attempt to add
  # global calling handlers. For that reason, we just register a
  # bare restart handler, so at least we can catch the jump.
  #
  # https://github.com/rstudio/renv/issues/1036
  status <- withRestarts(
    sys.source(profile, envir = globalenv()),
    abort = function() { structure(list(), class = "_renv_error") }
  )

  if (inherits(status, "_renv_error")) {
    fmt <- "an error occurred while sourcing %s"
    warningf(fmt, renv_path_pretty(profile))
  }

  FALSE

}

renv_load_libpaths <- function(project = NULL) {
  libpaths <- renv_init_libpaths(project)
  lapply(libpaths, renv_library_diagnose, project = project)
  Sys.setenv(R_LIBS_USER = paste(libpaths, collapse = .Platform$path.sep))
  renv_libpaths_set(libpaths)
}

renv_load_sandbox <- function(project) {
  renv_sandbox_activate(project)
}

renv_load_python <- function(project, fields) {

  python <- tryCatch(
    renv_load_python_impl(project, fields),
    error = function(e) {
      warning(e)
      NULL
    }
  )

  if (is.null(python))
    return(FALSE)

  # set environment variables
  # - RENV_PYTHON is the version of Python renv was configured to use
  # - RETICULATE_PYTHON used to configure version of Python used by reticulate
  Sys.setenv(
    RENV_PYTHON       = python,
    RETICULATE_PYTHON = python
  )

  # place python + relevant utilities on the PATH
  bindir <- normalizePath(dirname(python), 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
  if (renv_platform_windows()) {
    scriptsdir <- file.path(bindir, "Scripts")
    if (file.exists(scriptsdir))
      renv_envvar_path_add("PATH", scriptsdir)
  }

  # for conda environments, we should try to find conda and place the conda
  # executable on the PATH, in case users want to use conda e.g. from
  # the terminal or even via R system calls
  #
  # we'll also need to set some environment variables to ensure that conda
  # uses this environment by default
  info <- renv_python_info(python)
  if (identical(info$type, "conda")) {
    conda <- renv_conda_find(python)
    if (file.exists(conda)) {
      renv_envvar_path_add("PATH", dirname(conda))
      Sys.setenv(CONDA_PREFIX = info$root)
    }
  }

  TRUE

}

renv_load_python_impl <- function(project, fields) {

  # if RENV_PYTHON is already set, just use it
  python <- Sys.getenv("RENV_PYTHON", unset = NA)
  if (!is.na(python))
    return(python)

  # set a default reticulate Python environment path
  envpath <- renv_paths_renv("python/r-reticulate", project = project)
  Sys.setenv(RETICULATE_MINICONDA_PYTHON_ENVPATH = envpath)

  # nothing more to do if no lockfile fields set
  if (is.null(fields))
    return(NULL)

  # delegate based on type appropriately
  type <- fields$Type
  if (is.null(type))
    return(NULL)

  python <- switch(type,
    system     = renv_load_python_default(project, fields),
    virtualenv = renv_load_python_virtualenv(project, fields),
    conda      = renv_load_python_condaenv(project, fields),
    stopf("unrecognized Python type '%s'", type)
  )

  renv_path_canonicalize(python)

}

renv_load_python_default <- function(project, fields) {

  # if 'Name' points to a valid copy of Python, use it
  name <- fields$Name
  if (!is.null(name) && file.exists(name))
    return(name)

  # otherwise, try to find a compatible version of Python
  renv_python_find(fields$Version)

}

renv_load_python_virtualenv <- function(project, fields) {

  renv_use_python_virtualenv_impl(
    project = project,
    name    = fields[["Name"]]    %NA% NULL,
    version = fields[["Version"]] %NA% NULL,
    python  = fields[["Python"]]  %NA% NULL
  )

}

renv_load_python_condaenv <- function(project, fields) {

  renv_use_python_condaenv_impl(
    project = project,
    name    = fields[["Name"]]    %NA% NULL,
    version = fields[["Version"]] %NA% NULL,
    python  = fields[["Python"]]  %NA% NULL
  )

}

renv_load_bioconductor <- function(project, bioconductor) {

  # we don't try to support older R anymore
  if (getRversion() < "3.4")
    return()

  # if we don't have a valid Bioconductor version, bail
  version <- bioconductor$Version
  if (is.null(version))
    return()

  # initialize bioconductor
  renv_bioconductor_init()

  # validate version if necessary
  validate <- getOption("renv.bioconductor.validate")
  if (truthy(validate, default = TRUE))
    renv_load_bioconductor_validate(project, version)

  # update the R repositories
  repos <- renv_bioconductor_repos(project, version)
  options(repos = repos)

  # notify the user
  sprintf("- Using Bioconductor '%s'.", version)

}

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_load_switch <- function(project) {

  # skip when testing
  if (testing())
    return(project)

  # safety check: avoid recursive unload attempts
  unloading <- getOption("renv.unload.project")
  if (!is.null(unloading)) {
    fmt <- "ignoring recursive attempt to load project '%s'"
    warningf(fmt, renv_path_pretty(project))
    return(project)
  }

  # unset the RENV_PATHS_RENV environment variable
  # TODO: is there a path forward if different projects use
  # different RENV_PATHS_RENV paths?
  renvpath <- Sys.getenv("RENV_PATHS_RENV", unset = NA)
  Sys.unsetenv("RENV_PATHS_RENV")

  # validate that this project has an activate script
  script <- renv_paths_activate(project = project)
  if (!file.exists(script)) {
    fmt <- "project %s has no activate script and so cannot be activated"
    stopf(fmt, renv_path_pretty(project))
  }

  # signal that we're unloading now
  renv_scope_options(renv.unload.project = project)

  # perform the unload
  unload()

  # unload the current version of renv (but keep track of position
  # on search path in case we need to revert later)
  path <- renv_namespace_path("renv")
  pos <- match("package:renv", search())
  unloadNamespace("renv")

  # move to new project directory
  renv_scope_wd(project)

  # source the activate script
  source(script)

  # 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))
    loadNamespace("renv", lib.loc = dirname(path))
    Sys.setenv(RENV_PATHS_RENV = renvpath)
    if (!is.na(pos)) {
      args <- list(package = "renv", pos = pos, character.only = TRUE)
      do.call(base::library, args)
    }
  }

}

renv_load_cache <- function(project) {

  if (!interactive())
    return(FALSE)

  oldcache <- renv_paths_cache(version = renv_cache_version_previous())[[1L]]
  newcache <- renv_paths_cache(version = renv_cache_version())[[1L]]
  if (!file.exists(oldcache) || file.exists(newcache))
    return(FALSE)

  msg <- lines(
    "- The cache version has been updated in this version of renv.",
    "- Use `renv::rehash()` to migrate packages from the old renv cache."
  )
  printf(msg)

}

renv_load_check <- function(project) {
  renv_load_check_description(project)
}

renv_load_check_description <- function(project) {

  descpath <- file.path(project, "DESCRIPTION")
  if (!file.exists(descpath))
    return(TRUE)

  # read description file, with whitespace trimmed
  contents <- read(descpath) %>% trim() %>% chop()
  bad <- which(grepl("^\\s*$", contents, perl = TRUE))
  if (empty(bad))
    return(TRUE)

  values <- sprintf("[line %i is blank]", bad)

  caution_bullets(
    sprintf("%s contains blank lines:", renv_path_pretty(descpath)),
    values,
    c(
      "DESCRIPTION files cannot contain blank lines between fields.",
      "Please remove these blank lines from the file."
    )
  )

  return(FALSE)

}

renv_load_quiet <- function() {
  default <- identical(renv_verbose(), FALSE) || renv_session_quiet()
  config$startup.quiet(default = default)
}

renv_load_finish <- function(project = NULL, lockfile = NULL) {

  renv_project_set(project)

  renv_load_check(project)
  renv_load_report_project(project)
  renv_load_report_python(project)

  if (config$updates.check())
    renv_load_report_updates(project)

  if (config$synchronized.check())
    renv_load_report_synchronized(project, lockfile)

  renv_snapshot_auto_update(project = project)

}

renv_load_report_project <- function(project) {

  profile <- renv_profile_get()
  version <- renv_metadata_version_friendly(shafmt = "; sha: %s")

  if (!is.null(profile)) {
    fmt <- "- Project '%s' loaded. [renv %s; using profile '%s']"
    writef(fmt, renv_path_aliased(project), version, profile)
  } else {
    fmt <- "- Project '%s' loaded. [renv %s]"
    writef(fmt, renv_path_aliased(project), version)
  }

}

renv_load_report_python <- function(project) {
  # TODO
}

# nocov start
renv_load_report_updates <- function(project) {

  lockpath <- renv_lockfile_path(project = project)
  if (!file.exists(lockpath))
    return(FALSE)

  status <- update(project = project, check = TRUE)
  available <- inherits(status, "renv_updates") && length(status$diff)
  if (!available)
    return(FALSE)

  writef("- Use `renv::update()` to install updated packages.")
  if (!interactive())
    print(status)

  TRUE

}
# nocov end


renv_load_report_synchronized <- function(project = NULL, lockfile = NULL) {

  project  <- renv_project_resolve(project)
  lockfile <- lockfile %||% renv_lockfile_load(project)

  # signal that we're running synchronization checks
  renv_scope_binding(the, "project_synchronized_check_running", TRUE)

  # be quiet when checking for dependencies in this scope
  # https://github.com/rstudio/renv/issues/1181
  renv_scope_options(renv.config.dependency.errors = "ignored")

  # check for packages referenced in the lockfile which are not installed
  lockpkgs <- names(lockfile$Packages)
  libpkgs <- renv_snapshot_library(
    library = renv_libpaths_all(),
    project = project,
    records = FALSE
  )

  # ignore renv
  lockpkgs <- setdiff(lockpkgs, "renv")
  libpkgs <- setdiff(libpkgs, "renv")

  # check for case where no packages are installed (except renv)
  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 (!response)
      return(FALSE)

    restore(project, prompt = FALSE, exclude = "renv")
    return(TRUE)

  }

  # check for case where one or more packages are missing
  missing <- setdiff(lockpkgs, basename(libpkgs))
  if (length(missing)) {
    msg <- lines(
      "- One or more packages recorded in the lockfile are not installed.",
      "- Use `renv::status()` for more details."
    )
    caution(msg)
    return(FALSE)
  }

  # otherwise, use status to detect if we're synchronized
  info <- local({
    renv_scope_options(renv.verbose = FALSE)
    renv_scope_caution(FALSE)
    status(project = project, sources = FALSE)
  })

  if (!identical(info$synchronized, TRUE)) {
    caution("- The project is out-of-sync -- use `renv::status()` for details.")
    return(FALSE)
  }

  TRUE

}


# lock.R ---------------------------------------------------------------------


the$lock_registry <- new.env(parent = emptyenv())

renv_lock_acquire <- function(path) {

  # normalize path
  path <- renv_lock_path(path)
  dlog("lock", "%s [acquiring lock]", renv_path_pretty(path))

  # if we already have this lock, increment our counter
  count <- the$lock_registry[[path]] %||% 0L
  if (count > 0L) {
    the$lock_registry[[path]] <- count + 1L
    return(TRUE)
  }

  # make sure parent directory exists
  ensure_parent_directory(path)

  # make sure warnings are errors here
  renv_scope_options(warn = 2L)

  # loop until we acquire the lock
  repeat tryCatch(
    renv_lock_acquire_impl(path) && break,
    error = function(cnd) Sys.sleep(0.2)
  )

  # mark this path as locked by us
  the$lock_registry[[path]] <- 1L

  # notify the watchdog
  renv_watchdog_notify("LockAcquired", list(path = path))

  # TRUE to mark successful lock
  dlog("lock", "%s [lock acquired]", renv_path_pretty(path))
  TRUE

}

# https://rcrowley.org/2010/01/06/things-unix-can-do-atomically.html
renv_lock_acquire_impl <- function(path) {

  # check for orphaned locks
  if (renv_lock_orphaned(path)) {
    dlog("lock", "%s: removing orphaned lock", path)
    unlink(path, recursive = TRUE, force = TRUE)
  }

  # attempt to create the lock
  dir.create(path, mode = "0755")

}

renv_lock_release <- function(path) {

  # normalize path
  path <- renv_lock_path(path)

  # decrement our lock count
  count <- the$lock_registry[[path]] <- the$lock_registry[[path]] - 1L

  # remove the lock if we have no more locks
  if (count == 0L) {
    dlog("lock", "%s [lock released]", renv_path_pretty(path))
    renv_lock_release_impl(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)
  renv_watchdog_notify("LockReleased", list(path = path))
}

renv_lock_orphaned <- function(path) {

  timeout <- getOption("renv.lock.timeout", default = 60L)
  if (timeout <= 0L)
    return(TRUE)

  info <- renv_file_info(path)
  if (is.na(info$isdir))
    return(FALSE)

  diff <- difftime(Sys.time(), info$mtime, units = "secs")
  diff >= timeout

}

renv_lock_refresh <- function(lock) {
  Sys.setFileTime(lock, Sys.time())
}

renv_lock_unload <- function() {
  locks <- ls(envir = the$lock_registry, all.names = TRUE)
  unlink(locks, recursive = TRUE, force = TRUE)
}

renv_lock_path <- function(path) {

  file.path(
    renv_path_normalize(dirname(path), mustWork = TRUE),
    basename(path)
  )

}


# lockfile-api.R -------------------------------------------------------------


# NOTE: These functions are used by the 'dockerfiler' package, even though
# they are not exported. We retain these functions here just to avoid issues
# during CRAN submission. We'll consider removing them in a future release.

renv_lockfile_api <- function(lockfile = NULL) {

  .lockfile <- lockfile
  .self <- new.env(parent = emptyenv())

  .self$repos <- function(..., .repos = NULL) {

    if (nargs() == 0) {
      repos <- .lockfile$R$Repositories
      return(repos)
    }

    repos <- .repos %||% list(...)
    if (is.null(names(repos)) || "" %in% names(repos))
      stop("repositories must all be named", call. = FALSE)

    .lockfile$R$Repositories <<- as.list(convert(repos, "character"))
    invisible(.self)

  }

  .self$version <- function(..., .version = NULL) {

    if (nargs() == 0) {
      version <- .lockfile$R$Version
      return(version)
    }

    version <- .version %||% c(...)

    if (length(version) > 1) {
      stop("Version should be length 1 character e.g. `\"3.6.3\"`")
    }

    .lockfile$R$Version <<- version
    invisible(.self)

  }

  .self$add <- function(..., .list = NULL) {

    records <- renv_lockfile_records(.lockfile)

    dots <- .list %||% list(...)
    enumerate(dots, function(package, remote) {
      resolved <- renv_remotes_resolve(remote)
      records[[package]] <<- resolved
    })

    renv_lockfile_records(.lockfile) <<- records
    invisible(.self)

  }

  .self$remove <- function(packages) {
    records <- renv_lockfile_records(.lockfile) %>% exclude(packages)
    renv_lockfile_records(.lockfile) <<- records
    invisible(.self)
  }

  .self$write <- function(file = stdout()) {
    renv_lockfile_write(.lockfile, file = file)
    invisible(.self)
  }

  .self$data <- function() {
    .lockfile
  }

  class(.self) <- "renv_lockfile_api"
  .self

}

#' Programmatically Create and Modify a Lockfile
#'
#' 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
#' record in an existing lockfile.
#'
#' @inheritParams renv-params
#'
#' @param file The path to an existing lockfile. When no lockfile is provided,
#'   a new one will be created based on the current project context. If you
#'   want to create a blank lockfile, use `file = NA` instead.
#'
#' @seealso \code{\link{lockfiles}}, for a description of the structure of an
#'   `renv` lockfile.
#'
#' @examples
#'
#' \dontrun{
#'
#' lock <- lockfile("renv.lock")
#'
#' # set the repositories for a lockfile
#' lock$repos(CRAN = "https://cran.r-project.org")
#'
#' # depend on digest 0.6.22
#' lock$add(digest = "digest@@0.6.22")
#'
#' # write to file
#' lock$write("renv.lock")
#'
#' }
#'
#' @keywords internal
#' @rdname lockfile-api
#' @name lockfile-api
#'
lockfile <- function(file = NULL, project = NULL) {
  project <- renv_project_resolve(project)
  renv_scope_error_handler()

  lock <- if (is.null(file)) {

    renv_lockfile_create(
      project  = project,
      libpaths = renv_libpaths_all(),
      type     = settings$snapshot.type(project = project)
    )

  } else if (is.na(file)) {

    renv_lockfile_init(project)

  } else {

    renv_lockfile_read(file = file)

  }

  renv_lockfile_api(lock)

}


# lockfile-diff.R ------------------------------------------------------------


renv_lockfile_diff <- function(old, new, compare = NULL) {

  compare <- compare %||% function(lhs, rhs) {
    list(before = lhs, after = rhs)
  }

  # ensure both lists have the same names, inserting missing
  # entries for those without any value
  nms <- union(names(old), names(new)) %||% character()
  if (length(nms)) {

    nms <- sort(nms)
    old[renv_vector_diff(nms, names(old))] <- list(NULL)
    new[renv_vector_diff(nms, names(new))] <- list(NULL)

    old <- old[nms]
    new <- new[nms]

  }

  # ensure that these have the same length for comparison
  if (is.list(old) && is.list(new))
    length(old) <- length(new) <- max(length(old), length(new))

  # check for differences
  diffs <- mapply(
    renv_lockfile_diff_impl, old, new,
    MoreArgs = list(compare = compare),
    SIMPLIFY = FALSE
  )

  # drop NULL entries
  reject(diffs, empty)

}

renv_lockfile_diff_impl <- function(lhs, rhs, compare) {
  case(
    is.list(lhs) && empty(rhs)   ~ renv_lockfile_diff(lhs, list(), compare),
    empty(lhs) && is.list(rhs)   ~ renv_lockfile_diff(list(), rhs, compare),
    is.list(lhs) && is.list(rhs) ~ renv_lockfile_diff(lhs, rhs, compare),
    !identical(c(lhs), c(rhs))   ~ compare(lhs, rhs),
    NULL
  )
}

renv_lockfile_diff_record <- function(before, after) {

  before <- renv_record_normalize(before)
  after  <- renv_record_normalize(after)

  # first, compare on version / record existence
  type <- case(
    is.null(before) ~ "install",
    is.null(after)  ~ "remove",
    before$Version < after$Version ~ "upgrade",
    before$Version > after$Version ~ "downgrade"
  )

  if (!is.null(type))
    return(type)

  # if we're running this as part of 'load()', and we're comparing
  # packages with unknown sources, then just ignore those -- this
  # is because we disable the 'guess repository' hack on startup,
  # to avoid a potentially expensive query of package repositories
  #
  # https://github.com/rstudio/renv/issues/1683
  if (the$load_running) {
    unknown <-
      identical(before$Source, "unknown") ||
      identical(after$Source,  "unknown")
    if (unknown)
      return(NULL)
  }

  # check for a crossgrade -- where the package version is the same,
  # but details about the package's remotes have changed
  if (!setequal(renv_record_names(before), renv_record_names(after)))
    return("crossgrade")

  nm <- union(renv_record_names(before), renv_record_names(after))
  if (!identical(before[nm], after[nm]))
    return("crossgrade")

  NULL

}

renv_lockfile_diff_packages <- function(old, new) {

  old <- renv_lockfile_records(old)
  new <- renv_lockfile_records(new)

  packages <- named(union(names(old), names(new)))
  actions <- lapply(packages, function(package) {
    before <- old[[package]]; after <- new[[package]]
    renv_lockfile_diff_record(before, after)
  })

  Filter(Negate(is.null), actions)

}

renv_lockfile_override <- function(lockfile) {
  records <- renv_lockfile_records(lockfile)
  overrides <- renv_records_override(records)
  renv_lockfile_records(lockfile) <- overrides
  lockfile
}

renv_lockfile_repair <- function(lockfile) {

  records <- renv_lockfile_records(lockfile)

  # fix up records in lockfile
  renv_lockfile_records(lockfile) <- enumerate(records, function(package, record) {

    # if this package is from a repository, but doesn't specify an explicit
    # version, then use the latest-available version of that package
    source <- renv_record_source_normalize(record, record$Source)
    if (identical(source, "Repository") && is.null(record$Version)) {
      entry <- renv_available_packages_latest(package)
      record$Version <- entry$Version
    }

    # return normalized record
    record

  })

  lockfile

}


# lockfile-read.R ------------------------------------------------------------


renv_lockfile_read_finish_impl <- function(key, val) {

  # convert repository records to named vectors
  # (be careful to handle NAs, NULLs)
  if (identical(key, "Repositories") && is.null(names(val))) {

    getter <- function(name) function(record) record[[name]] %||% "" %NA% ""
    keys <- map_chr(val, getter("Name"))
    vals <- map_chr(val, getter("URL"))

    result <- case(
      empty(keys)       ~ list(),
      any(nzchar(keys)) ~ named(vals, keys),
      TRUE              ~ vals
    )

    return(as.list(result))

  }

  # convert the "Requirements" field to a character vector
  if (identical(key, "Requirements"))
    return(unlist(val))

  # recurse for lists
  if (is.list(val))
    return(enumerate(val, renv_lockfile_read_finish_impl))

  # return other values as-is
  val

}

renv_lockfile_read_finish <- function(data) {
  data <- enumerate(data, renv_lockfile_read_finish_impl)
  class(data) <- "renv_lockfile"
  data
}

renv_lockfile_read_preflight <- function(contents) {

  # check for merge conflict markers
  starts <- grep("^[<]+", contents)
  ends   <- grep("^[>]+", contents)

  hasconflicts <-
    length(starts) &&
    length(ends) &&
    length(starts) == length(ends)

  if (hasconflicts) {

    parts <- .mapply(function(start, end) {
      c(contents[start:end], "")
    }, list(starts, ends), NULL)

    all <- unlist(parts, recursive = TRUE, use.names = FALSE)

    caution_bullets(
      "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."
    )

    stop("lockfile contains merge conflict markers; cannot proceed", call. = FALSE)

  }

}

renv_lockfile_read <- function(file = NULL, text = NULL) {

  # read the lockfile
  contents <- if (is.null(file))
    unlist(strsplit(text, "\n", fixed = TRUE))
  else
    readLines(file, warn = FALSE, encoding = "UTF-8")

  # check and report some potential errors (e.g. merge conflicts)
  renv_lockfile_read_preflight(contents)
  withCallingHandlers(
    json <- renv_json_read(text = contents),
    error = function(err) {
      stop("Failed to parse 'renv.lock':\n", conditionMessage(err))
    }
  )

  renv_lockfile_read_finish(json)

}


# lockfile-write.R -----------------------------------------------------------


the$lockfile_state <- new.env(parent = emptyenv())

renv_lockfile_state_get <- function(key) {
  if (exists(key, envir = the$lockfile_state))
    get(key, envir = the$lockfile_state, inherits = FALSE)
}

renv_lockfile_state_set <- function(key, value) {
  assign(key, value, envir = the$lockfile_state, inherits = FALSE)
}

renv_lockfile_state_clear <- function() {
  rm(list = ls(the$lockfile_state), envir = the$lockfile_state)
}

renv_lockfile_write_preflight <- function(old, new) {

  diff <- renv_lockfile_diff(old, new)
  if (empty(diff))
    return(new)

  packages <- diff$Packages
  if (empty(diff$Packages))
    return(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")))

    if (spurious)
      new$Packages[[package]]$Repository <<- old$Packages[[package]]$Repository

    # 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

  })

  new

}

renv_lockfile_write <- function(lockfile, file = stdout()) {

  # if we're updating an existing lockfile, try to avoid
  # "unnecessary" diffs that might otherwise be annoying
  if (is.character(file) && file.exists(file)) {
    old <- catch(renv_lockfile_read(file))
    if (!inherits(old, "error"))
      lockfile <- renv_lockfile_write_preflight(old, lockfile)
  }

  lockfile <- renv_lockfile_sort(lockfile)
  result <- renv_lockfile_write_json(lockfile, file)

  if (is.character(file))
    writef("- Lockfile written to %s.", renv_path_pretty(file))

  result

}

renv_lockfile_write_json_prepare_repos <- function(repos) {

  prepared <- enumerate(repos, function(name, url) {
    url <- sub("/+$", "", url)
    list(Name = name, URL = url)
  })

  unname(prepared)
}

renv_lockfile_write_json_prepare <- function(key, val) {

  if (key == "Repositories")
    renv_lockfile_write_json_prepare_repos(val)
  else if (is.list(val) && !is.null(names(val)))
    enumerate(val, renv_lockfile_write_json_prepare)
  else
    val

}

renv_lockfile_write_json <- function(lockfile, file = stdout()) {

  prepared <- enumerate(lockfile, renv_lockfile_write_json_prepare)

  box <- c("Depends", "Imports", "Suggests", "LinkingTo", "Requirements")
  config <- list(box = box)
  json <- renv_json_convert(prepared, config)
  if (is.null(file))
    return(json)

  writeLines(json, con = file)

}

renv_lockfile_write_internal <- function(lockfile,
                                         file = stdout(),
                                         delim = "=")
{
  if (is.character(file)) {
    file <- textfile(file)
    defer(close(file))
  }

  emitter <- function(text) writeLines(text, con = file)

  renv_lockfile_state_set("delim", delim)
  renv_lockfile_state_set("emitter", emitter)
  defer(renv_lockfile_state_clear())

  renv_lockfile_write_list(lockfile, section = character())
  invisible(lockfile)
}

renv_lockfile_write_list <- function(entry, section) {
  enumerate(entry, renv_lockfile_write_atoms, section = section)
  enumerate(entry, renv_lockfile_write_lists, section = section)
}

renv_lockfile_write_atoms <- function(key, value, section) {

  sublists <- map_lgl(value, function(x) identical(class(x), "list"))
  if (all(sublists))
    return()

  subsection <- c(section, key)
  label <- sprintf("[%s]", paste(subsection, collapse = "/"))
  renv_lockfile_write_emit(label)

  enumerate(value[!sublists], renv_lockfile_write_atom)
  renv_lockfile_write_emit()

}

renv_lockfile_write_atom <- function(key, value) {

  lhs <- key
  rhs <- if (is_named(value))
    paste(sprintf("\n\t%s=%s", names(value), value), collapse = "")
  else
    paste(value, collapse = ", ")

  delim <- renv_lockfile_state_get("delim")
  text <- paste(lhs, rhs, sep = delim)
  renv_lockfile_write_emit(text)

}

renv_lockfile_write_lists <- function(key, value, section) {
  sublists <- map_lgl(value, function(x) identical(class(x), "list"))
  renv_lockfile_write_list(value[sublists], section = c(section, key))
}

renv_lockfile_write_emit <- function(text = "") {
  emitter <- renv_lockfile_state_get("emitter")
  emitter(text)
}


# lockfile.R -----------------------------------------------------------------


renv_lockfile_init <- function(project) {

  lockfile <- list()

  lockfile$R        <- renv_lockfile_init_r(project)
  lockfile$Python   <- renv_lockfile_init_python(project)
  lockfile$Packages <- list()

  class(lockfile) <- "renv_lockfile"
  lockfile

}

renv_lockfile_init_r_version <- function(project) {

  # NOTE: older versions of renv may have written out an empty array
  # for the R version in some cases, so we explicitly check that we
  # receive a length-one string here.
  version <- settings$r.version(project = project)
  if (!pstring(version))
    version <- getRversion()

  format(version)

}

renv_lockfile_init_r_repos <- function(project) {

  repos <- getOption("repos")

  # save names
  nms <- names(repos)

  # force as character
  repos <- as.character(repos)

  # clear RStudio attribute
  attr(repos, "RStudio") <- NULL

  # set a default URL
  repos[repos == "@CRAN@"] <- getOption(
    "renv.repos.cran",
    "https://cloud.r-project.org"
  )

  # remove PPM bits from URL
  if (renv_ppm_enabled()) {
    pattern <- "/__[^_]+__/[^/]+/"
    repos <- sub(pattern, "/", repos)
  }

  # force as list
  repos <- as.list(repos)

  # ensure names
  names(repos) <- nms

  repos

}

renv_lockfile_init_r <- function(project) {
  version <- renv_lockfile_init_r_version(project)
  repos   <- renv_lockfile_init_r_repos(project)
  list(Version = version, Repositories = repos)
}

renv_lockfile_init_python <- function(project) {

  python <- Sys.getenv("RENV_PYTHON", unset = NA)
  if (is.na(python))
    return(NULL)

  if (!file.exists(python))
    return(NULL)

  info <- renv_python_info(python)
  if (is.null(info))
    return(NULL)

  version <- renv_python_version(python)
  type <- info$type
  root <- info$root
  name <- renv_python_envname(project, root, type)

  fields <- list()

  fields$Version <- version
  fields$Type    <- type
  fields$Name    <- name

  fields

}

renv_lockfile_fini <- function(lockfile, project) {
  lockfile$Bioconductor <- renv_lockfile_fini_bioconductor(lockfile, project)
  lockfile
}

renv_lockfile_fini_bioconductor <- function(lockfile, project) {

  # check for explicit version in settings
  version <- settings$bioconductor.version(project = project)
  if (length(version))
    return(list(Version = version))

  # otherwise, check for a package which required Bioconductor
  records <- renv_lockfile_records(lockfile)
  if (empty(records))
    return(NULL)

  for (package in c("BiocManager", "BiocInstaller"))
    if (!is.null(records[[package]]))
      return(list(Version = renv_bioconductor_version(project = project)))

  sources <- extract_chr(records, "Source")
  if ("Bioconductor" %in% sources)
    return(list(Version = renv_bioconductor_version(project = project)))

  # nothing found; return NULL
  NULL

}

renv_lockfile_path <- function(project) {
  renv_paths_lockfile(project = project)
}

renv_lockfile_save <- function(lockfile, project) {
  file <- renv_lockfile_path(project)
  renv_lockfile_write(lockfile, file = file)
}

renv_lockfile_load <- function(project, strict = FALSE) {

  path <- renv_lockfile_path(project)
  if (file.exists(path))
    return(renv_lockfile_read(path))

  if (strict) {
    abort(c(
      "This project does not contain a lockfile.",
      i = "Have you called `snapshot()` yet?"
    ))
  }

  renv_lockfile_init(project = project)

}

renv_lockfile_sort <- function(lockfile) {

  # extract R records (nothing to do if empty)
  records <- renv_lockfile_records(lockfile)
  if (empty(records))
    return(lockfile)

  # sort the records
  sorted <- records[csort(names(records))]
  renv_lockfile_records(lockfile) <- sorted

  # sort top-level fields
  fields <- unique(c("R", "Bioconductor", "Python", "Packages", names(lockfile)))
  lockfile <- lockfile[intersect(fields, names(lockfile))]

  # return post-sort
  lockfile

}

renv_lockfile_create <- function(project,
                                 type = NULL,
                                 libpaths = NULL,
                                 packages = NULL,
                                 exclude = NULL,
                                 prompt = NULL,
                                 force = NULL,
                                 dev = FALSE)
{
  libpaths <- libpaths %||% renv_libpaths_all()
  type <- type %||% settings$snapshot.type(project = project)

  # use a restart, so we can allow the user to install packages before snapshot
  lockfile <- withRestarts(
    renv_lockfile_create_impl(project, type, libpaths, packages, exclude, prompt, force, dev = dev),
    renv_recompute_records = function() {
      renv_dynamic_reset()
      renv_lockfile_create_impl(project, type, libpaths, packages, exclude, prompt, force, dev = dev)
    }
  )
}

renv_lockfile_create_impl <- function(project, type, libpaths, packages, exclude, prompt, force, dev = FALSE) {

  lockfile <- renv_lockfile_init(project)

  # compute the project's top-level package dependencies
  packages <- packages %||% renv_snapshot_dependencies(
    project = project,
    type = type,
    dev = dev
  )

  # expand the recursive dependencies of these packages
  records <- renv_snapshot_packages(
    packages = setdiff(packages, exclude),
    libpaths = libpaths,
    project  = project
  )

  # check for missing packages
  ignored <- c(renv_project_ignored_packages(project), renv_packages_base(), exclude, "renv")
  missing <- setdiff(packages, c(names(records), ignored))

  # cancel automatic snapshots if we have missing packages
  if (length(missing) && the$auto_snapshot_running) {
    cancel <- findRestart("cancel")
    if (isRestart(cancel))
      invokeRestart(cancel)
  }

  # give user a chance to handle missing packages, if any
  #
  # we only run this in top-level calls to snapshot() since renv will internally
  # use snapshot() to create lockfiles, and missing packages are understood /
  # tolerated there. this code mostly exists so interactive usages of snapshot()
  # can recover and install missing packages
  if (identical(topfun(), snapshot))
    renv_snapshot_report_missing(missing, type)

  records <- renv_snapshot_fixup(records)
  renv_lockfile_records(lockfile) <- records

  lockfile <- renv_lockfile_fini(lockfile, project)

  keys <- unique(c("R", "Bioconductor", names(lockfile)))
  lockfile <- lockfile[intersect(keys, names(lockfile))]

  class(lockfile) <- "renv_lockfile"
  lockfile

}

renv_lockfile_modify <- function(lockfile, records) {

  enumerate(records, function(package, record) {
    renv_lockfile_records(lockfile)[[package]] <<- record
  })

  lockfile

}

renv_lockfile_compact <- function(lockfile) {

  records <- renv_lockfile_records(lockfile)
  remotes <- map_chr(records, renv_record_format_remote)

  remotes <- csort(remotes)

  formatted <- sprintf("  \"%s\"", remotes)
  joined <- paste(formatted, collapse = ",\n")

  all <- c("renv::use(", joined, ")")
  paste(all, collapse = "\n")

}

renv_lockfile_records <- function(lockfile) {
  as.list(lockfile$Packages %||% lockfile)
}

`renv_lockfile_records<-` <- function(x, value) {
  x$Packages <- filter(value, zlength)
  invisible(x)
}

# for compatibility with older versions of RStudio
renv_records <- renv_lockfile_records


# lockfiles.R ----------------------------------------------------------------


#' Lockfiles
#'
#' A **lockfile** records the state of a project at some point in time.
#'
#' A lockfile captures the state of a project's library at some point in time.
#' In particular, the package names, their versions, and their sources (when
#' known) are recorded in the lockfile.
#'
#' Projects can be restored from a lockfile using the [restore()] function. This
#' implies reinstalling packages into the project's private library, as encoded
#' within the lockfile.
#'
#' While lockfiles are normally generated and used with [snapshot()] /
#' [restore()], they can also be edited by hand if so desired. Lockfiles are
#' written as `.json`, to allow for easy consumption by other tools.
#'
#' An example lockfile follows:
#'
#' ```
#' {
#'   "R": {
#'     "Version": "3.6.1",
#'     "Repositories": [
#'       {
#'         "Name": "CRAN",
#'         "URL": "https://cloud.r-project.org"
#'       }
#'     ]
#'   },
#'   "Packages": {
#'     "markdown": {
#'       "Package": "markdown",
#'       "Version": "1.0",
#'       "Source": "Repository",
#'       "Repository": "CRAN",
#'       "Hash": "4584a57f565dd7987d59dda3a02cfb41"
#'     },
#'     "mime": {
#'       "Package": "mime",
#'       "Version": "0.7",
#'       "Source": "Repository",
#'       "Repository": "CRAN",
#'       "Hash": "908d95ccbfd1dd274073ef07a7c93934"
#'     }
#'   }
#' }
#' ```
#'
#' The sections used within a lockfile are described next.
#'
#' ## renv
#'
#' Information about the version of renv used to manage this project.
#'
#' \tabular{ll}{
#' \strong{Version}     \tab The version of the renv package used with this project. \cr
#' }
#'
#' ## R
#'
#' Properties related to the version of \R associated with this project.
#'
#' \tabular{ll}{
#' \strong{Version}      \tab The version of \R used. \cr
#' \strong{Repositories} \tab The \R repositories used in this project. \cr
#' }
#'
#' ## Packages
#'
#' \R package records, capturing the packages used or required by a project
#' at the time when the lockfile was generated.
#'
#' \tabular{ll}{
#' \strong{Package}      \tab The package name. \cr
#' \strong{Version}      \tab The package version. \cr
#' \strong{Source}       \tab The location from which this package was retrieved. \cr
#' \strong{Repository}   \tab The name of the repository (if any) from which this package was retrieved. \cr
#' \strong{Hash}         \tab (Optional) A unique hash for this package, used for package caching. \cr
#' }
#'
#' Additional remote fields, further describing how the package can be
#' retrieved from its corresponding source, will also be included as
#' appropriate (e.g. for packages installed from GitHub).
#'
#' ## Python
#'
#' Metadata related to the version of Python used with this project (if any).
#'
#' \tabular{ll}{
#' \strong{Version} \tab The version of Python being used. \cr
#' \strong{Type}    \tab The type of Python environment being used ("virtualenv", "conda", "system") \cr
#' \strong{Name}    \tab The (optional) name of the environment being used.
#' }
#'
#' Note that the `Name` field may be empty. In that case, a project-local Python
#' environment will be used instead (when not directly using a system copy of Python).
#'
#' # Caveats
#'
#' These functions are primarily intended for expert users -- in most cases,
#' [snapshot()] and [restore()] are the primariy tools you will need when
#' creating and using lockfiles.
#'
#' @inheritParams snapshot
#' @inheritParams renv-params
#'
#' @param lockfile An `renv` lockfile; typically created by either
#'   `lockfile_create()` or `lockfile_read()`.
#'
#' @param file A file path, or \R connection.
#'
#' @family reproducibility
#' @name lockfiles
#' @rdname lockfiles
NULL

#' @param libpaths The library paths to be used when generating the lockfile.
#' @rdname lockfiles
#' @export
lockfile_create <- function(type = settings$snapshot.type(project = project),
                            libpaths = .libPaths(),
                            packages = NULL,
                            exclude = NULL,
                            prompt = interactive(),
                            force = FALSE,
                            ...,
                            project = NULL)
{
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  renv_scope_verbose_if(prompt)

  renv_lockfile_create(
    project  = project,
    type     = type,
    libpaths = libpaths,
    packages = packages,
    exclude  = exclude,
    prompt   = prompt,
    force    = force
  )
}

#' @rdname lockfiles
#' @export
lockfile_read <- function(file = NULL, ..., project = NULL) {
  project <- renv_project_resolve(project)
  file <- file %||% renv_paths_lockfile(project = project)
  renv_lockfile_read(file = file)
}

#' @rdname lockfiles
#' @export
lockfile_write <- function(lockfile, file = NULL, ..., project = NULL) {
  project <- renv_project_resolve(project)
  file <- file %||% renv_paths_lockfile(project = project)
  renv_lockfile_write(lockfile, file = file)
}

#' @param remotes An \R vector of remote specifications.
#'
#' @param repos A named vector, mapping \R repository names to their URLs.
#'
#' @rdname lockfiles
#' @export
lockfile_modify <- function(lockfile = NULL,
                            ...,
                            remotes = NULL,
                            repos = NULL,
                            project = NULL)
{
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  lockfile <- lockfile %||% renv_lockfile_load(project, strict = TRUE)

  if (!is.null(repos))
    lockfile$R$Repositories <- as.list(repos)

  if (!is.null(remotes)) {
    remotes <- renv_records_resolve(remotes, latest = TRUE)
    names(remotes) <- map_chr(remotes, `[[`, "Package")
    enumerate(remotes, function(package, remote) {
      record <- renv_remotes_resolve(remote)
      renv_lockfile_records(lockfile)[[package]] <<- record
    })
  }

  lockfile

}


# log.R ----------------------------------------------------------------------


# the log level, indicating what severity of messages will be logged
the$log_level <- 4L

# the file to which log messages will be written
the$log_file <- NULL

# the scopes for which filtering will be enabled
the$log_scopes <- NULL

elog <- function(scope, fmt, ...) {
  renv_log_impl(4L, scope, fmt, ...)
}

wlog <- function(scope, fmt, ...) {
  renv_log_impl(3L, scope, fmt, ...)
}

ilog <- function(scope, fmt, ...) {
  renv_log_impl(2L, scope, fmt, ...)
}

dlog <- function(scope, fmt, ...) {
  renv_log_impl(1L, scope, fmt, ...)
}


renv_log_impl <- function(level, scope, fmt, ...) {

  # check log level
  if (level < the$log_level)
    return()

  # only include scopes matching the scopes
  scopes <- the$log_scopes
  if (is.character(scopes) && !scope %in% scopes)
    return()

  # build message
  message <- sprintf(fmt, ...)

  # annotate with prefix from scope, timestamp
  fmt <- "%sZ [renv-%i] %s: %s"
  now <- format(Sys.time(), format = "%Y-%m-%d %H:%M:%OS6", tz = "UTC")
  all <- sprintf(fmt, now, Sys.getpid(), scope, message)

  # write it out
  cat(all, file = the$log_file, sep = "\n", append = TRUE)

}

renv_log_init <- function() {
  the$log_level  <- renv_log_level()
  the$log_file   <- renv_log_file()
  the$log_scopes <- renv_log_scopes()
}

renv_log_level <- function() {

  level <- Sys.getenv("RENV_LOG_LEVEL", unset = NA)
  if (is.na(level))
    return(4L)

  case(
    level %in% c("4", "error",   "ERROR")   ~ 4L,
    level %in% c("3", "warning", "WARNING") ~ 3L,
    level %in% c("2", "info",    "INFO")    ~ 2L,
    level %in% c("1", "debug",   "DEBUG")   ~ 1L,
    ~ {
      warningf("ignoring invalid RENV_LOG_LEVEL '%s'", level)
      4L
    }
  )

}

renv_log_file <- function() {

  # check for log file
  file <- Sys.getenv("RENV_LOG_FILE", unset = NA)
  if (!is.na(file))
    return(file)

  # default to stderr, since it's unbuffered
  stderr()

}

renv_log_scopes <- function() {

  scopes <- Sys.getenv("RENV_LOG_SCOPES", unset = NA)
  if (is.na(scopes))
    return(NULL)

  strsplit(scopes, ",", fixed = TRUE)[[1L]]

}



# manifest-convert.R ---------------------------------------------------------


#' Generate `renv.lock` from an RStudio Connect `manifest.json`
#'
#' Use `renv_lockfile_from_manifest()` to convert a `manifest.json` file from
#' an RStudio Connect content bundle into an `renv.lock` lockfile.
#'
#' This function can be useful when you need to recreate the package environment
#' of a piece of content that is deployed to RStudio Connect. The content bundle
#' contains a `manifest.json` file that is used to recreate the package
#' environment. This function will let you convert that manifest file to an
#' `renv.lock` file. Run `renv::restore()` after you've converted the file to
#' restore the package environment.
#'
#' @param manifest
#'   The path to a `manifest.json` file.
#'
#' @param lockfile
#'   The path to the lockfile to be generated and / or updated.
#'   When `NA` (the default), the generated lockfile is returned as an \R
#'   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,
                                        lockfile = NA,
                                        project = NULL)
{
  renv_scope_error_handler()
  project <- renv_project_resolve(project)

  # read the manifest (accept both lists and file paths)
  manifest <- case(
    is.character(manifest) ~ renv_json_read(manifest),
    is.list(manifest)      ~ manifest,
    TRUE                   ~ renv_type_unexpected(manifest)
  )

  # convert descriptions into records
  records <- map(manifest[["packages"]], function(entry) {
    desc <- entry[["description"]]
    renv_snapshot_description_impl(desc)
  })

  # extract repositories from descriptions
  repos <- list()
  for (entry in manifest[["packages"]]) {

    if (is.null(entry[["Repository"]]))
      next

    src <- entry[["Source"]] %||% "CRAN"
    repo <- entry[["Repository"]]

    repos[[src]] <- repo

  }

  # extract version
  version <- format(manifest[["platform"]] %||% getRversion())

  # create R field for lockfile
  r <- list(Version = version, Repositories = repos)

  # create the lockfile
  lock <- list(R = r, Packages = records)
  class(lock) <- "renv_lockfile"

  # return lockfile as R object if requested
  if (is.na(lockfile))
    return(lock)

  # otherwise, write to file and report for user
  renv_lockfile_write(lock, file = lockfile)
  fmt <- "- Lockfile written to %s."
  writef(fmt, renv_path_pretty(lockfile))

  invisible(lock)

}


# mask.R ---------------------------------------------------------------------


# functions which mask internal / base R equivalents, usually to provide
# backwards compatibility or guard against common errors

numeric_version <- function(x, strict = TRUE) {
  base::numeric_version(as.character(x), strict = strict)
}

sprintf <- function(fmt, ...) {
  if (nargs() == 1L)
    fmt
  else
    base::sprintf(fmt, ...)
}

unique <- function(x) {
  base::unique(x)
}

# a wrapper for 'utils::untar()' that throws an error if untar fails
untar <- function(tarfile,
                  files = NULL,
                  list = FALSE,
                  exdir = ".",
                  tar = Sys.getenv("TAR"))
{
  # delegate to utils::untar()
  result <- utils::untar(
    tarfile = tarfile,
    files   = files,
    list    = list,
    exdir   = exdir,
    tar     = tar
  )

  # check for errors (tar returns a status code)
  if (is.integer(result) && result != 0L) {
    call <- stringify(sys.call())
    stopf("'%s' returned status code %i", call, result)
  }

  # return other results as-is
  result
}



# memoize.R ------------------------------------------------------------------


the$memoize <- new.env(parent = emptyenv())

memo <- function(value, scope = NULL) {
  scope <- scope %||% stringify(sys.call(sys.parent())[[1L]])
  (the$memoize[[scope]] <- the$memoize[[scope]] %||% value)
}

memoize <- function(key, value, scope = NULL) {

  # figure out scope to use
  scope <- scope %||% stringify(sys.call(sys.parent())[[1L]])

  # initialize memoized environment
  envir <-
    the$memoize[[scope]] <-
    the$memoize[[scope]] %||%
    new.env(parent = emptyenv())

  # retrieve, or compute, memoized value
  envir[[key]] <- envir[[key]] %||% value

}


# metadata.R -----------------------------------------------------------------


# NOTE: 'the$metadata' is initialized either in 'renv_metadata_init()', for
# stand-alone installations of renv, or via an embedded initialize script for
# vendored copies of renv.

renv_metadata_create <- function(embedded, version) {
  list(embedded = embedded, version = version)
}

renv_metadata_embedded <- function() {
  the$metadata$embedded
}

renv_metadata_version <- function() {
  the$metadata$version
}

renv_metadata_version_create <- function(record) {
  version <- record[["Version"]]
  attr(version, "sha") <- record[["RemoteSha"]]
  version
}

renv_metadata_remote <- function(metadata = the$metadata) {

  # check for development versions
  sha <- attr(metadata$version, "sha")
  if (!is.null(sha) && nzchar(sha))
    return(paste("rstudio/renv", sha, sep = "@"))

  # otherwise, use release version
  paste("renv", metadata$version, sep = "@")

}

renv_metadata_version_friendly <- function(metadata = the$metadata,
                                           shafmt = NULL)
{
  renv_bootstrap_version_friendly(
    version = metadata$version,
    shafmt  = shafmt
  )
}

renv_metadata_init <- function() {

  # if renv was embedded, then the$metadata should already be initialized
  if (!is.null(the$metadata))
    return()

  # renv doesn't appear to be embedded; initialize metadata
  path <- renv_namespace_path("renv")
  record <- renv_description_read(path = file.path(path, "DESCRIPTION"))
  version <- renv_metadata_version_create(record)

  the$metadata <- renv_metadata_create(
    embedded = FALSE,
    version  = version
  )

}


# methods.R ------------------------------------------------------------------


renv_methods_map <- function() {

  list(

    renv_path_normalize = c(
      unix  = "renv_path_normalize_unix",
      win32 = "renv_path_normalize_win32"
    ),

    renv_file_exists = c(
      unix  = "renv_file_exists_unix",
      win32 = "renv_file_exists_win32"
    ),

    renv_file_list_impl = c(
      unix  = "renv_file_list_impl_unix",
      win32 = "renv_file_list_impl_win32"
    ),

    renv_file_broken = c(
      unix  = "renv_file_broken_unix",
      win32 = "renv_file_broken_win32"
    )

  )

}

renv_methods_init <- function() {

  # get list of method mappings
  methods <- renv_methods_map()

  # 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) {
    replacement <- eval(parse(text = alt), envir = envir)
    assign(name, replacement, envir = envir)
  })

}

renv_methods_error <- function() {
  call <- sys.call(sys.parent())
  fmt <- "internal error: '%s()' not initialized in .onLoad()"
  stopf(fmt, as.character(call[[1L]]), call. = FALSE)
}


# migrate.R ------------------------------------------------------------------


#' Migrate a project from packrat to renv
#'
#' Migrate a project's infrastructure from packrat to renv.
#'
#' # Migration
#'
#' When migrating Packrat projects to renv, the set of components migrated
#' can be customized using the `packrat` argument. The set of components that
#' can be migrated are as follows:
#'
#' \tabular{ll}{
#'
#' **Name** \tab **Description** \cr
#'
#' `lockfile` \tab
#'   Migrate the Packrat lockfile (`packrat/packrat.lock`) to the renv lockfile
#'   (`renv.lock`). \cr
#'
#' `sources` \tab
#'   Migrate package sources from the `packrat/src` folder to the renv
#'   sources folder. Currently, only CRAN packages are migrated to renv --
#'   packages retrieved from other sources (e.g. GitHub) are ignored.
#'   \cr
#'
#' `library` \tab
#'   Migrate installed packages from the Packrat library to the renv project
#'   library.
#'   \cr
#'
#' `options` \tab
#'   Migrate compatible Packrat options to the renv project.
#'   \cr
#'
#' `cache` \tab
#'   Migrate packages from the Packrat cache to the renv cache.
#'   \cr
#'
#' }
#'
#' @inherit renv-params
#'
#' @param packrat Components of the Packrat project to migrate. See the default
#'   argument list for components of the Packrat project that can be migrated.
#'   Select a subset of those components for migration as appropriate.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # migrate Packrat project infrastructure to renv
#' renv::migrate()
#'
#' }
migrate <- function(
  project = NULL,
  packrat = c("lockfile", "sources", "library", "options", "cache"))
{
  renv_consent_check()
  renv_scope_error_handler()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  project <- renv_path_normalize(project, mustWork = TRUE)
  if (file.exists(file.path(project, "packrat/packrat.lock"))) {
    packrat <- match.arg(packrat, several.ok = TRUE)
    renv_migrate_packrat(project, packrat)
  }

  invisible(project)
}

renv_migrate_packrat <- function(project = NULL, components = NULL) {
  project <- renv_project_resolve(project)

  if (!requireNamespace("packrat", quietly = TRUE))
    stopf("migration requires the 'packrat' package to be installed")

  callbacks <- list(
    lockfile = renv_migrate_packrat_lockfile,
    sources  = renv_migrate_packrat_sources,
    library  = renv_migrate_packrat_library,
    options  = renv_migrate_packrat_options,
    cache    = renv_migrate_packrat_cache
  )

  components <- components %||% names(callbacks)
  callbacks <- callbacks[components]
  for (callback in callbacks)
    callback(project)

  renv_migrate_packrat_infrastructure(project)
  renv_imbue_impl(project)

  fmt <- "- Project '%s' has been migrated from Packrat to renv."
  writef(fmt, renv_path_aliased(project))

  writef("- Consider deleting the project 'packrat' folder if it is no longer needed.")
  invisible(TRUE)
}

renv_migrate_packrat_lockfile <- function(project) {

  plock <- file.path(project, "packrat/packrat.lock")
  if (!file.exists(plock))
    return(FALSE)

  # read the lockfile
  contents <- read(plock)
  splat <- strsplit(contents, "\n{2,}")[[1]]
  dcf <- lapply(splat, function(section) {
    renv_dcf_read(text = section)
  })

  # split into header + package fields
  header <- dcf[[1]]
  records <- dcf[-1L]

  # parse the repositories
  repos <- getOption("repos")
  if (!is.null(header$Repos)) {
    parts <- strsplit(header$Repos, "\\s*,\\s*")[[1]]
    repos <- renv_properties_read(text = parts, delimiter = "=")
  }

  # fix-up some record fields for renv
  fields <- c("Package", "Version", "Source")
  records <- lapply(records, function(record) {

    # remove an old packrat hash
    record$Hash <- NULL

    # add RemoteType for GitHub records
    if (any(grepl("^Github", names(record))))
      record$RemoteType <- "github"

    # remap '^Github'-style records to '^Remote'
    map <- c(
      "GithubRepo"     = "RemoteRepo",
      "GithubUsername" = "RemoteUsername",
      "GithubRef"      = "RemoteRef",
      "GithubSha1"     = "RemoteSha",
      "GithubSHA1"     = "RemoteSha",
      "GithubSubdir"   = "RemoteSubdir"
    )
    names(record) <- remap(names(record), map)

    # keep only fields of interest
    keep <- c(fields, grep("^Remote", names(record), value = TRUE))
    as.list(record[keep])

  })

  # pull out names for records
  names(records) <- extract_chr(records, "Package")

  # ensure renv is added
  records <- renv_snapshot_fixup_renv(records)

  # generate a blank lockfile
  lockfile <- structure(list(), class = "renv_lockfile")
  lockfile$R <- renv_lockfile_init_r(project)

  # update fields
  lockfile$R$Version <- header$RVersion
  lockfile$R$Repositories <- as.list(repos)
  renv_lockfile_records(lockfile) <- records

  # finish
  lockfile <- renv_lockfile_fini(lockfile, project)

  # write the lockfile
  lockpath <- renv_lockfile_path(project = project)
  renv_lockfile_write(lockfile, file = lockpath)

}

renv_migrate_packrat_sources <- function(project) {

  packrat <- asNamespace("packrat")
  srcdir <- packrat$srcDir(project = project)
  if (!file.exists(srcdir))
    return(TRUE)

  pattern <- paste0(
    "^",                   # start
    "[^_]+",               # package name
    "_",                   # separator
    "\\d+(?:[_.-]\\d+)*",  # version
    "\\.tar\\.gz",         # extension
    "$"                    # end
  )

  suffixes <- list.files(
    srcdir,
    pattern = pattern,
    recursive = TRUE
  )

  sources <- file.path(srcdir, suffixes)
  targets <- renv_paths_source("cran", suffixes)

  keep <- !file.exists(targets)
  sources <- sources[keep]; targets <- targets[keep]

  printf("- Migrating package sources from Packrat to renv ... ")
  copy <- renv_progress_callback(renv_file_copy, length(targets))
  mapply(sources, targets, FUN = function(source, target) {
    ensure_parent_directory(target)
    copy(source, target)
  })
  writef("Done!")

  TRUE

}

renv_migrate_packrat_library <- function(project) {

  packrat <- asNamespace("packrat")

  libdir <- packrat$libDir(project = project)
  if (!file.exists(libdir))
    return(TRUE)

  sources <- list.files(libdir, full.names = TRUE)
  if (empty(sources))
    return(TRUE)

  targets <- renv_paths_library(basename(sources), project = project)

  names(targets) <- sources
  targets <- targets[!file.exists(targets)]
  if (empty(targets)) {
    writef("- The renv library is already synchronized with the Packrat library.")
    return(TRUE)
  }

  # copy packages from Packrat to renv private library
  printf("- Migrating library from Packrat to renv ... ")
  ensure_parent_directory(targets)
  copy <- renv_progress_callback(renv_file_copy, length(targets))
  enumerate(targets, copy)
  writef("Done!")

  # move packages into the cache
  if (renv_cache_config_enabled(project = project)) {
    printf("- Moving packages into the renv cache ... ")
    records <- lapply(targets, renv_description_read)
    sync <- renv_progress_callback(renv_cache_synchronize, length(targets))
    lapply(records, sync, linkable = TRUE)
    writef("Done!")
  }

  TRUE

}

renv_migrate_packrat_options <- function(project) {

  packrat <- asNamespace("packrat")
  opts <- packrat$get_opts(project = project)

  settings$ignored.packages(opts$ignored.packages, project = project)

}

renv_migrate_packrat_cache <- function(project) {

  # find packages in the packrat cache
  packrat <- asNamespace("packrat")
  cache <- packrat$cacheLibDir()
  packages <- list.files(cache, full.names = TRUE)
  hashes <- list.files(packages, full.names = TRUE)
  sources <- list.files(hashes, full.names = TRUE)

  # sanity check: make sure the source folder is an R package
  ok <- file.exists(file.path(sources, "DESCRIPTION"))
  sources <- sources[ok]

  # construct cache target paths
  targets <- map_chr(sources, renv_cache_path)
  names(targets) <- sources

  # only copy to cache target paths that don't exist
  targets <- targets[!file.exists(targets)]
  if (empty(targets)) {
    writef("- The renv cache is already synchronized with the Packrat cache.")
    return(TRUE)
  }

  # cache each installed package
  if (renv_cache_config_enabled(project = project))
    renv_migrate_packrat_cache_impl(targets)

  TRUE

}

renv_migrate_packrat_cache_impl <- function(targets) {

  # attempt to copy packages from Packrat to renv cache
  printf("- Migrating Packrat cache to renv cache ... ")
  ensure_parent_directory(targets)
  copy <- renv_progress_callback(renv_file_copy, length(targets))

  result <- enumerate(targets, function(source, target) {
    status <- catch(copy(source, target))
    broken <- inherits(status, "error")
    reason <- if (broken) conditionMessage(status) else ""
    list(source = source, target = target, broken = broken, reason = reason)
  })

  writef("Done!")

  # report failures
  status <- bind(result)
  bad <- status[status$broken, ]
  if (nrow(bad) == 0)
    return(TRUE)

  caution_bullets(
    "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."
  )

}

renv_migrate_packrat_infrastructure <- function(project) {
  unlink(file.path(project, ".Rprofile"))
  renv_infrastructure_write(project)
  writef("- renv support infrastructure has been written.")
  TRUE
}


# modify.R -------------------------------------------------------------------


#' Modify a Lockfile
#'
#' Modify a project's lockfile, either interactively or non-interactively.
#'
#' After edit, if the lockfile edited is associated with the active project, any
#' state-related changes (e.g. to \R repositories) will be updated in the
#' current session.
#'
#' @inherit renv-params
#'
#' @param changes A list of changes to be merged into the lockfile.
#'   When `NULL` (the default), the lockfile is instead opened for
#'   interactive editing.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # modify an existing lockfile
#' if (interactive())
#'   renv::modify()
#'
#' }
modify <- function(project = NULL, changes = NULL) {
  renv_scope_error_handler()
  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_modify_impl(project, changes)
  invisible(project)
}

renv_modify_impl <- function(project, changes) {

  lockfile <- if (is.null(changes))
    renv_modify_interactive(project)
  else
    renv_modify_noninteractive(project, changes)

  if (renv_project_loaded(project))
    renv_modify_fini(lockfile)

}

renv_modify_interactive <- function(project) {

  # check for interactive session
  if (!interactive())
    stop("can't modify lockfile in non-interactive session")

  # resolve path to lockfile
  lockpath <- renv_lockfile_path(project)
  if (!file.exists(lockpath))
    stopf("lockfile '%s' does not exist", renv_path_aliased(lockpath))

  # copy the lockfile to a temporary file
  dir <- renv_scope_tempfile("renv-lockfile-")
  ensure_directory(dir)

  templock <- file.path(dir, "renv.lock")
  file.copy(lockpath, templock)

  # edit the temporary lockfile
  renv_file_edit(templock)

  # check that the new lockfile can be read
  withCallingHandlers(
    lockfile <- catch(renv_lockfile_read(file = templock)),
    error = function(cnd) {
      stop(lines(
        "renv was unable to parse the modified lockfile:",
        conditionMessage(cnd),
        "Your changes will be discarded"
      ))
    }
  )

  lockfile

}

renv_modify_noninteractive <- function(project, changes) {

  # resolve path to lockfile
  lockpath <- renv_lockfile_path(project)
  if (!file.exists(lockpath))
    stopf("lockfile '%s' does not exist", renv_path_aliased(lockpath))

  # read it
  lockfile <- renv_lockfile_read(file = lockpath)

  # merge changes
  merged <- overlay(lockfile, changes)

  # write updated lockfile to a temporary file
  templock <- renv_scope_tempfile("renv-lock-")
  renv_lockfile_write(merged, file = templock)

  # try reading it once more
  newlock <- renv_lockfile_read(file = templock)
  if (!identical(merged, newlock))
    stop("modify produced an invalid lockfile")

  # overwrite the original lockfile
  file.rename(templock, lockpath)

  # finish up
  merged

}

renv_modify_fini <- function(lockfile) {

  # synchronize relevant changes into the session
  repos <- lockfile$R$Repositories
  options(repos = convert(repos, "character"))

}


# mran.R ---------------------------------------------------------------------


renv_mran_enabled <- function() {
  !identical(getOption("pkgType"), "source") && config$mran.enabled()
}

renv_mran_database_path <- function() {
  renv_paths_mran("packages.rds")
}

renv_mran_database_encode <- function(database) {
  database <- as.list(database)
  encoded <- lapply(database, renv_mran_database_encode_impl)
  encoded[order(names(encoded))]
}

renv_mran_database_encode_impl <- function(entry) {

  entry <- as.list(entry)
  keys <- names(entry)
  vals <- unlist(entry)

  splat <- strsplit(keys, " ", fixed = TRUE)

  encoded <- data_frame(
    Package          = map_chr(splat, `[[`, 1L),
    Version          = map_chr(splat, `[[`, 2L),
    Date             = as.integer(vals)
  )

  encoded <- encoded[order(encoded$Package, encoded$Version), ]
  rownames(encoded) <- NULL

  encoded$Package <- as.factor(encoded$Package)
  encoded$Version <- as.factor(encoded$Version)

  encoded

}

renv_mran_database_decode <- function(encoded) {
  decoded <- lapply(encoded, renv_mran_database_decode_impl)
  list2env(decoded, parent = emptyenv())
}

renv_mran_database_decode_impl <- function(entry) {

  entry$Package <- as.character(entry$Package)
  entry$Version <- as.character(entry$Version)

  keys <- paste(entry$Package, entry$Version)
  vals <- as.list(entry$Date)
  names(vals) <- keys

  envir <- list2env(vals, parent = emptyenv())
  attr(envir, "keys") <- keys

  envir

}

renv_mran_database_save <- function(database, path = NULL) {

  path <- path %||% renv_mran_database_path()
  ensure_parent_directory(path)

  encoded <- renv_mran_database_encode(database)

  conn <- xzfile(path)
  defer(close(conn))
  saveRDS(encoded, file = conn, version = 2L)

}

renv_mran_database_load <- function(path = NULL) {

  filebacked(
    context  = "renv_mran_database_load",
    path     = path %||% renv_mran_database_path(),
    callback = renv_mran_database_load_impl
  )

}

renv_mran_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))
  }

  # otherwise, initialize a new database
  new.env(parent = emptyenv())

}

renv_mran_database_dates <- function(version, all = TRUE) {

  # release dates for old versions of R
  releases <- c(
    "3.2" = "2015-04-16",
    "3.3" = "2016-05-03",
    "3.4" = "2017-04-21",
    "3.5" = "2018-04-23",
    "3.6" = "2019-04-26",
    "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
    NULL
  )

  # find the start date
  index <- match(version, names(releases))
  if (is.na(index))
    stopf("no known release date for R %s", version)

  start <- as.Date(releases[[index]])
  if (!all)
    return(start)

  # form end date (ensure not in future)
  # we look 2 releases in the future as R builds binaries for
  # the previous releases of R as well
  end <- min(
    as.Date(releases[[index + 2L]]),
    as.Date(Sys.time(), tz = "UTC")
  )

  # generate list of dates
  seq(start, end, by = 1L)

}

renv_mran_database_key <- function(platform, version) {
  sprintf("/bin/%s/contrib/%s", platform, version)
}

renv_mran_database_update <- function(platform, version, dates = NULL) {

  # load database
  database <- renv_mran_database_load()

  # get reference to entry in database (initialize if not yet created)
  suffix <- renv_mran_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))

  for (date in dates) {

    # attempt to update our database entry for this date
    url <- renv_mran_url(date, suffix)
    tryCatch(
      renv_mran_database_update_impl(date, url, entry),
      error = warnify
    )

  }

  # save at end
  printf("[%s]: saving database ... ", date)
  renv_mran_database_save(database)
  writef("DONE")

}

renv_mran_database_update_impl <- function(date, url, entry) {

  printf("[%s]: reading 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)
  if (is.null(db)) {
    writef("ERROR")
    return(FALSE)
  }

  # insert packages into database
  for (i in seq_len(nrow(db))) {

    # construct key for index
    name <- db[i, "Package"]
    vers <- db[i, "Version"]
    key <- paste(name, vers)

    # update database
    entry[[key]] <- max(entry[[key]] %||% 0L, idate)

  }

  writef("OK")
  TRUE

}

renv_mran_url <- function(date, suffix) {
  root <- Sys.getenv("RENV_MRAN_URL", unset = "https://mran.microsoft.com/snapshot")
  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"
  Sys.getenv("RENV_MRAN_DATABASE_URL", unset = default)
}

renv_mran_database_refresh <- function(explicit = TRUE) {

  if (explicit || renv_mran_database_refresh_required())
    renv_mran_database_refresh_impl()

}

renv_mran_database_refresh_required <- function() {
  dynamic(
    key   = list(),
    value = renv_mran_database_refresh_required_impl()
  )
}

renv_mran_database_refresh_required_impl <- function() {

  # if the cache doesn't exist, we must refresh
  path <- renv_mran_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)
  if (!inherits(db, "error")) {
    keys <- names(db)
    versions <- unique(basename(keys))
    if (any(versions > getRversion()))
      return(FALSE)
  }

  # read the file mtime
  info <- renv_file_info(path)
  if (is.na(info$mtime))
    return(FALSE)

  # if it's older than a day, then we should update
  difftime(Sys.time(), info$mtime, units = "days") > 1

}

renv_mran_database_refresh_impl <- function() {

  url  <- renv_mran_database_url()
  path <- renv_mran_database_path()

  if (nzchar(url) && nzchar(path)) {
    ensure_parent_directory(path)
    download(url = url, destfile = path, quiet = TRUE)
  }

}

renv_mran_database_sync <- function(platform, version) {

  # read database
  database <- renv_mran_database_load()

  # read entry for this platform + version combo
  key <- renv_mran_database_key(platform, version)
  entry <- database[[key]]
  if (is.null(entry)) {
    database[[key]] <- new.env(parent = emptyenv())
    entry <- database[[key]]
  }

  # 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)
    last <- as.integer(date)
  }

  # get yesterday's date
  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))
  now <- min(now, max(dates))

  # if we've already in sync, nothing to do
  if (last >= now)
    return(FALSE)

  # invoke update for missing dates
  writef("==> Synchronizing MRAN 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)

  # return TRUE to indicate update occurred
  return(TRUE)

}

renv_mran_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
  )

}


# 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 ------------------------------------------------------------------


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)))

  # resolve option value
  if (!is.null(value))
    return(renv_options_resolve(value, list(key, extra)))

  # nothing found; use default
  default

}


# 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
  )
}

renv_package_find_impl <- function(package,
                                   lib.loc = renv_libpaths_all(),
                                   check.loaded = TRUE)
{
  # 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) {
    pkgpath <- file.path(libpath, package)
    descpath <- file.path(pkgpath, "DESCRIPTION")
    if (file.exists(descpath))
      return(pkgpath)
  }

  # if that failed, check to see if it's loaded and use the associated path
  if (check.loaded && package %in% loadedNamespaces()) {
    path <- renv_namespace_path(package)
    if (file.exists(path))
      return(path)
  }

  # failed to find package
  ""
}

renv_package_installed <- function(package, lib.loc = renv_libpaths_all()) {
  paths <- renv_package_find(package, lib.loc, check.loaded = FALSE)
  nzchar(paths)
}

renv_package_available <- function(package) {
  package %in% loadedNamespaces() || renv_package_installed(package)
}

renv_package_version <- function(package) {
  renv_package_description_field(package, "Version")
}

renv_package_description_field <- function(package, field) {
  path <- renv_package_find(package)
  desc <- renv_description_read(path)
  desc[[field]]
}

renv_package_type <- function(path, quiet = FALSE, default = "source") {

  info <- renv_file_info(path)
  if (is.na(info$isdir))
    stopf("no package at path '%s'", renv_path_aliased(path))

  # for directories, check for Meta
  if (info$isdir) {
    hasmeta <- file.exists(file.path(path, "Meta"))
    type <- if (hasmeta) "binary" else "source"
    return(type)
  }

  # otherwise, guess based on contents of package
  methods <- list(
    tar = function(path) untar(tarfile = path, list = TRUE),
    zip = function(path) unzip(zipfile = path, list = TRUE)$Name
  )

  # guess appropriate method when possible
  type <- renv_archive_type(path)
  if (type %in% c("tar", "zip"))
    methods <- methods[type]

  for (method in methods) {

    # suppress warnings to avoid issues with e.g.
    # 'skipping pax global extended headers' when
    # using internal tar
    files <- catch(suppressWarnings(method(path)))
    if (inherits(files, "error"))
      next

    hasmeta <- any(grepl("^[^/]+/Meta/?$", files))
    type <- if (hasmeta) "binary" else "source"
    return(type)

  }

  if (!quiet) {
    fmt <- "failed to determine type of package '%s'; assuming source"
    warningf(fmt, renv_path_aliased(path))
  }

  default

}

renv_package_priority <- function(package) {

  # treat 'R' as pseudo base package
  if (package == "R")
    return("base")

  # read priority from db
  db <- installed_packages()
  entry <- db[db$Package == package, ]
  entry$Priority %NA% ""

}

renv_package_tarball_name <- function(path) {
  desc <- renv_description_read(path)
  with(desc, sprintf("%s_%s.tar.gz", Package, Version))
}

renv_package_ext <- function(type) {

  # always use '.tar.gz' for source packages
  type <- match.arg(type, c("binary", "source"))
  if (type == "source")
    return(".tar.gz")

  # otherwise, infer appropriate extension based on platform
  case(
    renv_platform_macos()   ~ ".tgz",
    renv_platform_windows() ~ ".zip",
    renv_platform_unix()    ~ ".tar.gz"
  )

}

renv_package_pkgtypes <- function() {

  # only use binaries if the user has specifically requested it
  # and binaries are available for this installation of R
  # (users may want to install from sources explicitly to take
  # advantage of custom local compiler configurations)
  binaries <-
    !identical(.Platform$pkgType, "source") &&
    !identical(getOption("pkgType"), "source")

  if (binaries) c("binary", "source") else "source"

}

renv_package_augment <- function(installpath, record) {

  # check for remotes fields
  remotes <- record[grep("^Remote", names(record))]
  if (empty(remotes))
    return(FALSE)

  # for backwards compatibility with older versions of Packrat,
  # we write out 'Github*' fields as well
  if (identical(record$Source, "GitHub")) {

    map <- list(
      "GithubHost"     = "RemoteHost",
      "GithubRepo"     = "RemoteRepo",
      "GithubUsername" = "RemoteUsername",
      "GithubRef"      = "RemoteRef",
      "GithubSHA1"     = "RemoteSha"
    )

    enumerate(map, function(old, new) {
      remotes[[old]] <<- remotes[[old]] %||% remotes[[new]]
    })

  }

  # ensure RemoteType field is written out
  remotes$RemoteType <- remotes$RemoteType %||% renv_record_source(record)
  remotes <- remotes[c("RemoteType", renv_vector_diff(names(remotes), "RemoteType"))]

  # update package items
  renv_package_augment_description(installpath, remotes)
  renv_package_augment_metadata(installpath, remotes)

}

renv_package_augment_impl <- function(data, remotes) {
  remotes <- remotes[map_lgl(remotes, Negate(is.null))]
  nonremotes <- grep("^(?:Remote|Github)", names(data), invert = TRUE)
  remotes[["Remotes"]] <- data[["Remotes"]] %||% remotes[["Remotes"]]
  c(data[nonremotes], remotes)
}

renv_package_augment_description <- function(path, remotes) {

  descpath <- file.path(path, "DESCRIPTION")

  before <- renv_description_read(descpath)
  after <- renv_package_augment_impl(before, remotes)
  if (identical(before, after))
    return(FALSE)

  renv_dcf_write(after, file = descpath)

}

renv_package_augment_metadata <- function(path, remotes) {

  metapath <- file.path(path, "Meta/package.rds")
  if (!file.exists(metapath))
    return(FALSE)

  meta <- readRDS(metapath)
  before <- as.list(meta$DESCRIPTION)
  after <- renv_package_augment_impl(before, remotes)
  if (identical(before, after))
    return(FALSE)

  meta$DESCRIPTION <- map_chr(after, identity)
  saveRDS(meta, file = metapath, version = 2L)

}

# 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
renv_package_dependencies <- function(packages,
                                      libpaths = NULL,
                                      fields = NULL,
                                      callback = NULL,
                                      project = NULL)
{
  visited <- new.env(parent = emptyenv())
  ignored <- renv_project_ignored_packages(project = project)
  packages <- renv_vector_diff(packages, ignored)
  libpaths <- libpaths %||% renv_libpaths_all()
  fields <- fields %||% settings$package.dependency.fields(project = project)
  callback <- callback %||% function(package, location, project) location
  project <- renv_project_resolve(project)

  for (package in packages)
    renv_package_dependencies_impl(package, visited, libpaths, fields, callback, project)

  as.list(visited)
}

renv_package_dependencies_impl <- function(package,
                                           visited,
                                           libpaths,
                                           fields = NULL,
                                           callback = NULL,
                                           project = NULL)
{
  # skip the 'R' package
  if (package == "R")
    return()

  # if we've already visited this package, bail
  if (!is.null(visited[[package]]))
    return()

  # default to unknown path for visited packages
  visited[[package]] <- ""

  # find the package -- note that we perform a permissive lookup here
  # because we want to capture potentially invalid / broken package installs
  # (that is, the 'package' we find might be an incomplete or broken package
  # installation at this point)
  location <- find(libpaths, function(libpath) {
    candidate <- file.path(libpath, package)
    if (renv_file_exists(candidate))
      return(candidate)
  })

  if (is.null(location))
    return(callback(package, "", project))

  # we know the path, so set it now
  visited[[package]] <- callback(package, location, project)

  # find its dependencies from the DESCRIPTION file
  deps <- renv_dependencies_discover_description(location, fields = "strong")
  subpackages <- deps$Package
  for (subpackage in subpackages)
    renv_package_dependencies_impl(subpackage, visited, libpaths, fields, callback, project)
}

renv_package_reload <- function(package, library = NULL) {
  status <- catch(renv_package_reload_impl(package, library))
  !inherits(status, "error") && status
}

renv_package_reload_impl <- function(package, library) {

  if (renv_tests_running())
    return(FALSE)

  # record if package is attached (and, if so, where)
  name <- paste("package", package, sep = ":")
  pos <- match(name, search())

  # unload the package
  if (!is.na(pos))
    renv_package_reload_impl_searchpath(package, library, pos)
  else
    renv_package_reload_impl_namespace(package, library)

  TRUE

}

renv_package_reload_impl_searchpath <- function(package, library, pos) {

  args <- list(pos = pos, unload = TRUE, force = TRUE)
  quietly(do.call(base::detach, args), sink = FALSE)

  args <- list(package = package, pos = pos, lib.loc = library, quietly = TRUE)
  quietly(do.call(base::library, args), sink = FALSE)

}

renv_package_reload_impl_namespace <- function(package, library) {
  unloadNamespace(package)
  loadNamespace(package, lib.loc = library)
}

renv_package_hook <- function(package, hook) {
  if (package %in% loadedNamespaces())
    hook()
  else
    setHook(packageEvent(package, "onLoad"), hook)
}

renv_package_metadata <- function(package) {
  pkgpath <- renv_package_find(package)
  metapath <- file.path(pkgpath, "Meta/package.rds")
  readRDS(metapath)
}

renv_package_shlib <- function(package) {

  pkgpath <- renv_package_find(package)

  pkgname <- basename(package)
  if (pkgname == "data.table")
    pkgname <- "datatable"

  libname <- paste0(pkgname, .Platform$dynlib.ext)
  file.path(pkgpath, "libs", libname)

}

renv_package_built <- function(path) {

  info <- renv_file_info(path)

  # list files in package
  isarchive <- identical(info$isdir, FALSE)
  files <- if (isarchive)
    renv_archive_list(path)
  else
    list.files(path, full.names = TRUE, recursive = TRUE)

  # for a source package, the canonical way to determine if it has already
  # been built is the presence of a 'Packaged:' field in the DESCRIPTION file
  # ('Built:' for binary packages) but we want to avoid the overhead of
  # unpacking the package if at all possible
  pattern <- "/(?:MD5$|INDEX/|Meta/package\\.rds$)"
  matches <- grep(pattern, files)
  if (length(matches) != 0L)
    return(TRUE)

  # if the above failed, then we'll use the contents of the DESCRIPTION file
  descpaths <- grep("/DESCRIPTION$", files, value = TRUE)
  if (length(descpaths) == 0L)
    return(FALSE)

  n <- nchar(descpaths)
  descpath <- descpaths[n == min(n)]
  contents <- if (isarchive)
    renv_archive_read(path, descpath)
  else
    readLines(descpath, warn = FALSE)

  # check for signs it was built
  pattern <- "^(?:Packaged|Built):"
  matches <- grep(pattern, contents)
  if (length(matches) != 0L)
    return(TRUE)

  # does not appear to be a source package
  FALSE

}

renv_package_unpack <- function(package, path, subdir = "", force = FALSE) {

  # if this isn't an archive, nothing to do
  info <- renv_file_info(path)
  if (identical(info$isdir, TRUE))
    return(path)

  # 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)
    grep(pattern, descpaths, perl = TRUE, value = TRUE)
  } else {
    n <- nchar(descpaths)
    descpaths[n == min(n)]
  }

  # if this failed, error
  if (length(descpath) != 1L) {
    fmt <- "internal error: couldn't find DESCRIPTION file for package '%s' in archive '%s'"
    stopf(fmt, package, path)
  }

  # create extraction directory
  old <- renv_scope_tempfile("renv-package-old-")
  new <- renv_scope_tempfile("renv-package-new-", scope = parent.frame())
  ensure_directory(c(old, new))

  # decompress archive to dir
  renv_archive_decompress(path, exdir = old)

  # rename (without sub-directory)
  oldpath <- file.path(old, dirname(descpath))
  newpath <- file.path(new, package)
  file.rename(oldpath, newpath)

  # use newpath
  newpath

}


# packages.R -----------------------------------------------------------------


the$packages_base <- NULL
the$packages_recommended <- NULL

renv_packages_base <- function() {

  the$packages_base <- the$packages_base %||% {
    db <- installed_packages(lib.loc = .Library, priority = "base")
    c("R", db$Package, "translations")
  }

}

renv_packages_recommended <- function() {

  the$packages_recommended <- the$packages_recommended %||% {
    db <- installed_packages(lib.loc = .Library, priority = "recommended")
    db$Package
  }

}


# pak.R ----------------------------------------------------------------------


# the minimum-required version of 'pak' for renv integration
the$pak_minver <- numeric_version("0.5.1")

renv_pak_init <- function(stream = NULL, force = FALSE) {

  stream <- stream %||% renv_pak_stream()
  if (force || !renv_pak_available())
    renv_pak_init_impl(stream)

  renv_namespace_load("pak")

}

renv_pak_stream <- function() {

  # check if stable is new enough
  streams <- c("stable", "rc", "devel")
  for (stream in streams) {
    repos <- renv_pak_repos(stream)
    latest <- renv_available_packages_latest("pak", repos = repos)
    version <- numeric_version(latest$Version)
    if (version >= the$pak_minver)
      return(stream)
  }

  fmt <- "internal error: pak (>= %s) is not available"
  stopf(fmt, format(the$pak_minver))

}

renv_pak_available <- function() {
  tryCatch(
    packageVersion("pak") >= the$pak_minver,
    error = function(e) FALSE
  )
}

renv_pak_repos <- function(stream) {

  # on macOS, we can only use pak binaries with CRAN R
  if (renv_platform_macos() && .Platform$pkgType == "source")
    return(getOption("repos"))

  # otherwise, use pre-built pak binaries
  fmt <- "https://r-lib.github.io/p/pak/%s/%s/%s/%s"
  sprintf(fmt, stream, .Platform$pkgType, version$os, version$arch)

}

renv_pak_init_impl <- function(stream) {

  repos <- c("r-lib" = renv_pak_repos(stream))
  renv_scope_options(renv.config.pak.enabled = FALSE, repos = repos)

  library <- renv_libpaths_active()
  install("pak", library = library)
  loadNamespace("pak", lib.loc = library)

}

renv_pak_install <- function(packages, library, project) {

  pak <- renv_namespace_load("pak")
  lib <- library[[1L]]

  # transform repositories
  if (renv_ppm_enabled()) {
    repos <- getOption("repos")
    renv_scope_options(repos = renv_ppm_transform(repos))
  }

  # make sure pak::pkg_install() still works even if we're
  # running in renv with devtools::load_all()
  name <- Sys.getenv("_R_CHECK_PACKAGE_NAME_", unset = NA)
  if (identical(name, "renv"))
    renv_scope_envvars("_R_CHECK_PACKAGE_NAME_" = NULL)

  # if we received a named list of remotes, use the names
  packages <- if (any(nzchar(names(packages))))
     names(packages)
  else
    as.character(packages)

  if (length(packages) == 0L)
    return(pak$local_install_dev_deps(root = project, lib = lib))

  pak$pkg_install(
    pkg     = packages,
    lib     = lib,
    upgrade = TRUE
  )

}

renv_pak_restore <- function(lockfile,
                             packages = NULL,
                             exclude = NULL,
                             project = NULL)
{
  pak <- renv_namespace_load("pak")

  # transform repositories
  if (renv_ppm_enabled()) {
    repos <- getOption("repos")
    renv_scope_options(repos = renv_ppm_transform(repos))
  }

  # make sure pak::pkg_install() still works even if we're
  # running in renv with devtools::load_all()
  name <- Sys.getenv("_R_CHECK_PACKAGE_NAME_", unset = NA)
  if (identical(name, "renv"))
    renv_scope_envvars("_R_CHECK_PACKAGE_NAME_" = NULL)

  # get records to install
  records <- renv_lockfile_records(lockfile)
  packages <- setdiff(packages %||% names(records), c(exclude, "pak", "renv"))
  records <- records[packages]

  # attempt to link packages that have cache entries
  if (renv_cache_config_enabled(project = project)) {
    linked <- map_lgl(records, renv_cache_synchronize)
    records <- records[!linked]
  }

  # convert into specs compatible with pak, and install
  remotes <- map_chr(records, renv_record_format_remote)

  # TODO: We previously tried converting version-ed remotes into "plain" remotes
  # if the package version happened to be current, but then 'pak' would choose
  # not to install the package if a newer version was available. Hence, we need
  # to preserve the exact remote we wish to install here.

  # return early if there are zero remotes to restore
  if (length(remotes) == 0L) {
    return(invisible(TRUE))
  }

  # perform installation
  pak$pkg_install(remotes)
}



# parallel.R -----------------------------------------------------------------


renv_parallel_cores <- function() {

  if (renv_platform_windows())
    return(1L)

  value <- config$updates.parallel()
  case(
    identical(value, TRUE)  ~ getOption("mc.cores", default = 2L),
    identical(value, FALSE) ~ 1L,
    ~ as.integer(value)
  )

}

renv_parallel_exec <- function(data, callback) {
  cores <- renv_parallel_cores()
  if (cores > 1)
    parallel::mclapply(data, callback, mc.cores = cores)
  else
    lapply(data, callback)
}


# parse.R --------------------------------------------------------------------


renv_parse_file <- function(file = "", ...) {
  if (nzchar(file)) {
    renv_scope_options(warn = -1L)
    text <- readLines(file, warn = FALSE, encoding = "UTF-8")
    renv_parse_impl(text, srcfile = file, ...)
  }
}

renv_parse_text <- function(text = NULL, ...) {
  if (is.character(text)) {
    renv_parse_impl(text, ...)
  }
}

renv_parse_impl <- function(text, ...) {

  # save default encoding
  enc <- Encoding(text)

  # disable warnings + encoding conversions
  renv_scope_options(
    warn     = 1L,
    encoding = "native.enc"
  )

  # attempt multiple parse methods
  methods <- list(
    renv_parse_impl_asis,
    renv_parse_impl_native,
    renv_parse_impl_utf8
  )

  # attempt with different guessed encodings
  encodings <- c("UTF-8", "unknown")

  for (encoding in encodings) {
    Encoding(text) <- encoding
    for (method in methods) {
      parsed <- catch(method(text, ...))
      if (!inherits(parsed, "error"))
        return(parsed)
    }
  }

  # if these all fail, then just try the default
  # parse and let the error propagate
  defer(Sys.setlocale())
  Encoding(text) <- enc
  parse(text = text, ...)

}

renv_parse_impl_asis <- function(text, ...) {
  defer(Sys.setlocale())
  parse(text = text, ...)
}

renv_parse_impl_native <- function(text, ...) {
  defer(Sys.setlocale())
  parse(text = enc2native(text), encoding = "unknown", ...)
}

renv_parse_impl_utf8 <- function(text, ...) {
  defer(Sys.setlocale())
  parse(text = enc2utf8(text), encoding = "UTF-8", ...)
}



# patch.R --------------------------------------------------------------------


renv_patch_init <- function() {
  renv_patch_rprofile()
  renv_patch_tar()
  renv_patch_repos()
  renv_patch_golem()
  renv_patch_methods_table()
}

renv_patch_rprofile <- function() {

  # resolve path to user profile
  path <- Sys.getenv("R_PROFILE_USER", unset = "~/.Rprofile")
  info <- renv_file_info(path)
  if (!identical(info$isdir, FALSE))
    return(FALSE)

  # if the .Rprofile is empty, do nothing
  if (info$size == 0)
    return(TRUE)

  # check for trailing newline
  data <- readBin(path, raw(), n = info$size)
  if (empty(data))
    return(TRUE)

  last <- data[length(data)]
  endings <- as.raw(c(0x0a, 0x0d))
  if (last %in% endings)
    return(TRUE)

  # if it's missing, inform the user
  warningf("%s is missing a trailing newline", renv_path_pretty(path))
  FALSE

}

renv_patch_tar <- function() {

  # read value of TAR
  tar <- Sys.getenv("TAR", unset = "")

  # on Windows, if TAR is unset, then force the usage
  # of R's internal tar implementation. this is done to
  # avoid issues where e.g. versions of tar which do not
  # understand Windows paths are on the PATH
  #
  # https://github.com/rstudio/renv/issues/521
  if (renv_platform_windows() && !nzchar(tar)) {
    Sys.setenv(TAR = "internal")
    return(TRUE)
  }

  # otherwise, allow empty / internal tars
  if (tar %in% c("", "internal"))
    return(TRUE)

  # the user (or R itself) has set the TAR environment variable
  # validate that it exists (resolve from PATH)
  #
  # note that the user can set TAR to be a full command; e.g.
  #
  #    TAR = /path/to/tar --force-local
  #
  # so we need to handle that case appropriately
  whitespace <- gregexpr("(?:\\s+|$)", tar, perl = TRUE)[[1L]]
  for (index in whitespace) {
    candidate <- substring(tar, 1L, index - 1L)
    resolved <- Sys.which(candidate)
    if (nzchar(resolved))
      return(TRUE)
  }

  # TAR appears to be set but invalid; override it
  # and warn the user
  newtar <- Sys.which("tar")
  if (!nzchar(newtar))
    newtar <- "internal"

  Sys.setenv(TAR = newtar)

  # report to the user
  fmt <- "requested TAR '%s' does not exist; using '%s' instead"
  warningf(fmt, tar, newtar)

}

renv_patch_golem <- function() {
  renv_package_hook("golem", renv_patch_golem_impl)
}

renv_patch_golem_impl <- function(...) {

  if (packageVersion("golem") != "0.2.1")
    return()

  golem <- getNamespace("golem")

  replacement <- function(file, pattern, replace) {

    # skip .rds files
    if (grepl("[.]rds$", file))
      return()

    # skip files containing nul bytes
    info <- renv_file_info(file)
    bytes <- readBin(file, "raw", info$size)
    if (any(bytes == 0L))
      return()

    # otherwise, attempt replacement
    old <- readLines(file)
    new <- gsub(pattern, replace, old)
    writeLines(new, con = file)

  }

  environment(replacement) <- golem

  if ("compiler" %in% loadedNamespaces())
    replacement <- compiler::cmpfun(replacement)

  renv_binding_replace(golem, "replace_word", replacement)

}

renv_patch_methods_table <- function() {
  catchall(renv_patch_methods_table_impl())
}

renv_patch_methods_table_impl <- function() {

  # ensure promises in S3 methods table are forced
  # https://bugs.r-project.org/bugzilla/show_bug.cgi?id=16644
  for (envir in list(.BaseNamespaceEnv, renv_namespace_load("utils"))) {

    # unlock binding if it's locked
    binding <- ".__S3MethodsTable__."
    base <- baseenv()
    if (base$bindingIsLocked(binding, env = envir)) {
      base$unlockBinding(binding, env = envir)
      defer(base$lockBinding(binding, envir))
    }

    # force everything defined in the environment
    table <- envir[[binding]]
    for (key in ls(envir = table, all.names = TRUE))
      table[[key]] <- force(table[[key]])

  }

}

# puts the current version of renv into an on-disk package repository,
# so that packages using renv can find this version of renv in tests
# this helps renv survive CRAN revdep checks (e.g. jetpack)
renv_patch_repos <- function() {

  # nothing to do in embedded mode
  if (renv_metadata_embedded())
    return()

  # nothing to do if we're not running tests
  checking <- checking()
  if (!checking)
    return()

  # nothing to do if we're running our own tests
  name <- Sys.getenv("_R_CHECK_PACKAGE_NAME_", unset = NA)
  if (identical(name, "renv"))
    return()

  # presumably this will never happen when the dev version of renv is
  # installed, so we skip to avoid parsing a sha as version
  sha <- attr(the$metadata$version, "sha")
  if (!is.null(sha))
    return()

  # nothing to do if this version of 'renv' is already available
  version <- renv_metadata_version()
  entry <- catch(renv_available_packages_entry("renv", filter = version, quiet = TRUE))
  if (!inherits(entry, "error"))
    return()

  # check if we've already set repos
  if ("RENV" %in% names(getOption("repos")))
    return()

  # use package-local repository path
  repopath <- system.file("repos", package = "renv", mustWork = FALSE)
  if (!file.exists(repopath))
    return()

  # update our repos option
  fmt <- if (renv_platform_windows()) "file:///%s" else "file://%s"
  repourl <- sprintf(fmt, repopath)

  # renv needs to be first so the right version is found?
  repos <- c(RENV = repourl, getOption("repos"))
  names(repos) <- make.names(names(repos))
  options(repos = repos)

  # make sure these repositories are used in restore too
  options(renv.config.repos.override = repos)

}


# path.R ---------------------------------------------------------------------


the$alpha <- c(letters, LETTERS)

renv_path_absolute <- function(path) {

  substr(path, 1L, 1L) %in% c("~", "/", "\\") || (
    substr(path, 1L, 1L) %in% the$alpha &&
    substr(path, 2L, 3L) %in% c(":/", ":\\")
  )

}

renv_path_aliased <- function(path) {

  home <- Sys.getenv("HOME", unset = Sys.getenv("R_USER"))
  if (!nzchar(home))
    return(path)

  home <- gsub("\\", "/", home, fixed = TRUE)
  path <- gsub("\\", "/", path, fixed = TRUE)

  match <- regexpr(home, path, fixed = TRUE, useBytes = TRUE)
  path[match == 1L] <- file.path("~", substring(path[match == 1L], nchar(home) + 2L))

  path

}

renv_path_within <- function(path, parent) {
  path <- renv_path_canonicalize(path)
  prefix <- paste(renv_path_canonicalize(parent), "/", sep = "")
  path == parent | substring(path, 1L, nchar(prefix)) == prefix
}

renv_path_normalize <- function(path, winslash = "/", mustWork = FALSE) {
  if (renv_platform_unix())
    renv_path_normalize_unix(path, winslash, mustWork)
  else
    renv_path_normalize_win32(path, winslash, mustWork)
}

renv_path_normalize_unix <- function(path,
                                     winslash = "/",
                                     mustWork = FALSE)
{
  # force paths to be absolute
  bad <- !map_lgl(path, renv_path_absolute)
  if (any(bad)) {
    prefix <- normalizePath(".", winslash = winslash)
    path[bad] <- paste(prefix, path[bad], sep = winslash)
  }

  # normalize the expanded paths
  normalizePath(path, winslash, mustWork)
}

# NOTE: in versions of R < 4.0.0, normalizePath() does not normalize path
# casing; e.g. normalizePath("~/MyPaTh") will not normalize to "~/MyPath"
# (assuming that is the "true" underlying casing on the filesystem)
#
# we work around this by round-tripping between the short name and
# the long name, as Windows then has no choice but to figure out
# the correct casing for us
#
# this isn't 100% reliable (not all paths have a short-path equivalent)
# but seems to be good enough in practice ...
#
# except that, if the path contains characters that cannot be represented in the
# current encoding, then attempting to normalize the short version of that path
# will fail -- so if the path is already UTF-8, then we need to avoid
# round-tripping through the short path.
#
# furthermore, it appears that shortPathName() can mis-encode its result for
# strings marked with latin1 encoding?
#
# https://github.com/rstudio/renv/issues/629
renv_path_normalize_win32 <- function(path,
                                      winslash = "/",
                                      mustWork = FALSE)
{

  # see the NOTE above, this workaround is only necessary for R < 4.0.0,
  # and it complicates things unnecessarily
  if (getRversion() >= "4.0.0")
    return(renv_path_normalize_unix(path, winslash, mustWork))

  # get encoding for this set of paths
  enc <- Encoding(path)

  # perform separate operations for each
  utf8    <- enc == "UTF-8"
  latin1  <- enc == "latin1"
  unknown <- enc == "unknown"

  # normalize based on their encoding
  path[utf8]    <- normalizePath(path[utf8], winslash, mustWork)
  path[latin1]  <- normalizePath(path[latin1], winslash, mustWork)
  path[unknown] <- renv_path_normalize_win32_impl(path[unknown], winslash, mustWork)

  # return resulting path
  path
}

renv_path_normalize_win32_impl <- function(path,
                                           winslash = "/",
                                           mustWork = FALSE)
{
  # get short path
  expanded <- path.expand(path)
  short <- utils::shortPathName(expanded)

  # if a UTF-8 string is passed to utils::shortPathName(), it seems that
  # the string might be latin1-encoded, even though it's marked as UTF-8?
  if (!identical(R.version$crt, "ucrt")) {
    utf8 <- Encoding(short) == "UTF-8"
    Encoding(short[utf8]) <- "latin1"
  }

  # normalize
  normalizePath(short, winslash, mustWork)
}

# TODO: this is a lie; for existing paths symlinks will be resolved.
# don't use this for paths that need to be uniquely resolved!
renv_path_canonicalize <- function(path) {
  parent <- dirname(path)
  root <- renv_path_normalize(parent)
  trimmed <- sub("/+$", "", root)
  file.path(trimmed, basename(path))
}

renv_path_same <- function(lhs, rhs) {
  renv_path_canonicalize(lhs) == renv_path_canonicalize(rhs)
}

# get the nth path component from the end of the path
renv_path_component <- function(path, index = 1) {
  splat <- strsplit(path, "[/\\]+")
  map_chr(splat, function(parts) parts[length(parts) - index + 1])
}

renv_path_pretty <- function(path) {
  renv_json_quote(renv_path_aliased(path))
}

renv_path_relative <- function(path, root) {
  within <- startswith(path, root)
  path[within] <- substring(path[within], nchar(root) + 2L)
  path
}



# paths.R --------------------------------------------------------------------


the$root <- NULL

renv_paths_override <- function(name) {

  # # check for value from option
  # optname <- paste("renv.paths", name, sep = ".")
  # optval <- getOption(optname)
  # if (!is.null(optval))
  #   return(optval)

  # check for value from envvar
  envname <- paste("RENV_PATHS", toupper(name), sep = "_")
  envval  <- Sys.getenv(envname, unset = NA)
  if (!is.na(envval))
    return(envval)

}

renv_paths_common <- function(name, prefixes = NULL, ...) {

  # check for single absolute path supplied by user
  # TODO: handle multiple?
  end <- file.path(...)
  if (length(end) == 1 && renv_path_absolute(end))
    return(end)

  # check for path provided via option
  root <- renv_paths_override(name) %||% renv_paths_root(name)

  # split path entries containing a separator
  if (name %in% c("cache", "local", "cellar")) {
    pattern <- if (renv_platform_windows()) "[;]" else "[;:]"
    root <- strsplit(root, pattern)[[1L]]
  }

  # form rest of path
  prefixed <- if (length(prefixes))
    file.path(root, paste(prefixes, collapse = "/"))
  else
    root

  path <- file.path(prefixed, ...)
  if (length(path)) path else ""
}

renv_paths_library_root <- function(project) {
  renv_bootstrap_library_root(project)
}

renv_paths_library <- function(..., project = NULL) {
  project <- renv_project_resolve(project)
  root <- renv_paths_library_root(project)
  file.path(root, renv_platform_prefix(), ...) %||% ""
}

renv_paths_lockfile <- function(project = NULL) {

  # allow override
  # TODO: profiles?
  override <- Sys.getenv("RENV_PATHS_LOCKFILE", unset = NA)
  if (!is.na(override)) {
    last <- substr(override, nchar(override), nchar(override))
    if (last %in% c("/", "\\"))
      override <- paste0(override, "renv.lock")
    return(override)
  }

  # otherwise, use default location (location location relative to renv folder)
  project <- renv_project_resolve(project)
  renv <- renv_paths_renv(project = project)
  file.path(dirname(renv), "renv.lock")

}

renv_paths_settings <- function(project = NULL) {
  renv_paths_renv("settings.json", project = project)
}

renv_paths_activate <- function(project = NULL) {
  renv_paths_renv("activate.R", profile = FALSE, project = project)
}

renv_paths_sandbox <- function(project = NULL) {

  # construct a platform prefix
  path <- R()
  hash <- memoize(path, renv_hash_text(path), scope = "renv_paths_sandbox")
  parts <- c(renv_platform_prefix(), substring(hash, 1L, 8L))
  prefix <- paste(parts, collapse = "/")

  # check for override
  root <- Sys.getenv("RENV_PATHS_SANDBOX", unset = NA)
  if (!is.na(root))
    return(paste(c(root, prefix), collapse = "/"))

  # otherwise, build path in user data directory
  userdir <- renv_bootstrap_user_dir()
  paste(c(userdir, "sandbox", prefix), collapse = "/")

}

renv_paths_renv <- function(..., profile = TRUE, project = NULL) {
  renv_bootstrap_paths_renv(..., profile = profile, project = project)
}

renv_paths_cellar <- function(...) {
  renv_paths_common("cellar", c(), ...)
}

renv_paths_local <- function(...) {
  renv_paths_common("local", c(), ...)
}

renv_paths_source <- function(...) {
  renv_paths_common("source", c(), ...)
}

renv_paths_binary <- function(...) {
  renv_paths_common("binary", c(renv_platform_prefix()), ...)
}

renv_paths_cache <- function(..., version = NULL) {
  platform <- renv_platform_prefix()
  version <- version %||% renv_cache_version()
  renv_paths_common("cache", c(version, platform), ...)
}

renv_paths_rtools <- function() {

  root <- renv_paths_override("rtools")
  if (is.null(root)) {
    spec <- renv_rtools_find()
    root <- spec$root
  }

  root %||% ""
}

renv_paths_extsoft <- function(...) {
  renv_paths_common("extsoft", c(), ...)
}

renv_paths_mran <- function(...) {
  renv_paths_common("mran", c(), ...)
}

renv_paths_index <- function(...) {
  renv_paths_common("index", c(renv_platform_prefix()), ...)
}


renv_paths_root <- function(...) {
  root <- renv_paths_override("root") %||% renv_paths_root_default()
  file.path(root, ...) %||% ""
}

# nocov start
renv_paths_root_default <- function() {

  the$root <- the$root %||% {

    # use tempdir for cache when running tests
    # this check is necessary here to support packages which might use renv
    # during testing (and we don't want those to try to use the user dir)
    if (checking())
      renv_paths_root_default_tempdir()
    else
      renv_paths_root_default_impl()

  }

}

renv_paths_root_default_impl <- function() {

  # compute known root directories
  roots <- c(
    renv_paths_root_default_impl_v2(),
    renv_paths_root_default_impl_v1()
  )

  # iterate through those roots, finding the first existing
  for (root in roots)
    if (file.exists(root))
      return(root)

  # if none exist, choose the most recent definition
  roots[[1L]]

}

renv_paths_root_default_impl_v2 <- function() {

  # try using tools to get the user directory
  tools <- renv_namespace_load("tools")
  if (is.function(tools$R_user_dir))
    return(tools$R_user_dir("renv", "cache"))

  renv_paths_root_default_impl_v2_fallback()

}

renv_paths_root_default_impl_v2_fallback <- function() {

  # try using our own backfill for older versions of R
  envvars <- c("R_USER_CACHE_DIR", "XDG_CACHE_HOME")
  for (envvar in envvars) {
    root <- Sys.getenv(envvar, unset = NA)
    if (!is.na(root)) {
      path <- file.path(root, "R/renv")
      return(path)
    }
  }

  # use platform-specific default fallbacks
  if (renv_platform_windows())
    file.path(Sys.getenv("LOCALAPPDATA"), "R/cache/R/renv")
  else if (renv_platform_macos())
    "~/Library/Caches/org.R-project.R/R/renv"
  else
    "~/.cache/R/renv"

}

renv_paths_root_default_impl_v1 <- function() {

  base <- switch(
    Sys.info()[["sysname"]],
    Darwin  = Sys.getenv("XDG_DATA_HOME", "~/Library/Application Support"),
    Windows = Sys.getenv("LOCALAPPDATA", Sys.getenv("APPDATA")),
    Sys.getenv("XDG_DATA_HOME", "~/.local/share")
  )

  file.path(base, "renv")

}

renv_paths_root_default_tempdir <- function() {
  temp <- file.path(tempdir(), "renv")
  ensure_directory(temp)
  return(temp)
}

# nocov end

#' Path for storing global state
#'
#' @description
#' By default, renv stores global state in the following OS-specific folders:
#'
#' \tabular{ll}{
#' **Platform** \tab **Location** \cr
#' Linux        \tab `~/.cache/R/renv` \cr
#' macOS        \tab `~/Library/Caches/org.R-project.R/R/renv` \cr
#' Windows      \tab `%LOCALAPPDATA%/R/cache/R/renv` \cr
#' }
#'
#' If desired, this path can be customized by setting the `RENV_PATHS_ROOT`
#' environment variable. This can be useful if you'd like, for example, multiple
#' users to be able to share a single global cache.
#'
#' # Customising individual paths
#'
#' The various state sub-directories can also be individually adjusted, if so
#' desired (e.g. you'd prefer to keep the cache of package installations on a
#' separate volume). The various environment variables that can be set are
#' enumerated below:
#'
#' \tabular{ll}{
#' \strong{Environment Variable}     \tab \strong{Description} \cr
#' \code{RENV_PATHS_ROOT}            \tab The root path used for global state storage. \cr
#' \code{RENV_PATHS_LIBRARY}         \tab The path to the project library. \cr
#' \code{RENV_PATHS_LIBRARY_ROOT}    \tab The parent path for project libraries. \cr
#' \code{RENV_PATHS_LIBRARY_STAGING} \tab The parent path used for staged package installs. \cr
#' \code{RENV_PATHS_SANDBOX}         \tab The path to the sandboxed \R system library. \cr
#' \code{RENV_PATHS_LOCKFILE}        \tab The path to the [lockfile]. \cr
#' \code{RENV_PATHS_CELLAR}          \tab The path to the cellar, containing local package binaries and sources. \cr
#' \code{RENV_PATHS_SOURCE}          \tab The path containing downloaded package sources. \cr
#' \code{RENV_PATHS_BINARY}          \tab The path containing downloaded package binaries. \cr
#' \code{RENV_PATHS_CACHE}           \tab The path containing cached package installations. \cr
#' \code{RENV_PATHS_PREFIX}          \tab An optional prefix to prepend to the constructed library / cache paths. \cr
#' \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
#' you add these to an appropriate \R startup file. For example, these could be
#' set in: a project-local `.Renviron`, the user-level `.Renviron`, or a
#' site-wide file at `file.path(R.home("etc"), "Renviron.site")`. See
#' [Startup] for more details).
#'
#' Note that renv will append platform-specific and version-specific entries
#' to the set paths as appropriate. For example, if you have set:
#'
#' ```
#' Sys.setenv(RENV_PATHS_CACHE = "/mnt/shared/renv/cache")
#' ```
#'
#' then the directory used for the cache will still depend on the renv cache
#' version (e.g. `v2`), the \R version (e.g. `3.5`) and the platform (e.g.
#' `x86_64-pc-linux-gnu`). For example:
#'
#' ```
#' /mnt/shared/renv/cache/v2/R-3.5/x86_64-pc-linux-gnu
#' ```
#'
#' This ensures that you can set a single `RENV_PATHS_CACHE` environment variable
#' globally without worry that it may cause collisions or errors if multiple
#' versions of \R needed to interact with the same cache.
#'
#' If reproducibility of a project is desired on a particular machine, it is
#' highly recommended that the renv cache of installed packages + binary
#' packages is backed up and persisted, so that packages can be easily restored
#' in the future -- installation of packages from source can often be arduous.
#'
#' # Sharing state across operating systems
#'
#' If you need to share the same cache with multiple different Linux operating
#' systems, you may want to set the `RENV_PATHS_PREFIX` environment variable
#' to help disambiguate the paths used on Linux. For example, setting
#' `RENV_PATHS_PREFIX = "ubuntu-bionic"` would instruct renv to construct a
#' cache path like:
#'
#' ```
#' /mnt/shared/renv/cache/v2/ubuntu-bionic/R-3.5/x86_64-pc-linux-gnu
#' ```
#'
#' If this is required, it's strongly recommended that this environment
#' variable is set in your \R installation's `Renviron.site` file, typically
#' located at `file.path(R.home("etc"), "Renviron.site")`, so that it can be
#' active for any \R sessions launched on that machine.
#'
#' Starting from `renv 0.13.0`, you can also instruct renv to auto-generate
#' an OS-specific component to include as part of library and cache paths,
#' by setting the environment variable:
#'
#' ```
#' RENV_PATHS_PREFIX_AUTO = TRUE
#' ```
#'
#' The prefix will be constructed based on fields within the system's
#' `/etc/os-release` file.
#'
#' # Package cellar
#'
#' If your project depends on one or \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
#' package sources should be placed in a file at one of these locations:
#'
#' - `${RENV_PATHS_CELLAR}/<package>_<version>.<ext>`
#' - `${RENV_PATHS_CELLAR}/<package>/<package>_<version>.<ext>`
#' - `<project>/renv/cellar/<package>_<version>.<ext>`
#' - `<project>/renv/cellar/<package>/<package>_<version>.<ext>`
#'
#' where `.<ext>` is `.tar.gz` for source packages, or `.tgz` for binaries on
#' macOS and `.zip` for binaries on Windows. During `restore()`, renv will
#' search the cellar for a compatible package, and prefer installation with
#' that copy of the package if appropriate.
#'
#' # Older versions
#'
#' Older version of renv used a different default cache location.
#' Those cache locations are:
#'
#' \tabular{ll}{
#' **Platform** \tab **Location** \cr
#' Linux        \tab `~/.local/share/renv` \cr
#' macOS        \tab `~/Library/Application Support/renv` \cr
#' Windows      \tab `%LOCALAPPDATA%/renv` \cr
#' }
#'
#' If an renv root directory has already been created in one of the old
#' locations, that will still be used. This change was made to comply with the
#' CRAN policy requirements of \R packages.
#'
#' @rdname paths
#' @name paths
#'
#' @format NULL
#'
#' @export
#'
#' @examples
#' # get the path to the project library
#' path <- renv::paths$library()
paths <- list(
  root     = renv_paths_root,
  library  = renv_paths_library,
  lockfile = renv_paths_lockfile,
  settings = renv_paths_settings,
  cache    = renv_paths_cache,
  sandbox  = renv_paths_sandbox
)


# pip.R ----------------------------------------------------------------------


pip_freeze <- function(..., python = NULL) {
  python <- python %||% renv_python_active()
  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()
  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()

  file <- renv_scope_tempfile("renv-requirements-", fileext = ".txt")
  writeLines(requirements, con = file)

  renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1")
  python <- renv_path_canonicalize(python)
  args <- c("-m", "pip", "install", "--upgrade", "-r", renv_shell_path(file))
  action <- "restoring Python packages"
  renv_system_exec(python, args, action, ...)

}

pip_uninstall <- function(modules, ..., python = NULL) {

  python <- python %||% renv_python_active()

  renv_scope_envvars(PIP_DISABLE_PIP_VERSION_CHECK = "1")
  python <- renv_path_canonicalize(python)
  args <- c("-m", "pip", "uninstall", "--yes", modules)
  action <- paste("uninstalling", paste(shQuote(modules), collapse = ", "))
  renv_system_exec(python, args, action, ...)

  TRUE

}


# platform.R -----------------------------------------------------------------


the$sysinfo <- NULL

renv_platform_init <- function() {
  the$sysinfo <- Sys.info()
}

renv_platform_unix <- function() {
  .Platform$OS.type == "unix"
}

renv_platform_windows <- function() {
  .Platform$OS.type == "windows"
}

renv_platform_macos <- function() {
  the$sysinfo[["sysname"]] == "Darwin"
}

renv_platform_linux <- function() {
  the$sysinfo[["sysname"]] == "Linux"
}

renv_platform_solaris <- function() {
  the$sysinfo[["sysname"]] == "SunOS"
}

renv_platform_wsl <- function() {

  pv <- "/proc/version"
  if (!file.exists(pv))
    return(FALSE)

  renv_scope_options(warn = -1L)
  contents <- catch(readLines(pv, warn = FALSE))
  if (inherits(contents, "error"))
    return(FALSE)

  any(grepl("(?:Microsoft|WSL)", contents, ignore.case = TRUE))

}

renv_platform_prefix <- function() {
  renv_bootstrap_platform_prefix()
}

renv_platform_os <- function() {
  renv_bootstrap_platform_os()
}

renv_platform_machine <- function() {
  the$sysinfo[["machine"]]
}


# ppm.R ----------------------------------------------------------------------


renv_ppm_normalize <- function(url) {
  sub("/__[^_]+__/[^/]+/", "/", url)
}

renv_ppm_transform <- function(repos = getOption("repos")) {
  map_chr(repos, function(url) {
    tryCatch(
      renv_ppm_transform_impl(url),
      error = function(e) url
    )
  })
}

renv_ppm_transform_impl <- function(url) {

  # if this function is being called as part of `install(..., type = "source')`
  # then we want to transform binary URLs to source URLs here
  if (identical(the$install_pkg_type, "source"))
    return(renv_ppm_normalize(url))

  # repository URL transformation is only necessary on Linux
  os <- renv_ppm_os()
  if (!identical(os, "__linux__"))
    return(url)

  # check for a known platform
  platform <- renv_ppm_platform()
  if (is.null(platform))
    return(url)

  # don't transform non-https URLs
  if (!grepl("^https?://", url))
    return(url)

  # if this already appears to be a binary URL, then avoid
  # transforming it
  if (grepl("/__[^_]+__/", url))
    return(url)

  # try to parse the repository URL
  parts <- catch(renv_url_parse(url))
  if (inherits(parts, "error"))
    return(url)

  # only attempt to transform URLs that are formatted like PPM urls:
  #
  #   https://ppm.company.org/cran/checkpoint/id
  #
  # in particular, there should be at least two trailing
  # alphanumeric path components
  pattern <- "/[^/]+/[^/]+"
  if (!grepl(pattern, parts$path))
    return(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))
  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"
  )

  if (sub("/+$", "", url) %in% sub("/+$", "", ignored))
    return(url)

  # if this is a 'known' PPM instance, then skip the query step
  known <- c(
    dirname(dirname(config$ppm.url())),
    getOption("renv.ppm.repos", default = NULL)
  )

  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?
  base <- dirname(dirname(url))
  status <- catch(renv_ppm_status(base))
  if (inherits(status, "error"))
    return(url)

  # iterate through distros and check for a match
  for (distro in status$distros) {

    ok <-
      identical(distro$binaryURL, platform) &&
      identical(distro$binaries, TRUE)

    if (ok) {
      parts <- c(dirname(url), "__linux__", platform, basename(url))
      binurl <- paste(parts, collapse = "/")
      return(binurl)
    }

  }

  # no match; return url as-is
  url

}

renv_ppm_status <- function(base) {
  memoize(
    key   = base,
    value = catch(renv_ppm_status_impl(base))
  )
}

renv_ppm_status_impl <- function(base) {

  # use a shorter delay to avoid hanging a session
  renv_scope_options(
    renv.config.connect.timeout = 10L,
    renv.config.connect.retry   = 1L
  )

  # attempt the download
  endpoint <- file.path(base, "__api__/status")
  destfile <- renv_scope_tempfile("renv-ppm-status-", fileext = ".json")
  quietly(download(endpoint, destfile))

  # read the downloaded JSON
  renv_json_read(destfile)

}

renv_ppm_platform <- function(file = "/etc/os-release") {

  platform <- Sys.getenv("RENV_PPM_PLATFORM", unset = NA)
  if (!is.na(platform))
    return(platform)

  platform <- Sys.getenv("RENV_RSPM_PLATFORM", unset = NA)
  if (!is.na(platform))
    return(platform)

  if (renv_platform_windows())
    return("windows")

  if (renv_platform_macos())
    return("macos")

  renv_ppm_platform_impl(file)

}

renv_ppm_platform_impl <- function(file = "/etc/os-release") {

  if (file.exists(file)) {

    properties <- renv_properties_read(
      path      = file,
      delimiter = "=",
      dequote   = TRUE
    )

    id <- properties$ID %||% ""

    case(
      identical(id, "ubuntu")    ~ renv_ppm_platform_ubuntu(properties),
      identical(id, "centos")    ~ renv_ppm_platform_centos(properties),
      identical(id, "rhel")      ~ renv_ppm_platform_rhel(properties),
      identical(id, "rocky")     ~ renv_ppm_platform_rocky(properties),
      identical(id, "almalinux") ~ renv_ppm_platform_alma(properties),
      grepl("suse\\b", id)       ~ renv_ppm_platform_suse(properties),
      identical(id, "sles")      ~ renv_ppm_platform_sles(properties),
      identical(id, "debian")    ~ renv_ppm_platform_debian(properties),
      identical(id, "amzn")      ~ renv_ppm_platform_amzn(properties)
    )

  }

}

renv_ppm_platform_ubuntu <- function(properties) {

  codename <- properties$VERSION_CODENAME
  if (is.null(codename))
    return(NULL)

  codename

}

renv_ppm_platform_centos <- function(properties) {

  id <- properties$VERSION_ID
  if (is.null(id))
    return(NULL)

  paste0("centos", substring(id, 1L, 1L))

}

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))

}

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))

}

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))

}

renv_ppm_platform_suse <- function(properties) {

  id <- properties$VERSION_ID
  if (is.null(id))
    return(NULL)

  parts <- strsplit(id, ".", fixed = TRUE)[[1L]]
  paste0("opensuse", parts[[1L]], parts[[2L]])

}

renv_ppm_platform_sles <- function(properties) {

  id <- properties$VERSION_ID
  if (is.null(id))
    return(NULL)

  parts <- strsplit(id, ".", fixed = TRUE)[[1L]]
  paste0("opensuse", parts[[1L]], parts[[2L]])

}

renv_ppm_platform_debian <- function(properties) {

  codename <- properties$VERSION_CODENAME
  if (is.null(codename))
    return(NULL)

  codename

}

renv_ppm_platform_amzn <- function(properties) {

  id <- properties$VERSION_ID
  if (is.null(id))
    return(NULL)

  if (numeric_version(id) == "2")
    return("centos7")

  return(NULL)

}

renv_ppm_os <- function() {

  os <- Sys.getenv("RENV_PPM_OS", unset = NA)
  if (!is.na(os))
    return(os)

  os <- Sys.getenv("RENV_RSPM_OS", unset = NA)
  if (!is.na(os))
    return(os)

  if (renv_platform_windows())
    "__windows__"
  else if (renv_platform_macos())
    "__macos__"
  else if (renv_platform_linux())
    "__linux__"

}


renv_ppm_enabled <- function() {

  # allow environment variable override
  enabled <- Sys.getenv("RENV_PPM_ENABLED", unset = NA)
  if (!is.na(enabled))
    return(truthy(enabled, default = TRUE))

  # support older options as well
  enabled <- Sys.getenv("RENV_RSPM_ENABLED", unset = NA)
  if (!is.na(enabled))
    return(truthy(enabled, default = TRUE))

  # TODO: can we remove this check?
  # https://github.com/rstudio/renv/issues/1132
  if (!testing()) {

    disabled <-
      renv_platform_linux() &&
      identical(renv_platform_machine(), "aarch64")

    if (disabled)
      return(FALSE)

  }

  # check for project setting
  enabled <- settings$ppm.enabled()
  if (!is.null(enabled))
    return(enabled)

  # otherwise, use configuration option
  config$ppm.enabled()

}


# predicate.R ----------------------------------------------------------------


pscalar <- function(x) {
  length(x) == 1L
}

pstring <- function(x) {
  is.character(x) && length(x) == 1L
}



# preflight.R ----------------------------------------------------------------


# returns TRUE if problems detected
renv_preflight <- function(lockfile) {

  problems <- stack()

  # check that we can compile C programs
  renv_preflight_compiler(problems)

  # if rJava is being used, ensure that Java is properly configured
  renv_preflight_java(lockfile, problems)

  data <- problems$data()
  if (length(data)) {

    feedback <- lines(
      "The following problems were detected in your environment:",
      "",
      paste(data, collapse = "\n\n"),
      "",
      "The environment may not be restored correctly."
    )

    caution(feedback)

  }

  length(data) == 0

}

renv_preflight_compiler <- function(problems) {

  # try to compile a simple program
  program <- "void test() {}"
  file <- renv_scope_tempfile("renv-test-compile-", fileext = ".c")
  writeLines(program, con = file)

  args <- c("CMD", "SHLIB", renv_shell_path(file))
  status <- system2(R(), args, stdout = FALSE, stderr = FALSE)

  if (!identical(status, 0L)) {

    feedback <- lines(
      "- Cannot compile C / C++ files from source.",
      "  Please ensure you have a compiler toolchain installed."
    )

    problems$push(feedback)

  }

}

renv_preflight_java <- function(lockfile, problems) {

  # no need to check if we're not using rJava
  records <- renv_lockfile_records(lockfile)
  if (is.null(records[["rJava"]]))
    return(TRUE)

  # TODO: no need to do anything if we're only installing binaries?
  switch(
    Sys.info()[["sysname"]],
    Windows = renv_preflight_java_windows(problems),
    renv_preflight_java_unix(problems)
  )

}

renv_preflight_java_windows <- function(problems) {

  home <- Sys.getenv("JAVA_HOME", unset = NA)
  feedback <- case(

    is.na(home) ~ lines(
      "- JAVA_HOME is not set.",
      "  Please ensure you have a Java Development Kit (JDK) installed."
    ),

    !file.exists(home) ~ lines(
      "- JAVA_HOME is set to a non-existent directory.",
      "  Please ensure you have a Java Development Kit (JDK) installed."
    )

  )

  if (!is.null(feedback))
    problems$push(feedback)

}

renv_preflight_java_unix <- function(problems) {

  args <- c("CMD", "javareconf", "--dry-run")
  status <- system2(R(), args, stdout = FALSE, stderr = FALSE)
  if (!identical(status, 0L)) {

    feedback <- lines(
      "- Cannot compile Java files from source.",
      "  Please ensure you have a Java Development Kit (JDK) installed."
    )

    problems$push(feedback)

  }

}


# pretty.R -------------------------------------------------------------------


renv_pretty_print_records <- function(preamble, records, postamble = NULL) {

  if (empty(records))
    return(invisible(NULL))

  if (!renv_verbose())
    return(invisible(NULL))

  # NOTE: use 'sort()' rather than 'csort()' here so that
  # printed output is sorted in the expected way in the users locale
  # https://github.com/rstudio/renv/issues/1289
  names(records) <- names(records) %||% map_chr(records, `[[`, "Package")
  records <- records[sort(names(records))]
  packages <- names(records)
  descs <- map_chr(records, renv_record_format_short)
  text <- sprintf("- %s [%s]", format(packages), descs)

  all <- c(preamble, text, postamble, if (length(postamble)) "")
  renv_caution_impl(all)

}

renv_pretty_print_records_pair <- function(preamble,
                                                old,
                                                new,
                                                postamble = NULL,
                                                formatter = NULL)
{
  formatter <- formatter %||% renv_record_format_pair

  all <- c(
    c(preamble, ""),
    renv_pretty_print_records_pair_impl(old, new, formatter),
    if (length(postamble)) c(postamble, "")
  )

  renv_caution_impl(all)
}

renv_pretty_print_records_pair_impl <- function(old, new, formatter) {

  # NOTE: use 'sort()' rather than 'csort()' here so that
  # printed output is sorted in the expected way in the users locale
  # https://github.com/rstudio/renv/issues/1289
  all <- sort(union(names(old), names(new)))

  # compute groups
  groups <- map_chr(all, function(package) {

    lhs <- old[[package]]; rhs <- new[[package]]
    case(
      is.null(lhs$Source)      ~ rhs$Repository %||% rhs$Source,
      is.null(rhs$Source)      ~ lhs$Repository %||% lhs$Source,
      !is.null(rhs$Repository) ~ rhs$Repository,
      !is.null(rhs$Source)     ~ rhs$Source
    )

  })

  n <- max(nchar(all))

  # iterate over each group and print
  uapply(csort(unique(groups)), function(group) {

    lhs <- renv_records_select(old, groups, group)
    rhs <- renv_records_select(new, groups, group)

    nms <- union(names(lhs), names(rhs))
    text <- map_chr(nms, function(nm) {
      formatter(lhs[[nm]], rhs[[nm]])
    })

    if (group == "unknown")
      group <- "(Unknown Source)"

    c(
      header(group),
      paste("-", format(nms, width = n), " ", text),
      ""
    )

  })

}

# NOTE: Used by vetiver, so perhaps is part of the API.
# We should think of a cleaner way of exposing this.
# https://github.com/rstudio/renv/issues/1413
renv_pretty_print_impl <- renv_caution_impl


# process.R ------------------------------------------------------------------


# NOTE: We use 'psnice()' here as R also supports using that
# for process detection on Windows; on all platforms R returns
# NA if you request information about a non-existent process
renv_process_exists <- function(pid) {
  !is.na(psnice(pid))
}

renv_process_kill <- function(pid, signal = 15L) {
  pskill(pid, signal)
}


# profile.R ------------------------------------------------------------------


renv_profile_prefix <- function() {
  renv_bootstrap_profile_prefix()
}

renv_profile_get <- function() {
  renv_bootstrap_profile_get()
}

renv_profile_set <- function(profile) {
  renv_bootstrap_profile_set(profile)
}

renv_profile_normalize <- function(profile) {
  renv_bootstrap_profile_normalize(profile)
}


# progress.R -----------------------------------------------------------------


renv_progress_create <- function(max, wait = 1.0) {

  # local variables for closure
  count <- 0L
  max <- max
  message <- ""
  start <- Sys.time()

  function() {

    # check for and print progress
    count <<- count + 1L

    # if not enough time has elapsed yet, nothing to do
    if (Sys.time() - start < wait)
      return()

    # create message
    backspaces <- paste(rep("\b", nchar(message)), collapse = "")
    message <<- sprintf("[%i/%i] ", count, max)
    all <- paste(backspaces, message, sep = "")
    cat(all, file = stdout(), sep = "")

  }

}

renv_progress_callback <- function(callback, max, wait = 1.0) {
  tick <- renv_progress_create(max, wait)
  function(...) { tick(); callback(...) }
}


# project.R ------------------------------------------------------------------


# The path to the currently-loaded project, if any.
# NULL when no project is currently loaded.
the$project_path <- NULL

# Flag indicating whether we're checking if the project is synchronized.
the$project_synchronized_check_running <- FALSE

#' Retrieve the active project
#'
#' Retrieve the path to the active project (if any).
#'
#' @param default The value to return when no project is
#'   currently active. Defaults to `NULL`.
#'
#' @export
#'
#' @return The active project directory, as a length-one character vector.
#'
#' @examples
#' \dontrun{
#'
#' # get the currently-active renv project
#' renv::project()
#'
#' }
project <- function(default = NULL) {
  renv_project_get(default = default)
}

renv_project_get <- function(default = NULL) {
  the$project_path %||% default
}

# NOTE: RENV_PROJECT kept for backwards compatibility with RStudio
renv_project_set <- function(project) {
  the$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
  Sys.unsetenv("RENV_PROJECT")
}

renv_project_resolve <- function(project = NULL, default = getwd()) {
  project <- project %||% renv_project_get(default = default)
  renv_path_normalize(project)
}

renv_project_initialized <- function(project) {

  lockfile <- renv_lockfile_path(project)
  if (file.exists(lockfile))
    return(TRUE)

  library <- renv_paths_library(project = project)
  if (file.exists(library))
    return(TRUE)

  FALSE

}

renv_project_type <- function(path) {

  if (!nzchar(path))
    return("unknown")

  path <- renv_path_normalize(path)
  filebacked(
    context  = "renv_project_type",
    path     = file.path(path, "DESCRIPTION"),
    callback = renv_project_type_impl
  )

}

renv_project_type_impl <- function(path) {

  if (!file.exists(path))
    return("unknown")

  desc <- tryCatch(
    renv_dcf_read(path),
    error = identity
  )

  if (inherits(desc, "error"))
    return("unknown")

  type <- desc$Type
  if (!is.null(type))
    return(tolower(type))

  package <- desc$Package
  if (!is.null(package))
    return("package")

  "unknown"

}

renv_project_remotes <- function(project, fields = NULL) {

  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
  deps <- renv_dependencies_discover_description(
    path    = descpath,
    project = project
  )

  if (empty(deps))
    return(list())

  # split according to package
  specs <- split(deps, deps$Package)

  # drop ignored specs
  ignored <- renv_project_ignored_packages(project = project)
  specs <- specs[setdiff(names(specs), c("R", ignored))]

  # if any Roxygen fields are included,
  # infer a dependency on roxygen2 and devtools
  desc <- renv_description_read(descpath)
  if (any(grepl("^Roxygen", names(desc)))) {
    for (package in c("devtools", "roxygen2")) {
      if (!package %in% ignored) {
        specs[[package]] <-
          specs[[package]] %||%
          renv_dependencies_list(descpath, package, dev = TRUE)
      }
    }
  }

  # 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))

    version <- spec$Version[[1]]
    if (!nzchar(version))
      return(renv_remotes_resolve(package))

    entry <- paste(package, version, sep = "@")
    renv_remotes_resolve(entry)

  })

  # return records
  records

}

renv_project_ignored_packages <- function(project) {

  # if we don't have a project, nothing to do
  if (is.null(project))
    return(character())

  # read base set of ignored packages
  ignored <- c(
    settings$ignored.packages(project = project),
    renv_project_ignored_packages_self(project)
  )

  # return collected set of ignored packages
  ignored

}

renv_project_ignored_packages_self <- function(project) {

  # only ignore self in package projects
  if (renv_project_type(project) != "package")
    return(NULL)

  # read current package
  desc <- renv_description_read(project)
  package <- desc[["Package"]]

  # respect user preference if set
  ignore <- getOption("renv.snapshot.ignore.self", default = NULL)
  if (identical(ignore, TRUE))
    return(package)
  else if (identical(ignore, FALSE))
    return(NULL)

  # don't ignore self in golem projets
  golem <- file.path(project, "inst/golem-config.yml")
  if (file.exists(golem))
    return(NULL)

  # hack for renv: don't depend on self
  if (identical(package, "renv"))
    return(NULL)

  # return the package name
  package

}

renv_project_id <- function(project) {

  idpath <- renv_id_path(project = project)
  if (!file.exists(idpath)) {
    id <- renv_id_generate()
    writeLines(id, con = idpath)
  }

  readLines(idpath, n = 1L, warn = FALSE)

}

# TODO: this gets really dicey once the user starts configuring where
# renv places its project-local state ...
renv_project_find <- function(path = NULL) {

  path <- path %||% getwd()

  anchors <- c("renv.lock", "renv/activate.R")
  resolved <- renv_file_find(path, function(parent) {
    for (anchor in anchors)
      if (file.exists(file.path(parent, anchor)))
        return(parent)
  })

  if (is.null(resolved)) {
    fmt <- "couldn't resolve renv project associated with path %s"
    stopf(fmt, renv_path_pretty(path))
  }

  resolved

}

renv_project_lock <- function(project = NULL) {

  if (!config$locking.enabled())
    return()

  path <- the$project_path
  if (!identical(project, path))
    return()

  project <- renv_project_resolve(project)
  path <- file.path(project, "renv/lock")
  ensure_parent_directory(path)
  renv_scope_lock(path, scope = parent.frame())

}

renv_project_loaded <- function(project) {
  !is.null(project) && identical(project, the$project_path)
}


# properties.R ---------------------------------------------------------------


renv_properties_read <- function(path = NULL,
                                 text = NULL,
                                 delimiter = ":",
                                 dequote = TRUE,
                                 trim = TRUE)
{
  renv_scope_options(warn = -1L)

  # read file
  contents <- paste(text %||% readLines(path, warn = FALSE), collapse = "\n")

  # split on newlines; allow spaces to continue a value
  parts <- strsplit(contents, "\\n(?=\\S)", perl = TRUE)[[1L]]

  # remove comments and blank lines
  parts <- grep("^\\s*(?:#|$)", parts, perl = TRUE, value = TRUE, invert = TRUE)

  # split into key / value pairs
  index <- regexpr(delimiter, parts, fixed = TRUE)
  keys <- substring(parts, 1L, index - 1L)
  vals <- substring(parts, index + 1L)

  # trim whitespace when requested
  if (trim) {
    keys <- trimws(keys)
    vals <- gsub("\n\\s*", " ", trimws(vals), perl = TRUE)
  }

  # strip quotes if requested
  if (dequote) {
    keys <- dequote(keys)
    vals <- dequote(vals)
  }

  # return as named list
  storage.mode(vals) <- "list"
  names(vals) <- keys

  vals

}


# purge.R --------------------------------------------------------------------


#' Purge packages from the cache
#'
#' Purge packages from the cache. This can be useful if a package which had
#' previously been installed in the cache has become corrupted or unusable,
#' and needs to be reinstalled.
#'
#' `purge()` is an inherently destructive option. It removes packages from the
#' cache, and so any project which had symlinked that package into its own
#' project library would find that package now unavailable. These projects would
#' hence need to reinstall any purged packages. Take heed of this in case you're
#' looking to purge the cache of a package which is difficult to install, or
#' if the original sources for that package are no longer available!
#'
#' @inherit renv-params
#'
#' @param package A single package to be removed from the cache.
#' @param version The package version to be removed. When `NULL`, all versions
#'   of the requested package will be removed.
#' @param hash The specific hashes to be removed. When `NULL`, all hashes
#'   associated with a particular package's version will be removed.
#'
#' @return The set of packages removed from the renv global cache,
#'   as a character vector of file paths.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # remove all versions of 'digest' from the cache
#' renv::purge("digest")
#'
#' # remove only a particular version of 'digest' from the cache
#' renv::purge("digest", version = "0.6.19")
#'
#' }
purge <- function(package,
                  ...,
                  version = NULL,
                  hash    = NULL,
                  prompt  = interactive())
{
  renv_scope_error_handler()
  renv_dots_check(...)
  renv_scope_verbose_if(prompt)
  invisible(renv_purge_impl(package, version, hash, prompt))
}

renv_purge_impl <- function(package,
                            version = NULL,
                            hash = NULL,
                            prompt = interactive())
{
  if (length(package) != 1)
    stop("argument 'package' is not of length one", call. = FALSE)

  bail <- function() {
    writef("- The requested package is not installed in the cache -- nothing to do.")
    character()
  }

  # get root cache path entry for package
  paths <- renv_paths_cache(package)
  if (!any(file.exists(paths)))
    return(bail())

  # construct versioned path
  paths <- if (is.null(version))
    list.files(paths, full.names = TRUE)
  else
    file.path(paths, version)
  if (!any(file.exists(paths)))
    return(bail())

  # construct hashed path
  paths <- if (is.null(hash))
    list.files(paths, full.names = TRUE)
  else
    file.path(paths, hash)
  if (all(!file.exists(paths)))
    return(bail())

  # now add package name
  paths <- file.path(paths, renv_path_component(paths, 3))

  # check that these entries exist
  missing <- !file.exists(paths)
  if (any(missing)) {

    caution_bullets(
      "The following entries were not found in the cache:",
      paths[missing],
      "They will be ignored."
    )

    paths <- paths[!missing]

  }

  # nocov start
  if (prompt || renv_verbose()) {

    caution_bullets(
      "The following packages will be purged from the cache:",
      renv_cache_format_path(paths)
    )

    cancel_if(prompt && !proceed())

  }
  # nocov end

  unlink(paths, recursive = TRUE)
  renv_cache_clean_empty()

  n <- length(paths)
  writef("- Removed %s from the cache.", nplural("package", n))

  invisible(paths)

}


# pyenv.R --------------------------------------------------------------------


renv_pyenv_root <- function() {
  root <- Sys.getenv("PYENV_ROOT", unset = renv_pyenv_root_default())
  path.expand(root)
}

renv_pyenv_root_default <- function() {

  if (renv_platform_windows())
    "~/.pyenv/pyenv-win"
  else
    "~/.pyenv"

}



# python-conda.R -------------------------------------------------------------


renv_python_conda_select <- function(name, version = NULL) {

  # get python package
  version <- version %||% Sys.getenv("RENV_CONDA_PYTHON_VERSION", unset = "3.7")
  packages <- paste("python", version, sep = "=")

  # handle paths (as opposed to environment names)
  if (grepl("[/\\\\]", name)) {
    if (!file.exists(name))
      return(reticulate::conda_create(envname = name, packages = packages))
    return(renv_python_exe(name))
  }

  # check for an existing conda environment
  envs <- reticulate::conda_list()
  idx <- which(name == envs$name)
  if (length(idx))
    return(envs$python[[idx]])

  # no environment exists; create it
  reticulate::conda_create(envname = name, packages = packages)

}

renv_python_conda_export_path <- function(project) {

  # check override
  override <- renv_paths_override("CONDA_EXPORT")
  if (!is.null(override))
    return(override)

  # use default
  file.path(project, "environment.yml")

}

# TODO: support prompt
renv_python_conda_snapshot <- function(project, prompt, python) {

  renv_scope_wd(project)

  path <- renv_python_conda_export_path(project = project)

  # find the root of the associated conda environment
  lockfile <- renv_lockfile_load(project = project)
  name <- lockfile$Python$Name %||% renv_python_envpath(project, "conda", version)
  python <- renv_python_conda_select(name)
  info <- renv_python_info(python)
  prefix <- info$root

  conda <- reticulate::conda_binary()
  args <- c(
    "env", "export",
    "--prefix", renv_shell_path(prefix),
    "--file", renv_shell_path(path)
  )

  output <- if (renv_tests_running()) FALSE else ""
  system2(conda, args, stdout = output, stderr = output)

  writef("- Wrote Python packages to '%s'.", renv_path_aliased(path))
  return(TRUE)
}

# TODO: support prompt
renv_python_conda_restore <- function(project, prompt, python) {

  renv_scope_wd(project)

  path <- renv_python_conda_export_path(project = project)

  # find the root of the associated conda environment
  lockfile <- renv_lockfile_load(project = project)
  name <- lockfile$Python$Name %||% renv_python_envpath(project, "conda", version)
  python <- renv_python_conda_select(name)
  info <- renv_python_info(python)
  prefix <- info$root

  conda <- reticulate::conda_binary()
  cmd <- if (file.exists(prefix)) "update" else "create"
  args <- c(
    "env", cmd,
    "--prefix", renv_shell_path(prefix),
    "--file", renv_shell_path(path)
  )

  output <- if (renv_tests_running()) FALSE else ""
  system2(conda, args, stdout = output, stderr = output)

  return(TRUE)

}


# python-virtualenv.R --------------------------------------------------------


renv_python_virtualenv_home <- function() {
  Sys.getenv("WORKON_HOME", unset = "~/.virtualenvs")
}

renv_python_virtualenv_path <- function(name) {

  # if the name contains a slash, use it as-is
  if (grepl("/", name, fixed = TRUE))
    return(renv_path_canonicalize(name))

  # treat names starting with '.' specially
  if (substring(name, 1L, 1L) == ".")
    return(renv_path_canonicalize(name))

  # otherwise, resolve relative to virtualenv home
  home <- renv_python_virtualenv_home()
  file.path(home, name)

}

renv_python_virtualenv_validate <- function(path, version) {

  # get path to python executable
  python <- renv_python_exe(path)

  # compare requested + actual versions
  if (!is.null(version)) {
    request <- renv_version_maj_min(version)
    current <- renv_version_maj_min(renv_python_version(python))
    if (request != current) {
      fmt <- "Project requested Python version '%s' but '%s' is currently being used"
      warningf(fmt, request, current)
    }
  }

  python

}

renv_python_virtualenv_create <- function(python, path) {

  ensure_parent_directory(path)

  python <- renv_path_canonicalize(python)
  version <- renv_python_version(python)
  module <- if (numeric_version(version) > "3.2") "venv" else "virtualenv"
  args <- c("-m", module, renv_shell_path(path))
  renv_system_exec(python, args, "creating virtual environment")

  info <- renv_python_info(path)
  info$python

}

renv_python_virtualenv_update <- function(python) {

  # resolve python executable path
  python <- renv_python_exe(python)
  python <- renv_path_canonicalize(python)

  # resolve packages
  packages <- c("pip", "setuptools", "wheel")

  # don't upgrade these packages for older versions of python, as we may
  # end up installing versions of packages that aren't actually compatible
  # with the version of python we're running
  version <- renv_python_version(python)
  if (renv_version_lt(version, "3.6"))
    return(TRUE)

  # perform the install
  # make errors non-fatal as the environment will still be functional even
  # if we're not able to install or update these packages
  status <- catch(pip_install(packages, python = python))
  if (inherits(status, "error"))
    warnify(status)

  TRUE

}

renv_python_virtualenv_snapshot <- function(project, prompt, python) {

  renv_scope_wd(project)

  path <- file.path(project, "requirements.txt")
  before <- character()
  if (file.exists(path))
    before <- readLines(path, warn = FALSE)

  after <- pip_freeze(python = python)
  if (setequal(before, after)) {
    writef("- Python requirements are already up to date.")
    return(FALSE)
  }

  caution_bullets("The following will be written to requirements.txt:", after)

  cancel_if(prompt && !proceed())

  writeLines(after, con = path)

  fmt <- "- Wrote Python packages to %s."
  writef(fmt, renv_path_pretty(path))
  return(TRUE)

}

renv_python_virtualenv_restore <- function(project, prompt, python) {

  renv_scope_wd(project)

  path <- file.path(project, "requirements.txt")
  if (!file.exists(path))
    return(FALSE)

  before <- readLines(path, warn = FALSE)
  after <- pip_freeze(python = python)
  diff <- renv_vector_diff(before, after)
  if (empty(diff)) {
    writef("- The Python library is already up to date.")
    return(FALSE)
  }

  caution_bullets("The following Python packages will be restored:", diff)

  cancel_if(prompt && !proceed())

  pip_install_requirements(diff, python = python, stream = TRUE)
  TRUE

}


# python.R -------------------------------------------------------------------


renv_python_resolve <- function(python = NULL) {

  # if Python was explicitly supplied, use it
  if (!is.null(python)) {

    resolved <- Sys.which(renv_path_canonicalize(python))
    if (nzchar(resolved))
      return(resolved)

    stopf("'%s' does not refer to a valid python interpreter", python)

  }

  # in interactive sessions, ask user what version of python they'd like to use
  if (interactive()) {

    python <- renv_python_select()

    fmt <- "- Selected %s [Python %s]."
    writef(fmt, renv_path_pretty(python), renv_python_version(python))

    return(path.expand(python))

  }

  # check environment variables
  envvars <- c("RETICULATE_PYTHON", "RETICULATE_PYTHON_ENV")
  for (envvar in envvars) {
    val <- Sys.getenv(envvar, unset = NA)
    if (!is.na(val) && file.exists(val))
      return(val)
  }

  # check on the PATH (prefer Python 3)
  for (binary in c("python3", "python")) {
    python <- Sys.which(binary)
    if (nzchar(python))
      return(python)
  }

  stopf("could not locate Python (not available on the PATH)")

}

renv_python_find <- function(version, path = NULL) {
  renv_python_find_impl(version, path)
}

renv_python_find_impl <- function(version, path = NULL) {

  # if we've been given the name of an environment,
  # check to see if it's already been initialized
  # and use the associated copy of Python if possible
  if (!is.null(path) && file.exists(path)) {
    python <- catch(renv_python_exe(path))
    if (!inherits(python, "error"))
      return(python)
  }

  # try to find a compatible version of python
  pythons <- renv_python_discover()
  if (length(pythons) == 0) {

    fmt <- lines(
      "project requested Python %s, but no compatible Python installation could be found.",
      "renv's Python integration will be disabled in this session.",
      "See `?renv::use_python` for more details."
    )

    stopf(fmt, version)

  }

  # read python versions
  pyversions <- map_chr(pythons, function(python) {
    tryCatch(
      renv_python_version(python),
      error = function(e) "0.0.0"
    )
  })

  # try to find a compatible version
  renv_version_match(pyversions, version)

}

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"))
    return(renv_path_canonicalize(path))

  # otherwise, attempt to infer the Python executable type
  info <- renv_python_info(path)
  if (!is.null(info$python))
    return(renv_path_canonicalize(info$python))

  fmt <- "failed to find Python executable associated with path %s"
  stopf(fmt, renv_path_pretty(path))

}

renv_python_version <- function(python) {

  filebacked(
    context  = "renv_python_version",
    path     = renv_path_normalize(python),
    callback = renv_python_version_impl
  )

}

renv_python_version_impl <- function(python) {
  python <- renv_path_canonicalize(python)
  code <- "from platform import python_version; print(python_version())"
  args <- c("-c", shQuote(code))
  action <- "reading Python version"
  renv_system_exec(python, args, action)
}

renv_python_info <- function(python) {

  found <- renv_file_find(python, function(path) {

    # check for virtual environment files
    virtualenv <-
      file.exists(file.path(path, "pyvenv.cfg")) ||
      file.exists(file.path(path, ".Python")) ||
      file.exists(file.path(path, "bin/activate_this.py"))

    if (virtualenv) {
      suffix <- if (renv_platform_windows()) "Scripts/python.exe" else "bin/python"
      python <- file.path(path, suffix)
      return(list(python = python, type = "virtualenv", root = path))
    }

    # check for conda-meta
    condaenv <-
      file.exists(file.path(path, "conda-meta")) &&
      !file.exists(file.path(path, "condabin"))

    if (condaenv) {
      suffix <- if (renv_platform_windows()) "python.exe" else "bin/python"
      python <- file.path(path, suffix)
      return(list(python = python, type = "conda", root = path))
    }

  })

  if (!is.null(found))
    return(found)

  if (file.exists(python))
    list(python = python, type = "system", root = python)

}

renv_python_type <- function(python) {
  info <- renv_python_info(python)
  info$type
}

renv_python_action <- function(action, prompt, project) {

  python <- Sys.getenv("RENV_PYTHON", unset = NA)
  if (is.na(python) || !file.exists(python))
    return(NULL)

  type <- renv_python_type(python)
  if (is.null(type))
    return(NULL)

  if (type == "conda" && !requireNamespace("reticulate", quietly = TRUE))
    return(NULL)

  action(python, type, prompt, project)

}

renv_python_snapshot <- function(project, prompt) {
  renv_python_action(
    renv_python_snapshot_impl,
    prompt  = prompt,
    project = project
  )
}

renv_python_snapshot_impl <- function(python, type, prompt, project) {

  switch(type,
    virtualenv = renv_python_virtualenv_snapshot(project, prompt, python),
    conda      = renv_python_conda_snapshot(project, prompt, python)
  )

}

renv_python_restore <- function(project, prompt) {
  renv_python_action(
    renv_python_restore_impl,
    prompt  = prompt,
    project = project
  )
}

renv_python_restore_impl <- function(python, type, prompt, project) {

  case(
    type == "virtualenv" ~ renv_python_virtualenv_restore(project, prompt, python),
    type == "conda"      ~ renv_python_conda_restore(project, prompt, python)
  )

}

renv_python_envpath_virtualenv <- function(version) {
  sprintf("python/virtualenvs/renv-python-%s", renv_version_maj_min(version))
}

renv_python_envpath_condaenv <- function(version) {
  "python/condaenvs/renv-python"
}

renv_python_envpath <- function(project, type, version = NULL) {

  suffix <- case(
    type == "virtualenv" ~ renv_python_envpath_virtualenv(version),
    type == "conda"      ~ renv_python_envpath_condaenv(version),
    ~ stopf("internal error: unrecognized environment type '%s'", type)
  )

  renv_paths_renv(suffix, project = project)

}

renv_python_envname <- function(project, path, type) {

  # check for a project-local environment
  if (renv_path_within(path, project)) {
    stem <- substring(path, nchar(project) + 2L)
    path <- paste(".", stem, sep = "/")
    return(path)
  }

  bn <- basename(path)

  # check for file within virtualenv
  ok <-
    type == "virtualenv" &&
    identical(renv_python_virtualenv_path(bn), path)

  if (ok)
    return(bn)

  # check for named conda environment
  ok <-
    type == "conda" &&
    bn %in% reticulate::conda_list()$name

  if (ok)
    return(bn)

  # doesn't match any known named environments; return full path
  path

}

renv_python_discover <- function() {

  all <- stack()

  # find python in some pre-determined root directories
  roots <- c(
    getOption("renv.python.root"),
    Sys.getenv("WORKON_HOME", "~/.virtualenvs"),
    "/opt/python",
    "/opt/local/python",
    "~/opt/python",
    file.path(renv_pyenv_root(), "versions")
  )

  for (root in roots) {
    versions <- sort(list.files(root, full.names = TRUE), decreasing = TRUE)
    exts <- if (renv_platform_windows()) "Scripts/python.exe" else "bin/python"
    pythons <- file.path(versions, exts)
    all$push(pythons)
  }

  # find Homebrew python
  if (renv_platform_macos()) {

    homebrew <- renv_homebrew_root()
    roots <- sort(list.files(
      path       = file.path(homebrew, "opt"),
      pattern    = "^python@[[:digit:]]+[.][[:digit:]]+$",
      full.names = TRUE
    ), decreasing = TRUE)

    for (root in roots) {

      # homebrew python doesn't install bin/python, so we need
      # to be a little bit more clever here
      exes <- list.files(
        path = file.path(root, "bin"),
        pattern = "^python[[:digit:]]+[.][[:digit:]]+$",
        full.names = TRUE
      )

      if (length(exes))
        all$push(exes[[1L]])

    }

  }

  # find Windows python installations
  if (renv_platform_windows()) {

    sd <- Sys.getenv("SYSTEMDRIVE", unset = "C:")
    roots <- file.path(sd, c("", "Program Files"))

    lad <- Sys.getenv("LOCALAPPDATA", unset = NA)
    if (!is.na(lad))
      roots <- c(roots, file.path(lad, "Programs/Python"))

    dirs <- list.files(
      path       = roots,
      pattern    = "^Python",
      full.names = TRUE
    )

    if (length(dirs)) {
      exes <- file.path(dirs, "python.exe")
      pythons <- renv_path_normalize(exes)
      all$push(pythons)
    }

  }

  # find Python installations on the PATH
  path <- Sys.getenv("PATH", unset = "")
  splat <- strsplit(path, .Platform$path.sep, fixed = TRUE)[[1L]]
  for (entry in splat) {
    for (exe in c("python3", "python")) {
      python <- Sys.which(file.path(entry, exe))
      if (nzchar(python))
        all$push(python)
    }
  }

  # collect discovered pythons as vector
  pythons <- unlist(all$data(), recursive = FALSE, use.names = TRUE)

  # don't include /usr/bin/python on macOS (too old)
  if (renv_platform_macos())
    pythons <- setdiff(pythons, "/usr/bin/python")

  # get list of pythons
  pythons <- renv_path_canonicalize(pythons[file.exists(pythons)])

  # don't include WindowsApps
  if (renv_platform_windows())
    pythons <- grep("/WindowsApps/", pythons, invert = TRUE, value = TRUE)

  unique(pythons)

}

renv_python_select_error <- function() {

  lines <- c(
    "renv was unable to find any Python installations on your machine.",
    if (renv_platform_windows())
      "Consider installing Python from https://www.python.org/downloads/windows/.",
    if (renv_platform_macos())
      "Consider installing Python from https://www.python.org/downloads/mac-osx/."
  )

  stop(paste(lines, collapse = "\n"))

}

renv_python_select <- function(candidates = NULL) {

  candidates <- renv_path_aliased(candidates %||% renv_python_discover())
  if (empty(candidates))
    return(renv_python_select_error())

  title <- "Please select a version of Python to use with this project:"
  selection <- tryCatch(
    utils::select.list(candidates, title = title, graphics = FALSE),
    interrupt = identity
  )

  if (selection %in% "" || inherits(selection, "interrupt"))
    stop("operation canceled by user")

  return(path.expand(selection))

}

renv_python_module_available <- function(python, module) {
  python <- renv_path_canonicalize(python)
  command <- paste("import", module)
  args <- c("-c", shQuote(command))
  status <- system2(python, args, stdout = FALSE, stderr = FALSE)
  identical(status, 0L)
}

renv_python_active <- function() {

  python <- Sys.getenv("RENV_PYTHON", unset = NA)
  if (is.na(python))
    stop("internal error: RENV_PYTHON is not set")

  renv_python_validate(python)

}

renv_python_validate <- function(python) {

  if (!file.exists(python)) {
    fmt <- "python %s does not exist"
    stopf(fmt, renv_path_pretty(python))
  }

  invisible(python)

}


# r.R ------------------------------------------------------------------------


R <- function() {
  bin <- normalizePath(R.home("bin"), winslash = "/")
  exe <- if (renv_platform_windows()) "R.exe" else "R"
  file.path(bin, exe)
}

r <- function(args, ...) {

  # ensure R_LIBS is set; unset R_LIBS_USER and R_LIBS_SITE
  # so that R_LIBS will always take precedence
  rlibs <- paste(renv_libpaths_all(), collapse = .Platform$path.sep)
  renv_scope_envvars(R_LIBS = rlibs, R_LIBS_USER = "NULL", R_LIBS_SITE = "NULL")

  # ensure Rtools is on the PATH for Windows
  renv_scope_rtools()

  # invoke r
  suppressWarnings(system2(R(), args, ...))

}

r_exec_error <- function(package, output, label, extra) {

  # installation failed; write output for user
  fmt <- "Error %sing package '%s':"
  header <- sprintf(fmt, label, package)

  lines <- paste(rep("=", nchar(header)), collapse = "")

  # try to add diagnostic information if possible
  diagnostics <- r_exec_error_diagnostics(package, output)
  if (!empty(diagnostics)) {
    size <- min(getOption("width"), 78L)
    dividers <- paste(rep.int("-", size), collapse = "")
    output <- c(output, paste(dividers, diagnostics, collapse = "\n\n"))
  }

  # normalize 'extra'
  extra <- if (is.integer(extra))
    paste("error code", extra)
  else
    paste(renv_path_pretty(extra), "does not exist")

  # stop with an error
  footer <- sprintf("%s of package '%s' failed [%s]", label, package, extra)
  all <- c(header, lines, "", output, footer)
  abort(all)

}

r_exec_error_diagnostics_fortran_library <- function() {

  checker <- function(output) {
    pattern <- "library not found for -l(quadmath|gfortran|fortran)"
    idx <- grep(pattern, output, ignore.case = TRUE)
    if (length(idx))
      return(unique(output[idx]))
  }

  suggestion <- "
R was unable to find one or more FORTRAN libraries during compilation.
This often implies that the FORTRAN compiler has not been properly configured.
Please see https://stackoverflow.com/q/35999874 for more information.
"

  list(
    checker = checker,
    suggestion = suggestion
  )

}

r_exec_error_diagnostics_fortran_binary <- function() {

  checker <- function(output) {
    pattern <- "gfortran: no such file or directory"
    idx <- grep(pattern, output, ignore.case = TRUE)
    if (length(idx))
      return(unique(output[idx]))
  }

  suggestion <- "
R was unable to find the gfortran binary.
gfortran is required for the compilation of FORTRAN source files.
Please check that gfortran is installed and available on the PATH.
Please see https://stackoverflow.com/q/35999874 for more information.
"

  list(
    checker = checker,
    suggestion = suggestion
  )

}

r_exec_error_diagnostics_openmp <- function() {

  checker <- function(output) {
    pattern <- "unsupported option '-fopenmp'"
    idx <- grep(pattern, output, fixed = TRUE)
    if (length(idx))
      return(unique(output[idx]))
  }

  suggestion <- "
R is currently configured to use a compiler that does not have OpenMP support.
You may need to disable OpenMP, or update your compiler toolchain.
Please see https://support.bioconductor.org/p/119536/ for a related discussion.
"

  list(
    checker = checker,
    suggestion = suggestion
  )

}

r_exec_error_diagnostics <- function(package, output) {

  diagnostics <- list(
    r_exec_error_diagnostics_fortran_library(),
    r_exec_error_diagnostics_fortran_binary(),
    r_exec_error_diagnostics_openmp()
  )

  suggestions <- uapply(diagnostics, function(diagnostic) {

    check <- catch(diagnostic$checker(output))
    if (!is.character(check))
      return()

    suggestion <- diagnostics$suggestion
    reasons <- paste("-", shQuote(check), collapse = "\n")
    paste(diagnostic$suggestion, "Reason(s):", reasons, sep = "\n")

  })

  as.character(suggestions)

}

# install package called 'package' located at path 'path'
r_cmd_install <- function(package, path, ...) {

  # normalize path to package
  path <- renv_path_normalize(path, mustWork = TRUE)

  # unpack .zip source archives before install
  # https://github.com/rstudio/renv/issues/1359
  ftype <- renv_file_type(path)
  atype <- renv_archive_type(path)
  ptype <- renv_package_type(path)

  unpack <-
    ftype == "file" &&
    atype == "zip" &&
    ptype == "source"

  if (unpack) {
    newpath <- renv_package_unpack(package, path, force = TRUE)
    if (!identical(newpath, path)) {
      path <- newpath
      defer(unlink(path, recursive = TRUE))
    }
  }

  # rename binary .zip files if necessary
  rename <-
    ftype == "file" &&
    atype == "zip" &&
    ptype == "binary"

  if (rename) {
    regexps <- .standard_regexps()
    fmt <- "^%s(?:_%s)?\\.zip$"
    pattern <- sprintf(fmt, regexps$valid_package_name, regexps$valid_package_version)
    if (!grepl(pattern, basename(path), perl = TRUE)) {
      dir <- renv_scope_tempfile(package)
      ensure_directory(dir)
      newpath <- file.path(dir, paste(package, "zip", sep = "."))
      renv_file_copy(path, newpath)
      path <- newpath
    }
  }

  # resolve default library path
  library <- renv_libpaths_active()

  # validate that we have command line tools installed and
  # available for e.g. macOS
  if (renv_platform_macos() && renv_package_type(path) == "source")
    renv_xcode_check()

  # perform platform-specific pre-install checks
  renv_scope_install()

  # perform the install
  # note that we need to supply '-l' below as otherwise the library paths
  # could be changed by, for example, site-specific profiles
  args <- c(
    "--vanilla",
    "CMD", "INSTALL", "--preclean", "--no-multiarch", "--with-keep.source",
    r_cmd_install_option(package, "configure.args", TRUE),
    r_cmd_install_option(package, "configure.vars", TRUE),
    r_cmd_install_option(package, c("install.opts", "INSTALL_opts"), FALSE),
    "-l", renv_shell_path(library),
    ...,
    renv_shell_path(path)
  )

  if (config$install.verbose()) {

    status <- r(args, stdout = "", stderr = "")
    if (!identical(status, 0L))
      stopf("install of package '%s' failed", package)

    installpath <- file.path(library, package)
    if (!file.exists(installpath)) {
      fmt <- "install of package '%s' failed: %s does not exist"
      stopf(fmt, package, renv_path_pretty(installpath))
    }

    installpath

  } else {

    output <- r(args, stdout = TRUE, stderr = TRUE)
    status <- attr(output, "status") %||% 0L
    if (!identical(status, 0L))
      r_exec_error(package, output, "install", status)

    installpath <- file.path(library, package)
    if (!file.exists(installpath))
      r_exec_error(package, output, "install", installpath)

    installpath

  }


}

r_cmd_build <- function(package, path, ...) {

  path <- renv_path_normalize(path, mustWork = TRUE)
  args <- c("--vanilla", "CMD", "build", "--md5", ..., renv_shell_path(path))

  output <- r(args, stdout = TRUE, stderr = TRUE)
  status <- attr(output, "status") %||% 0L
  if (!identical(status, 0L))
    r_exec_error(package, output, "build", status)

  pasted <- paste(output, collapse = "\n")
  pattern <- "[*] building .([a-zA-Z0-9_.-]+)."
  matches <- regexec(pattern, pasted)
  text <- regmatches(pasted, matches)

  tarball <- text[[1L]][[2L]]
  if (!file.exists(tarball))
    r_exec_error(package, output, "build", tarball)

  file.path(getwd(), tarball)

}

r_cmd_install_option <- function(package, options, configure) {

  # read option -- first, check for package-specific option, then
  # fall back to 'global' option
  for (option in options) {
    value <- r_cmd_install_option_impl(package, option, configure)
    if (!is.null(value))
      return(value)
  }

}

r_cmd_install_option_impl <- function(package, option, configure) {

  value <-
    getOption(paste(option, package, sep = ".")) %||%
    getOption(option)

  if (is.null(value))
    return(NULL)

  # if the value is named, treat it as a list,
  # mapping package names to their configure arguments
  if (!is.null(names(value)))
    value <- as.list(value)

  # check for named values
  if (!is.null(names(value))) {
    value <- value[[package]]
    if (is.null(value))
      return(NULL)
  }

  # if this is a configure option, format specially
  if (configure) {
    confkey <- sub(".", "-", option, fixed = TRUE)
    confval <- if (!is.null(names(value)))
      shQuote(paste(names(value), value, sep = "=", collapse = " "))
    else
      shQuote(paste(value, collapse = " "))
    return(sprintf("--%s=%s", confkey, confval))
  }

  # otherwise, just paste it
  paste(value, collapse = " ")

}

r_cmd_config <- function(...) {

  renv_system_exec(
    command = R(),
    args    = c("--vanilla", "CMD", "config", ...),
    action  = "reading R CMD config"
  )

}


# rebuild.R ------------------------------------------------------------------


#' Rebuild the packages in your project library
#'
#' Rebuild and reinstall packages in your library. This can be useful as a
#' diagnostic tool -- for example, if you find that one or more of your
#' packages fail to load, and you want to ensure that you are starting from a
#' clean slate.
#'
#' @inherit renv-params
#'
#' @param packages The package(s) to be rebuilt. When `NULL`, all packages
#'   in the library will be reinstalled.
#'
#' @param recursive Boolean; should dependencies of packages be rebuilt
#'   recursively? Defaults to `TRUE`.
#'
#' @return A named list of package records which were installed by renv.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # rebuild the 'dplyr' package + all of its dependencies
#' renv::rebuild("dplyr", recursive = TRUE)
#'
#' # rebuild only 'dplyr'
#' renv::rebuild("dplyr", recursive = FALSE)
#'
#' }
rebuild <- function(packages  = NULL,
                    recursive = TRUE,
                    ...,
                    type    = NULL,
                    prompt  = interactive(),
                    library = NULL,
                    project = NULL)
{
  renv_consent_check()
  renv_scope_error_handler()
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_scope_verbose_if(prompt)

  libpaths <- renv_libpaths_resolve(library)
  library <- nth(libpaths, 1L)

  # get collection of packages currently installed
  records <- renv_snapshot_libpaths(libpaths = libpaths, project = project)
  packages <- setdiff(packages %||% names(records), "renv")

  # add in missing packages
  for (package in packages) {
    records[[package]] <- records[[package]] %||%
      renv_available_packages_latest(package)
  }

  # make sure records are named
  names(records) <- map_chr(records, `[[`, "Package")
  if (empty(records)) {
    writef("- There are no packages currently installed -- nothing to rebuild.")
    return(invisible(records))
  }


  # apply any overrides
  records <- renv_records_override(records)

  # notify the user
  preamble <- if (recursive)
    "The following package(s) and their dependencies will be reinstalled:"
  else
    "The following package(s) will be reinstalled:"

  renv_pretty_print_records(preamble, records[packages])
  cancel_if(prompt && !proceed())

  # figure out rebuild parameter
  rebuild <- if (recursive) NA else packages

  # perform the install
  install(
    packages = records[packages],
    library  = libpaths,
    type     = type,
    rebuild  = rebuild,
    project  = project
  )
}


# record.R -------------------------------------------------------------------


#' Update package records in a lockfile
#'
#' Use `record()` to record a new entry within an existing renv lockfile.
#'
#' This function can be useful when you need to change one or more of the
#' package records within an renv lockfile -- for example, because a recorded
#' package cannot be restored in a particular environment, and you know of a
#' suitable alternative.
#'
#' # Records
#'
#' Records can be provided either using the **remotes** short-hand syntax,
#' or by using an \R list of entries to record within the lockfile. See
#' `?lockfiles` for more information on the structure of a package record.
#'
#' @inheritParams renv-params
#'
#' @param records A list of named records, mapping package names to a definition
#'   of their source. See **Records** for more details.
#'
#' @example examples/examples-record.R
#' @export
record <- function(records,
                   lockfile = NULL,
                   project  = NULL)
{
  renv_scope_error_handler()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  lockfile <- lockfile %||% renv_lockfile_path(project)

  records <- case(
    is.character(records) ~ lapply(records, renv_remotes_resolve, latest = TRUE),
    is.list(records)      ~ renv_records_resolve(records, latest = TRUE),
    ~ stopf("unexpected records format '%s'", typeof(records))
  )

  names(records) <- enum_chr(records, function(package, record) {
    if (is.null(package) || is.na(package) || !nzchar(package))
      record[["Package"]]
    else
      package
  })

  if (is.list(lockfile))
    return(renv_lockfile_modify(lockfile, records))

  if (!file.exists(lockfile)) {
    fmt <- "no lockfile exists at path %s"
    stopf(fmt, renv_path_pretty(lockfile))
  }

  old <- renv_lockfile_read(lockfile)
  new <- renv_lockfile_modify(old, records)

  local({
    renv_scope_options(renv.verbose = FALSE)
    renv_lockfile_write(new, lockfile)
  })

  n <- length(records)
  fmt <- "- Updated %s in %s."
  writef(fmt, nplural("record", n), renv_path_pretty(lockfile))

  renv <- records[["renv"]]
  if (!is.null(renv) && !is.null(renv[["Version"]])) {
    renv_infrastructure_write_activate(
      project = project,
      version = renv[["Version"]]
    )
  }

  invisible(lockfile)

}

renv_record_normalize <- function(record) {

  # normalize source
  source <- record$Source %||% "unknown"
  if (source %in% c("CRAN", "PPM", "RSPM"))
    record$Source <- "Repository"

  # drop remotes from records with a repository source
  if (identical(record$Source, "Repository") ||
      identical(record$RemoteType, "standard"))
    record <- record[grep("^Remote", names(record), invert = TRUE)]

  # keep only specific records for comparison
  remotes <- grep("^Remote", names(record), value = TRUE)
  keep <- c("Package", "Version", "Source", remotes)
  record <- record[intersect(names(record), keep)]

  # return normalized record
  record

}


# records.R ------------------------------------------------------------------


renv_records_select <- function(records, actions, action) {
  records <- renv_lockfile_records(records)
  matching <- actions[actions %in% action]
  keep(records, names(matching))
}

renv_records_sort <- function(records) {
  records[csort(names(records))]
}

renv_records_override <- function(records) {
  enumerate(records, renv_options_override, scope = "renv.records")
}

renv_record_names <- function(record, fields = NULL) {
  fields <- fields %||% c("Package", "Version", "Source")
  remotes <- grep("^Remote", names(record), value = TRUE)
  nms <- c(fields, setdiff(remotes, "Remotes"))
  renv_vector_intersect(nms, names(record))
}

renv_record_cacheable <- function(record) {

  # check if the record has been marked as cacheable
  cacheable <- record$Cacheable %||% TRUE
  if (identical(cacheable, FALSE))
    return(FALSE)

  # check for unknown source
  source <- renv_record_source(record)
  if (source == "unknown")
    return(FALSE)

  # record is ok
  TRUE

}

renv_record_source <- function(record, normalize = FALSE) {

  # if this appears to be a file path, then keep it as-is
  source <- record$Source %||% "unknown"
  if (grepl("[/\\]", source))
    return(source)

  # otherwise, try to normalize it
  source <- tolower(record$Source %||% "unknown")
  if (normalize)
    source <- renv_record_source_normalize(record, source)

  source

}

renv_record_source_normalize <- function(record, source) {

  # normalize different types of git remotes
  if (source %in% c("git2r", "xgit"))
    source <- "git"

  # handle old lockfiles where 'source' was explicitly set as CRAN
  if (source %in% c("cran"))
    source <- "repository"

  # check for ad-hoc requests to install from bioc
  if (identical(source, "repository")) {
    repos <- record$Repository %||% ""
    if (tolower(repos) %in% c("bioc", "bioconductor"))
      source <- "bioconductor"
  }

  # all done; return normalized source
  source

}

renv_record_validate <- function(package, record) {

  # check for a record -- minimally, a list with a package name
  if (is.list(record) && is.character(record$Package))
    return(record)

  # if we're running tests, or in CI, then report
  if (renv_tests_running() || renv_envvar_exists("CI")) {
    fmt <- "! Internal error: unexpected record for package '%s'"
    writef(fmt, package)
    print(record)
  }

  # return record as-is
  record

}

renv_record_format_remote <- function(record) {

  remotes <- c("RemoteUsername", "RemoteRepo")
  if (all(remotes %in% names(record)))
    return(renv_record_format_short_remote(record))

  paste(record$Package, record$Version, sep = "@")

}

renv_record_format_short <- function(record, versioned = FALSE) {

  remotes <- c("RemoteUsername", "RemoteRepo")
  if (all(remotes %in% names(record))) {
    remote <- renv_record_format_short_remote(record)
    if (versioned)
      remote <- sprintf("%s  [%s]", record$Version %||% "<NA>", remote)
    return(remote)
  }

  record$Version

}

renv_record_format_short_remote <- function(record) {

  text <- paste(record$RemoteUsername, record$RemoteRepo, sep = "/")

  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) {

  # 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)))

  map <- list(
    Source         = "src",
    Repository     = "repo",
    Version        = "ver",
    RemoteHost     = "host",
    RemoteUsername = "user",
    RemoteRepo     = "repo",
    RemoteRef      = "ref",
    RemoteSha      = "sha",
    RemoteSubdir   = "subdir"
  )

  fields <- names(map)

  # check to see which fields have changed between the two
  diff <- map_lgl(fields, function(field) {
    !identical(lhs[[field]], rhs[[field]])
  })

  changed <- names(which(diff))

  if (empty(changed)) {
    fmt <- "[%s: unchanged]"
    lhsf <- renv_record_format_short(lhs)
    return(sprintf(fmt, lhsf))
  }

  # check for CRAN packages; in such cases, we typically want to ignore
  # the Remote fields which might've been added by 'pak' or other tools
  isrepo <-
    nzchar(lhs$Version %||% "") &&
    nzchar(rhs$Version %||% "") &&
    nzchar(lhs$Repository %||% "") &&
    nzchar(rhs$Repository %||% "") &&
    identical(lhs$Repository, rhs$Repository)

  if (isrepo) {
    fmt <- "[%s -> %s]"
    lhsf <- renv_record_format_short(lhs)
    rhsf <- renv_record_format_short(rhs)
    return(sprintf(fmt, lhsf, rhsf))
  }

  # check for only sha changed
  usesha <-
    setequal(changed, "RemoteSha") ||
    setequal(changed, c("RemoteSha", "Version"))

  if (usesha) {

    user <- lhs$RemoteUsername %||% "*"
    repo <- lhs$RemoteRepo %||% "*"
    spec <- paste(user, repo, sep = "/")

    ref <- lhs$RemoteRef %||% "*"
    if (!ref %in% c("master", "*"))
      spec <- paste(spec, ref, sep = "@")

    fmt <- "[%s: %s -> %s]"
    lsha <- substring(lhs$RemoteSha %||% "*", 1L, 8L)
    rsha <- substring(rhs$RemoteSha %||% "*", 1L, 8L)

    return(sprintf(fmt, spec, lsha, 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))
  }

  # check only version changed
  if (setequal(changed, "Version")) {
    fmt <- "[%s -> %s]"
    lhsf <- lhs$Version %||% "*"
    rhsf <- rhs$Version %||% "*"
    return(sprintf(fmt, lhsf, rhsf))
  }

  # if the source has changed, highlight that
  if ("Source" %in% changed) {
    fmt <- "[%s -> %s]"
    lhsf <- renv_record_format_short(lhs)
    rhsf <- renv_record_format_short(rhs)
    return(sprintf(fmt, lhsf, rhsf))
  }

  # otherwise, report each diff individually
  diffs <- map_chr(changed, function(field) {

    lhsf <- lhs[[field]] %||% "*"
    rhsf <- rhs[[field]] %||% "*"

    if (field == "RemoteSha") {
      lhsf <- substring(lhsf, 1L, 8L)
      rhsf <- substring(rhsf, 1L, 8L)
    }

    fmt <- "%s: %s -> %s"
    sprintf(fmt, map[[field]], lhsf, rhsf)
  })

  sprintf("[%s]", paste(diffs, collapse = "; "))

}

renv_records_equal <- function(lhs, rhs) {

  lhs <- reject(lhs, is.null)
  rhs <- reject(rhs, is.null)

  nm <- setdiff(union(names(lhs), names(rhs)), "Hash")
  identical(keep(lhs, nm), keep(rhs, nm))

}

renv_records_resolve <- function(records, latest = FALSE) {

  enumerate(records, function(package, record) {

    # check for already-resolved records
    if (is.null(record) || is.list(record))
      return(record)

    # check for version-only specifications and
    # prepend the package name in such a case
    pattern <- "^(?:[[:digit:]]+[.-]){1,}[[:digit:]]+$"
    if (grepl(pattern, record))
      record <- paste(package, record, sep = "@")

    # resolve the record
    renv_remotes_resolve(record, latest)

  })

}


# recurse.R ------------------------------------------------------------------


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
  if (is.recursive(object))
    for (i in seq_along(object))
      renv_recurse_impl(stack, object[[i]], callback, ...)

}


# refresh.R ------------------------------------------------------------------


#' Refresh the local cache of available packages
#'
#' Query the active R package repositories for available packages, and
#' update the in-memory cache of those packages.
#'
#' Note that \R also maintains its own on-disk cache of available packages,
#' which is used by `available.packages()`. Calling `refresh()` will force
#' an update of both types of caches. renv prefers using an in-memory
#' cache as on occasion the temporary directory can be slow to access (e.g.
#' when it is a mounted network filesystem).
#'
#' @return A list of package databases, invisibly -- one for each repository
#'   currently active in the \R session. Note that this function is normally
#'   called for its side effects.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # check available packages
#' db <- available.packages()
#'
#' # wait some time (suppose packages are uploaded / changed in this time)
#' Sys.sleep(5)
#'
#' # refresh the local available packages database
#' # (the old locally cached db will be removed)
#' db <- renv::refresh()
#'
#' }
refresh <- function() {

  pkgtype <- getOption("pkgType", default = "source")

  srcok <- pkgtype %in% c("both", "source") ||
    getOption("install.packages.check.source", default = "yes") %in% "yes"

  binok <- pkgtype %in% "both" ||
    grepl("binary", pkgtype, fixed = TRUE)

  list(
    binary = if (binok) available_packages(type = "binary", limit = 0L),
    source = if (srcok) available_packages(type = "source", limit = 0L)
  )

}


# regexps.R ------------------------------------------------------------------


renv_regexps_package_name <- function() {
  paste0("^", .standard_regexps()$valid_package_name, "$")
}

renv_regexps_package_version <- function() {
  paste0("^", .standard_regexps()$valid_package_version, "$")
}

renv_regexps_escape <- function(regexp) {
  pattern <- "([\\-\\[\\]\\{\\}\\(\\)\\*\\+\\?\\.\\,\\\\\\^\\$\\|\\#\\s])"
  gsub(pattern, "\\\\\\1", regexp, perl = TRUE)
}

renv_regexps_join <- function(regexps, capture = TRUE) {
  fmt <- if (capture) "(%s)" else "(?:%s)"
  sprintf(fmt, paste(regexps, collapse = "|"))
}


# rehash.R -------------------------------------------------------------------


#' Re-hash packages in the renv cache
#'
#' Re-hash packages in the renv cache, ensuring that any previously-cached
#' packages are copied to a new cache location appropriate for this version of
#' renv. This can be useful if the cache scheme has changed in a new version
#' of renv, but you'd like to preserve your previously-cached packages.
#'
#' Any packages which are re-hashed will retain links to the location of the
#' newly-hashed package, ensuring that prior installations of renv can still
#' function as expected.
#'
#' @inheritParams renv-params
#'
#' @export
rehash <- function(prompt = interactive(), ...) {
  renv_scope_error_handler()
  renv_dots_check(...)
  renv_scope_verbose_if(prompt)
  invisible(renv_rehash_impl(prompt))
}

renv_rehash_impl <- function(prompt) {

  # check for cache migration
  oldcache <- renv_paths_cache(version = renv_cache_version_previous())[[1L]]
  newcache <- renv_paths_cache(version = renv_cache_version())[[1L]]
  if (file.exists(oldcache) && !file.exists(newcache))
    renv_rehash_cache(oldcache, prompt, renv_file_copy, "copied")

  # re-cache packages as necessary
  renv_rehash_cache(newcache, prompt, renv_file_move, "moved")

}

renv_rehash_cache <- function(cache, prompt, action, label) {

  # re-compute package hashes
  old <- renv_cache_list(cache = cache)

  printf("- Re-computing package hashes ... ")
  new <- map_chr(old, renv_progress_callback(renv_cache_path, length(old)))
  writef("Done!")

  changed <- which(old != new & file.exists(old) & !file.exists(new))
  if (empty(changed)) {
    writef("- Your cache is already up-to-date -- nothing to do.")
    return(TRUE)
  }

  if (prompt) {

    fmt <- "%s [%s -> %s]"
    packages <- basename(old)[changed]
    oldhash <- renv_path_component(old[changed], 2L)
    newhash <- renv_path_component(new[changed], 2L)
    caution_bullets(
      "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)
    )

    cancel_if(prompt && !proceed())

  }

  sources <- old[changed]
  targets <- new[changed]
  names(sources) <- targets
  names(targets) <- sources

  printf("- Re-caching packages ... ")
  enumerate(targets, renv_progress_callback(action, length(targets)))
  writef("Done!")

  n <- length(targets)
  fmt <- "Successfully re-cached %s."
  writef(fmt, nplural("package", n))
  renv_cache_clean_empty()

  TRUE
}


# release.R ------------------------------------------------------------------


renv_release_preflight <- function() {

  ok <- all(
    renv_release_preflight_urlcheck()
  )

  if (!ok)
    stop("one or more pre-flight release checks failed")

  ok

}

renv_release_preflight_urlcheck <- function() {

  # check for bad URLs
  urlchecker <- renv_namespace_load("urlchecker")
  result <- urlchecker$url_check()

  # report to user
  print(result)

  # return success
  nrow(result) == 0L

}


# remotes.R ------------------------------------------------------------------


#' Resolve a Remote
#'
#' Given a remote specification, resolve it into an renv package record that
#' can be used for download and installation (e.g. with [install]).
#'
#' @param spec A remote specification. This should be a string, conforming
#'   to the Remotes specification as defined in
#'   <https://remotes.r-lib.org/articles/dependencies.html>.
#'
remote <- function(spec) {
  renv_scope_error_handler()
  renv_remotes_resolve(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) {

  # check for already-resolved specs
  if (is.null(spec) || is.list(spec))
    return(spec)

  # remove a trailing slash
  # https://github.com/rstudio/renv/issues/1135
  spec <- gsub("/+$", "", spec, perl = TRUE)

  # check for archive URLs -- this is a bit hacky
  if (grepl("^(?:file|https?)://", spec)) {
    for (suffix in c(".zip", ".tar.gz", ".tgz", "/tarball"))
      if (endswith(spec, suffix))
        return(renv_remotes_resolve_url(spec, quiet = TRUE))
  }

  # remove github prefix
  spec <- gsub("^https?://(?:www\\.)?github\\.com/", "", spec)

  # check for paths to existing local files
  first <- substring(spec, 1L, 1L)
  local <- first %in% c("~", "/", ".") || renv_path_absolute(spec)

  if (local) {
    record <- catch(renv_remotes_resolve_path(spec))
    if (!inherits(record, "error"))
      return(record)
  }

  # define error handler (tag error with extra context when possible)
  error <- function(e) {

    # build error message
    fmt <- "failed to resolve remote '%s'"
    prefix <- sprintf(fmt, spec)
    message <- paste(prefix, e$message, sep = " -- ")

    # otherwise, propagate the error
    stop(simpleError(message = message, call = e$call))

  }

  # attempt the parse
  withCallingHandlers(
    renv_remotes_resolve_impl(spec, latest),
    error = error
  )

}

renv_remotes_resolve_impl <- function(spec, latest = FALSE) {

  remote <- renv_remotes_parse(spec)

  # fixup for bioconductor
  isbioc <-
    identical(remote$type, "repository") &&
    identical(remote$repository, "bioc")

  if (isbioc)
    remote$type <- "bioc"

  resolved <- switch(
    remote$type,
    bioc       = renv_remotes_resolve_bioc(remote),
    bitbucket  = renv_remotes_resolve_bitbucket(remote),
    gitlab     = renv_remotes_resolve_gitlab(remote),
    github     = renv_remotes_resolve_github(remote),
    repository = renv_remotes_resolve_repository(remote, latest),
    git        = renv_remotes_resolve_git(remote),
    url        = renv_remotes_resolve_url(remote$url, quiet = TRUE),
    stopf("unknown remote type '%s'", remote$type %||% "<NA>")
  )

  # ensure that attributes on the record are preserved, but drop NULL entries
  for (key in names(resolved))
    if (is.null(resolved[[key]]))
      resolved[[key]] <- NULL

  resolved

}

renv_remotes_parse_impl <- function(spec, pattern, fields, perl = FALSE) {

  matches <- regexec(pattern, spec, perl = perl)
  strings <- regmatches(spec, matches)[[1]]
  if (empty(strings))
    stopf("'%s' is not a valid remote", spec)

  if (length(fields) != length(strings))
    stop("internal error: field length mismatch in renv_remotes_parse_impl")

  names(strings) <- fields
  remote <- as.list(strings)
  lapply(remote, function(item) if (nzchar(item)) item)

}

renv_remotes_parse_repos <- function(spec) {

  pattern <- paste0(
    "^",                                           # start
    "(?:([^:]+)::)?",                              # optional repository name
    "([[:alnum:].]+)",                             # package name
    "(?:@([[:digit:]_.-]+))?",                     # optional package version
    "$"
  )

  fields <- c("spec", "repository", "package", "version")
  renv_remotes_parse_impl(spec, pattern, fields)

}

renv_remotes_parse_remote <- function(spec) {

  pattern <- paste0(
    "^",
    "(?:([[: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)
    "$"
  )

  fields <- c(
    "spec", "package", "type",
    "host", "user", "repo",
    "subdir", "pull", "ref"
  )

  remote <- renv_remotes_parse_impl(spec, pattern, fields)
  if (!nzchar(remote$repo))
    stopf("'%s' is not a valid remote", spec)

  renv_remotes_parse_finalize(remote)

}

renv_remotes_parse_gitssh <- function(spec) {

  pattern <- paste0(
    "^",
    "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?",  # optional package name
    "(?:(git)::)?",                                 # optional git prefix
    "(",                                            # url start
      "([^@]+)@",                                   # user (typically, 'git')
      "([^:]+):",                                   # host
      "([^:#@]+)",                                  # the rest of the repo url
    ")",                                            # url end
    "(?::([^@#:]+))?",                              # optional sub-directory
    "(?:#([^@#:]+))?",                              # optional hash (e.g. pull request)
    "(?:@([^@#:]+))?",                              # optional ref (e.g. branch or commit)
    "$"
  )

  fields <- c(
    "spec", "package", "type", "url",
    "user", "host", "repo",
    "subdir", "pull", "ref"
  )

  remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE)
  if (!nzchar(remote$repo))
    stopf("'%s' is not a valid remote", spec)

  remote$type <- remote$type %||% "git"
  renv_remotes_parse_finalize(remote)

}

renv_remotes_parse_git <- function(spec) {

  hostpattern <- paste0(
    "(",
      "(?:(?:(?!-))(?:xn--|_{1,1})?[a-z0-9-]{0,61}[a-z0-9]{1,1}\\.)*",
      "(?:xn--)?",
      "(?:[a-z0-9][a-z0-9\\-]{0,60}|[a-z0-9-]{1,30}\\.[a-z]{2,})",
    ")"
  )

  pattern <- paste0(
    "^",
    "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?",  # optional package name
    "(?:(git)::)?",                                 # optional git prefix
    "(",                                            # URL start
      "(?:(https?|git|ssh)://)?",                   #   protocol
      "(?:([^@]+)@)?",                              #   login (probably git)
      hostpattern,                                  #   host
      "[/:]([\\w_.-]+)",                            #   a username
      "(?:/([^@#:]+?))?",                           #   a repository (allow sub-repositories)
      "(?:\\.(git))?",                              #   optional .git extension
    ")",                                            # URL end
    "(?::([^@#:]+))?",                              # optional sub-directory
    "(?:#([^@#:]+))?",                              # optional hash (e.g. pull request)
    "(?:@([^@#:]+))?",                              # optional ref (e.g. branch or commit)
    "$"
  )

  fields <- c(
    "spec", "package", "type",
    "url", "protocol", "login", "host", "user", "repo", "ext",
    "subdir", "pull", "ref"
  )

  remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE)
  if (!nzchar(remote$repo))
    stopf("'%s' is not a valid remote", spec)

  # If type has not been found & repo looks like a git repo, set it as git
  # (note that this parser also accepts entries which are not truly git
  # references, so we try to "fix up" after the fact)
  if ("git" %in% c(remote$login, remote$type, remote$ext, remote$protocol))
    remote$type <- tolower(remote$type %||% "git")

  renv_remotes_parse_finalize(remote)

}

# NOTE: to avoid ambiguity with git remote specs, we require URL
# remotes to begin with a 'url::' prefix
renv_remotes_parse_url <- function(spec) {

  pattern <- paste0(
    "^",
    "(?:([[:alpha:]][[:alnum:].]*[[:alnum:]])=)?",  # optional package name
    "(url)::",                                      # type (required for URL remotes)
    "((https?)://([^:]+))",                         # url, protocol, path
    "(?::([^@#:]+))?",                              # optional subdir
    "$"
  )

  fields <- c("spec", "package", "type", "url", "protocol", "path", "subdir")
  remote <- renv_remotes_parse_impl(spec, pattern, fields, perl = TRUE)
  if (!nzchar(remote$url))
    stopf("'%s' is not a valid remote", spec)

  renv_remotes_parse_finalize(remote)
}

renv_remotes_parse_finalize <- function(remote) {

  # default remote type is github
  remote$type <- tolower(remote$type %||% "github")

  # custom finalization for different remote types
  case(
    remote$type == "github" ~ renv_remotes_parse_finalize_github(remote),
    TRUE                    ~ remote
  )

}

renv_remotes_parse_finalize_github <- function(remote) {

  # split repo spec into pieces
  repo <- remote$repo %||% ""
  parts <- strsplit(repo, "/", fixed = TRUE)[[1]]
  if (length(parts) < 2)
    return(remote)

  # form subdir from tail of repo
  remote$repo   <- paste(head(parts, n = 1L),  collapse = "/")
  remote$subdir <- paste(tail(parts, n = -1L), collapse = "/")

  # return modified remote
  remote

}

renv_remotes_parse <- function(spec) {

  remote <- catch(renv_remotes_parse_repos(spec))
  if (!inherits(remote, "error")) {
    remote$type <- "repository"
    return(remote)
  }

  remote <- catch(renv_remotes_parse_remote(spec))
  if (!inherits(remote, "error")) {
    remote$type <- remote$type %||% "github"
    return(remote)
  }

  remote <- catch(renv_remotes_parse_gitssh(spec))
  if (!inherits(remote, "error")) {
    remote$type <- remote$type %||% "git"
    return(remote)
  }

  remote <- catch(renv_remotes_parse_url(spec))
  if (!inherits(remote, "error")) {
    remote$type <- remote$type %||% "url"
    return(remote)
  }

  remote <- catch(renv_remotes_parse_git(spec))
  if (!inherits(remote, "error")) {
    remote$type <- remote$type %||% "git"
    return(remote)
  }

  stopf("failed to parse remote spec '%s'", spec)

}

renv_remotes_resolve_bioc_version <- function(version) {

  # initialize Bioconductor
  renv_bioconductor_init()
  BiocManager <- renv_scope_biocmanager()

  # handle versions like 'release' and 'devel'
  versions <- BiocManager$.version_map()
  row <- versions[versions$BiocStatus == version, ]
  if (nrow(row))
    return(row$Bioc)

  # otherwise, use the default version
  BiocManager$version()

}

renv_remotes_resolve_bioc_plain <- function(remote) {

  list(
    Package = remote$package,
    Version = remote$version,
    Source  = "Bioconductor"
  )

}

renv_remotes_resolve_bioc <- function(remote) {

  # if we parsed this as a repository remote, use that directly
  if (!is.null(remote$package))
    return(renv_remotes_resolve_bioc_plain(remote))

  # otherwise, this was parsed as a regular remote, declaring the package
  # should be obtained from a particular Bioconductor release
  package <- remote$repo
  biocversion <- renv_remotes_resolve_bioc_version(remote$user)
  biocrepos <- renv_bioconductor_repos(version = biocversion)
  record <- renv_available_packages_latest(package, repos = biocrepos)

  # update fields
  record$Source <- "Bioconductor"
  record$Repository <- NULL

  # return the resolved record
  record

}

renv_remotes_resolve_bitbucket <- function(remote) {

  user   <- remote$user
  repo   <- remote$repo
  subdir <- remote$subdir
  ref    <- remote$ref %||% getOption("renv.bitbucket.default_branch", "master")

  host <- remote$host %||% config$bitbucket.host()

  # scope authentication
  renv_scope_auth(repo)

  # get commit sha for ref
  fmt <- "%s/repositories/%s/%s/commit/%s"
  origin <- renv_retrieve_origin(host)
  url <- sprintf(fmt, origin, user, repo, ref)

  destfile <- renv_scope_tempfile("renv-bitbucket-")
  download(url, destfile = destfile, type = "bitbucket", quiet = TRUE)
  json <- renv_json_read(file = destfile)
  sha <- json$hash

  # get DESCRIPTION file
  fmt <- "%s/repositories/%s/%s/src/%s/DESCRIPTION"
  origin <- renv_retrieve_origin(host)
  url <- sprintf(fmt, origin, user, repo, ref)

  destfile <- renv_scope_tempfile("renv-description-")
  download(url, destfile = destfile, type = "bitbucket", quiet = TRUE)
  desc <- renv_dcf_read(destfile)

  list(
    Package        = desc$Package,
    Version        = desc$Version,
    Source         = "Bitbucket",
    RemoteType     = "bitbucket",
    RemoteHost     = host,
    RemoteUsername = user,
    RemoteRepo     = repo,
    RemoteSubdir   = subdir,
    RemoteRef      = ref,
    RemoteSha      = sha
  )

}

renv_remotes_resolve_repository <- function(remote, latest) {

  package <- remote$package
  if (package %in% renv_packages_base())
    return(renv_remotes_resolve_base(package))

  version <- remote$version
  repository <- remote$repository

  if (latest && is.null(version)) {
    remote <- renv_available_packages_latest(package)
    version <- remote$Version
  }

  list(
    Package    = package,
    Version    = version,
    Source     = "Repository",
    Repository = repository
  )

}

renv_remotes_resolve_base <- function(package) {

  list(
    Package = package,
    Version = renv_package_version(package),
    Source  = "R"
  )

}

renv_remotes_resolve_github_sha_pull <- function(host, user, repo, pull) {

  # scope authentication
  renv_scope_auth(repo)

  # make request
  fmt <- "%s/repos/%s/%s/pulls/%s"
  origin <- renv_retrieve_origin(host)
  url <- sprintf(fmt, origin, user, repo, pull)
  jsonfile <- renv_scope_tempfile("renv-json-")
  download(url, destfile = jsonfile, type = "github", quiet = TRUE)

  # read resulting JSON
  json <- renv_json_read(jsonfile)
  json$head$sha

}

renv_remotes_resolve_github_sha_ref <- function(host, user, repo, ref) {

  # scope authentication
  renv_scope_auth(repo)

  # 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")

  # prepare headers
  headers <- c(Accept = "application/vnd.github.sha")

  # make request to endpoint
  shafile <- renv_scope_tempfile("renv-sha-")
  download(
    url,
    destfile = shafile,
    type = "github",
    quiet = TRUE,
    headers = headers
  )

  # read downloaded content
  sha <- renv_file_read(shafile)

  # check for JSON response (in case our headers weren't sent)
  if (nchar(sha) > 40L) {
    json <- renv_json_read(text = sha)
    sha <- json$sha
  }

  sha

}

renv_remotes_resolve_github_modules <- function(host, user, repo, subdir, sha) {

  # form path to .gitmodules file
  subdir <- subdir %||% ""
  parts <- c(
    if (nzchar(subdir)) URLencode(subdir),
    ".gitmodules"
  )

  path <- paste(parts, collapse = "/")

  # scope authentication
  renv_scope_auth(repo)

  # add headers
  headers <- c(Accept = "application/vnd.github.raw")

  # get the file contents
  fmt <- "%s/repos/%s/%s/contents/%s?ref=%s"
  origin <- renv_retrieve_origin(host)
  url <- sprintf(fmt, origin, user, repo, path, sha)
  jsonfile <- renv_scope_tempfile("renv-json-")
  status <- suppressWarnings(
    catch(
      download(url, destfile = jsonfile, type = "github", quiet = TRUE, headers = headers)
    )
  )

  # just return a status code whether or not submodules are included
  !inherits(status, "error")

}

renv_remotes_resolve_github_description <- function(host, user, repo, subdir, sha) {

  # form DESCRIPTION path
  subdir <- subdir %||% ""
  parts <- c(
    if (nzchar(subdir)) URLencode(subdir),
    "DESCRIPTION"
  )

  descpath <- paste(parts, collapse = "/")

  # scope authentication
  renv_scope_auth(repo)

  # add headers
  headers <- c(
    Accept = "application/vnd.github.raw",
    renv_download_auth_github()
  )

  # get the DESCRIPTION contents
  fmt <- "%s/repos/%s/%s/contents/%s?ref=%s"
  origin <- renv_retrieve_origin(host)
  url <- sprintf(fmt, origin, user, repo, descpath, sha)
  destfile <- renv_scope_tempfile("renv-json-")
  download(url, destfile = destfile, type = "github", quiet = TRUE, headers = headers)

  # try to read the file; detect JSON versus raw content in case
  # headers were not sent for some reason
  contents <- renv_file_read(destfile)
  if (substring(contents, 1L, 1L) == "{") {
    json <- renv_json_read(text = contents)
    contents <- renv_base64_decode(json$content)
  }

  # normalize newlines
  contents <- gsub("\r\n", "\n", contents, fixed = TRUE)

  # read as DCF
  renv_dcf_read(text = contents)

}

renv_remotes_resolve_github_ref <- function(host, user, repo) {

  tryCatch(
    renv_remotes_resolve_github_ref_impl(host, user, repo),
    error = function(e) {
      warning(e)
      getOption("renv.github.default_branch", default = "master")
    }
  )

}

renv_remotes_resolve_github_ref_impl <- function(host, user, repo) {

  # scope authentication
  renv_scope_auth(repo)

  # build url to repos endpoint
  fmt <- "%s/repos/%s/%s"
  origin <- renv_retrieve_origin(host)
  url <- sprintf(fmt, origin, user, repo)

  # download JSON data at endpoint
  jsonfile <- renv_scope_tempfile("renv-github-ref-", fileext = ".json")
  download(url, destfile = jsonfile, type = "github", quiet = TRUE)
  json <- renv_json_read(jsonfile)

  # read default branch
  json$default_branch %||% getOption("renv.github.default_branch", default = "master")

}

renv_remotes_resolve_github <- function(remote) {

  # resolve the reference associated with this repository
  host   <- remote$host %||% config$github.host()
  user   <- remote$user
  repo   <- remote$repo
  spec   <- remote$spec
  subdir <- remote$subdir

  # resolve ref
  ref <- remote$ref %||% renv_remotes_resolve_github_ref(host, user, repo)

  # handle '*release' refs
  if (identical(ref, "*release"))
    ref <- renv_remotes_resolve_github_release(host, user, repo, spec)

  # resolve the sha associated with the ref / pull
  pull   <- remote$pull %||% ""
  sha <- case(
    nzchar(pull) ~ renv_remotes_resolve_github_sha_pull(host, user, repo, pull),
    nzchar(ref)  ~ renv_remotes_resolve_github_sha_ref(host, user, repo, ref)
  )

  # if an abbreviated sha was provided as the ref, expand it here
  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 = "/")
  }

  # read DESCRIPTION
  desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha)

  list(
    Package        = desc$Package,
    Version        = desc$Version,
    Source         = if (modules) "git" else "GitHub",
    RemoteType     = if (modules) "git" else "github",
    RemoteUrl      = if (modules) url,
    RemoteHost     = host,
    RemoteUsername = user,
    RemoteRepo     = repo,
    RemoteSubdir   = subdir,
    RemoteRef      = ref,
    RemoteSha      = sha
  )

}

renv_remotes_resolve_github_release <- function(host, user, repo, spec) {

  # scope authentication
  renv_scope_auth(repo)

  # build url for github releases endpoint
  fmt <- "%s/repos/%s/%s/releases?per_page=1"
  origin <- renv_retrieve_origin(host)
  url <- sprintf(fmt, origin, user, repo)

  # prepare headers
  headers <- c(Accept = "application/vnd.github.raw+json")

  # make request to endpoint
  releases <- renv_scope_tempfile("renv-releases-")
  download(
    url      = url,
    destfile = releases,
    type     = "github",
    quiet    = TRUE,
    headers  = headers
  )

  # get reference associated with this tag
  json <- renv_json_read(releases)
  if (empty(json)) {
    fmt <- "could not find any releases associated with remote '%s'"
    stopf(fmt, sub("[*]release$", "", spec))
  }

  json[[1L]][["tag_name"]]

}

renv_remotes_resolve_git <- function(remote) {

  package <- remote$package %||% basename(remote$repo)
  url     <- remote$url
  subdir  <- remote$subdir

  # handle git ref
  pull <- remote$pull %||% ""
  ref  <- remote$ref %||% ""

  # resolve ref from pull if set
  if (nzchar(pull))
    ref <- renv_remotes_resolve_git_pull(ref)

  record <- list(
    Package        = package,
    Version        = "<unknown>",
    Source         = "git",
    RemoteType     = "git",
    RemoteUrl      = url,
    RemoteSubdir   = subdir,
    RemoteRef      = ref
  )

  desc <- renv_remotes_resolve_git_description(record)

  record$Package <- desc$Package
  record$Version <- desc$Version

  record
}


renv_remotes_resolve_git_sha_ref <- function(record) {

  renv_git_preflight()

  origin <- record$RemoteUrl
  ref <- record$RemoteRef %||% record$RemoteSha
  args <- c("ls-remote", origin, ref)

  output <- local({
    renv_scope_auth(record)
    renv_scope_git_auth()
    renv_system_exec("git", args, "checking git remote")
  })

  if (empty(output))
    return("")

  # format of output is, for example:
  #
  #   $ git ls-remote https://github.com/rstudio/renv refs/tags/0.14.0
  #   20ca74bdcc3c87848e5665effa2fc8ee8b039c69        refs/tags/0.14.0
  #
  # take first line of output, split on tab character, and take leftmost entry
  strsplit(output[[1L]], "\t", fixed = TRUE)[[1L]][[1L]]

}


renv_remotes_resolve_git_description <- function(record) {

  path <- renv_scope_tempfile("renv-git-")
  ensure_directory(path)

  # TODO: is there a cheaper way for us to accomplish this?
  # it'd be nice if we could retrieve the contents of a single
  # file, without needing to pull an entire repository branch
  local({
    renv_scope_options(renv.verbose = FALSE)
    renv_retrieve_git_impl(record, path)
  })

  # subdir may be NULL
  subdir <- record$RemoteSubdir
  desc <- renv_description_read(path, subdir = subdir)

  desc
}

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
}

renv_remotes_resolve_gitlab_ref <- function(host, user, repo) {

  tryCatch(
    renv_remotes_resolve_gitlab_ref_impl(host, user, repo),
    error = function(e) {
      warning(e)
      getOption("renv.gitlab.default_branch", default = "master")
    }
  )

}

renv_remotes_resolve_gitlab_ref_impl <- function(host, user, repo) {

  # scope authentication
  renv_scope_auth(repo)

  # get list of available branches
  fmt <- "%s/api/v4/projects/%s/repository/branches"
  origin <- renv_retrieve_origin(host)
  id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE)
  url <- sprintf(fmt, origin, id)

  destfile <- renv_scope_tempfile("renv-gitlab-commits-")
  download(url, destfile = destfile, type = "gitlab", quiet = TRUE)
  json <- renv_json_read(file = destfile)

  # iterate through and find the default
  for (info in json)
    if (identical(info$default, TRUE))
      return(info$name)

  # if no default was found, use master branch
  # (for backwards compatibility with existing projects)
  getOption("renv.gitlab.default_branch", default = "master")

}

renv_remotes_resolve_gitlab <- function(remote) {

  host   <- remote$host %||% config$gitlab.host()
  user   <- remote$user
  repo   <- remote$repo
  subdir <- remote$subdir %||% ""

  ref <- remote$ref %||% renv_remotes_resolve_gitlab_ref(host, user, repo)

  parts <- c(if (nzchar(subdir)) subdir, "DESCRIPTION")
  descpath <- URLencode(paste(parts, collapse = "/"), reserved = TRUE)

  # scope authentication
  renv_scope_auth(repo)

  # retrieve sha associated with this ref
  fmt <- "%s/api/v4/projects/%s/repository/commits/%s"
  origin <- renv_retrieve_origin(host)
  id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE)
  ref <- URLencode(ref, reserved = TRUE)
  url <- sprintf(fmt, origin, id, ref)

  destfile <- renv_scope_tempfile("renv-gitlab-commits-")
  download(url, destfile = destfile, type = "gitlab", quiet = TRUE)
  json <- renv_json_read(file = destfile)
  sha <- json$id

  # retrieve DESCRIPTION file
  fmt <- "%s/api/v4/projects/%s/repository/files/%s/raw?ref=%s"
  origin <- renv_retrieve_origin(host)
  id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE)
  url <- sprintf(fmt, origin, id, descpath, ref)

  destfile <- renv_scope_tempfile("renv-description-")
  download(url, destfile = destfile, type = "gitlab", quiet = TRUE)
  desc <- renv_dcf_read(destfile)

  list(
    Package        = desc$Package,
    Version        = desc$Version,
    Source         = "GitLab",
    RemoteType     = "gitlab",
    RemoteHost     = host,
    RemoteUsername = user,
    RemoteRepo     = repo,
    RemoteSubdir   = subdir,
    RemoteRef      = ref,
    RemoteSha      = sha
  )

}

renv_remotes_resolve_url <- function(url, quiet = FALSE) {

  tempfile <- renv_scope_tempfile("renv-url-")
  writeLines(url, con = tempfile)
  hash <- tools::md5sum(tempfile)

  ext <- fileext(url, default = ".tar.gz")
  name <- paste(hash, ext, sep = "")
  path <- renv_paths_source("url", name)

  ensure_parent_directory(path)
  download(url, path, quiet = quiet)

  desc <- renv_description_read(path)

  list(
    Package    = desc$Package,
    Version    = desc$Version,
    Source     = "URL",
    RemoteType = "url",
    RemoteUrl  = url,
    Path       = path
  )

}

renv_remotes_resolve_path <- function(path) {

  # if this package lives within one of the cellar paths,
  # then treat it as a cellar source
  roots <- renv_cellar_roots()
  for (root in roots)
    if (renv_path_within(path, root))
      return(renv_remotes_resolve_path_cellar(path))

  # first, check for a common extension
  if (renv_archive_type(path) %in% c("tar", "zip"))
    return(renv_remotes_resolve_path_impl(path))

  # otherwise, if this is the path to a package project, use the sources as-is
  if (renv_project_type(path) == "package")
    return(renv_remotes_resolve_path_impl(path))

  stopf("there is no package at path '%s'", path)

}

renv_remotes_resolve_path_cellar <- function(path) {

  desc <- renv_description_read(path)
  list(
    Package    = desc$Package,
    Version    = desc$Version,
    Source     = "Cellar",
    Cacheable  = FALSE
  )

}

renv_remotes_resolve_path_impl <- function(path) {

  desc <- renv_description_read(path)
  list(
    Package    = desc$Package,
    Version    = desc$Version,
    Source     = "Local",
    RemoteType = "local",
    RemoteUrl  = path,
    Cacheable  = FALSE
  )

}


# remove.R -------------------------------------------------------------------


#' Remove packages
#'
#' Remove (uninstall) \R packages.
#'
#' @inherit renv-params
#'
#' @param packages A character vector of \R packages to remove.
#' @param library The library from which packages should be removed. When
#'   `NULL`, the active library (that is, the first entry reported in
#'   `.libPaths()`) is used instead.
#'
#' @return A vector of package records, describing the packages (if any) which
#'   were successfully removed.
#'
#' @export
#'
#' @example examples/examples-init.R
remove <- function(packages,
                   ...,
                   library = NULL,
                   project = NULL)
{
  renv_scope_error_handler()
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  library <- renv_path_normalize(library %||% renv_libpaths_active())

  # NOTE: users might request that we remove packages which aren't currently
  # installed, so we need to catch errors when trying to snapshot those packages
  descpaths <- file.path(library, packages, "DESCRIPTION")
  records <- lapply(descpaths, compose(catch, renv_snapshot_description))
  names(records) <- packages
  records <- Filter(function(record) !inherits(record, "error"), records)

  if (library == renv_paths_library(project = project)) {
    writef("- Removing package(s) from project library ...")
  } else {
    fmt <- "- Removing package(s) from library '%s' ..."
    writef(fmt, renv_path_aliased(library))
  }

  if (length(packages) == 1) {
    renv_remove_impl(packages, library)
    return(invisible(records))
  }

  count <- 0
  for (package in packages) {
    if (renv_remove_impl(package, library))
      count <- count + 1
  }

  writef("- Done! Removed %s.", nplural("package", count))
  invisible(records)
}

renv_remove_impl <- function(package, library) {

  path <- file.path(library, package)
  if (!renv_file_exists(path)) {
    writef("- Package '%s' is not installed -- nothing to do.", package)
    return(FALSE)
  }

  recursive <- renv_file_type(path) == "directory"
  printf("Removing package '%s' ... ", package)
  unlink(path, recursive = recursive)
  writef("Done!")

  TRUE

}


# renv-package.R -------------------------------------------------------------


#' Project-local Environments for R
#'
#' Project-local environments for \R.
#'
#' You can use renv to construct isolated, project-local \R libraries.
#' 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"


# renvignore.R ---------------------------------------------------------------


# given a path within a project, read all relevant ignore files
# and generate a pattern that can be used to filter file results
renv_renvignore_pattern <- function(path = getwd(), root = path) {

  if (is.null(root))
    return(NULL)

  stopifnot(
    renv_path_absolute(path),
    renv_path_absolute(root)
  )

  # prepare ignores
  ignores <- stack()

  # read ignore files
  parent <- path
  while (parent != dirname(parent)) {

    # attempt to read either .renvignore or .gitignore
    for (file in c(".renvignore", ".gitignore")) {
      candidate <- file.path(parent, file)
      if (file.exists(candidate)) {
        contents <- readLines(candidate, warn = FALSE)
        parsed <- renv_renvignore_parse(contents, parent)
        if (length(parsed))
          ignores$push(parsed)
        break
      }
    }

    # stop once we've hit the project root
    if (parent == root)
      break

    parent <- dirname(parent)

  }

  # collect patterns read
  patterns <- ignores$data()

  # separate exclusions, exclusions
  include <- unlist(extract(patterns, "include"))
  exclude <- unlist(extract(patterns, "exclude"))

  # allow for inclusion / exclusion via option
  # (primarily intended for internal use with packrat)
  include <- c(include, renv_renvignore_pattern_extra("include", root))
  exclude <- c(exclude, renv_renvignore_pattern_extra("exclude", root))

  # ignore hidden directories by default
  exclude <- c("/[.][^/]*/$", exclude)

  list(include = include, exclude = exclude)

}

# 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 = "") {

  # read the ignore entries
  contents <- grep("^\\s*(?:#|$)", contents, value = TRUE, invert = TRUE)
  if (empty(contents))
    return(list())

  # split into inclusion, exclusion patterns
  negate <- substring(contents, 1L, 1L) == "!"
  exclude <- contents[!negate]
  include <- substring(contents[negate], 2L)

  # For include rules, if we're explicitly including a file within
  # a sub-directory, then we need to force all parent directories
  # to also be included. In other words, a rule like:
  #
  #    !a/b/c
  #
  # needs to be implicitly treated like
  #
  #    !/a
  #    !/a/b
  #    !/a/b/c
  #
  # so we perform that transformation here.
  #
  # Note that this isn't perfect; for example, with the .gitignore file
  #
  #    dir
  #    !dir/matched
  #
  # 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) {
    idx <- gregexpr("(?:/|$)", rule, perl = TRUE)[[1L]]
    gsub("^/*", "/", substring(rule, 1L, idx))
  }))))

  # parse patterns separately
  list(
    exclude = renv_renvignore_parse_impl(exclude, prefix),
    include = renv_renvignore_parse_impl(include, prefix)
  )

}

renv_renvignore_parse_impl <- function(entries, prefix = "") {

  # check for empty entries list
  if (empty(entries))
    return(character())

  # remove trailing whitespace
  entries <- gsub("\\s+$", "", entries)

  # entries without a slash (other than a trailing one) should match in tree
  noslash <- grep("/", gsub("/*$", "", entries), fixed = TRUE, invert = TRUE)
  entries[noslash] <- paste("**", entries[noslash], sep = "/")

  # remove a leading slash (avoid double-slashing)
  entries <- gsub("^/+", "", entries)

  # save any '**' entries seen
  entries <- gsub("**/",  "\001", entries, fixed = TRUE)
  entries <- gsub("/**",  "\002", entries, fixed = TRUE)

  # transform '*' and '?'
  entries <- gsub("*", "\\E[^/]*\\Q", entries, fixed = TRUE)
  entries <- gsub("?", "\\E[^/]\\Q",  entries, fixed = TRUE)

  # restore '**' entries
  entries <- gsub("\001", "\\E(?:.*/)?\\Q", entries, fixed = TRUE)
  entries <- gsub("\002", "/\\E.*\\Q",      entries, fixed = TRUE)

  # if we don't have a trailing slash, then we can match both files and dirs
  noslash <- grep("/$", entries, invert = TRUE)
  entries[noslash] <- paste0(entries[noslash], "\\E(?:/)?\\Q")

  # enclose in \\Q \\E to ensure e.g. plain '.' are not treated
  # as regex characters
  entries <- sprintf("\\Q%s\\E$", entries)

  # prepend prefix
  entries <- sprintf("^\\Q%s/\\E%s", prefix, entries)

  # remove \\Q\\E
  entries <- gsub("\\Q\\E", "", entries, fixed = TRUE)

  # all done!
  entries

}

renv_renvignore_exec <- function(path, root, children) {

  # the root directory is always included
  if (identical(root, children))
    return(FALSE)

  # compute exclusion patterns
  patterns <- renv_renvignore_pattern(path, root)

  # if we have no patterns, then we're not excluding anything
  if (empty(patterns) || empty(patterns$exclude))
    return(logical(length(children)))

  # append slashes to files which are directories
  info <- renv_file_info(children)
  dirs <- info$isdir %in% TRUE
  children[dirs] <- paste0(children[dirs], "/")

  # get the entries that need to be excluded
  excludes <- logical(length = length(children))
  for (pattern in patterns$exclude)
    if (nzchar(pattern))
      excludes <- excludes | grepl(pattern, children, perl = TRUE)

  if (length(patterns$include)) {

    # check for entries that should be explicitly included
    # (note that these override any excludes)
    includes <- logical(length = length(children))
    for (pattern in patterns$include)
      if (nzchar(pattern))
        includes <- includes | grepl(pattern, children, perl = TRUE)

    # unset those excludes
    excludes[includes] <- FALSE

  }

  # return vector of excludes
  excludes

}

renv_renvignore_pattern_extra <- function(key, root) {

  # check for value from option
  optname <- paste("renv.renvignore", key, sep = ".")
  patterns <- getOption(optname)
  if (is.null(patterns))
    return(NULL)

  # should we use the pattern as-is?
  asis <- attr(patterns, "asis", exact = TRUE)
  if (identical(asis, TRUE))
    return(patterns)

  # otherwise, process it as an .renvignore-style ignore
  root <- attr(patterns, "root", exact = TRUE) %||% root
  patterns <- renv_renvignore_parse(patterns, root)
  patterns[[key]]

}


# repair.R -------------------------------------------------------------------


#' Repair a project
#'
#' Use `repair()` to recover from some common issues that can occur with
#' a project. Currently, two operations are performed:
#'
#' 1. Packages with broken symlinks into the cache will be re-installed.
#'
#' 2. Packages that were installed from sources, but appear to be from
#'    an remote source (e.g. GitHub), will have their `DESCRIPTION` files
#'    updated to record that remote source explicitly.
#'
#' @inheritParams renv-params
#'
#' @param lockfile The path to a lockfile (if any). When available, renv
#'   will use the lockfile when attempting to infer the remote associated
#'   with the inaccessible version of each missing package. When `NULL`
#'   (the default), the project lockfile will be used.
#'
#' @export
repair <- function(library  = NULL,
                   lockfile = NULL,
                   project  = NULL)
{
  renv_consent_check()
  renv_scope_error_handler()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  libpaths <- renv_path_normalize(library %||% renv_libpaths_all())
  library <- libpaths[[1L]]

  writef(header("Library cache links"))
  renv_repair_links(library, lockfile, project)
  writef()

  writef(header("Package sources"))
  renv_repair_sources(library, lockfile, project)
  writef()

  invisible()
}

renv_repair_links <- function(library, lockfile, project) {


  # figure out which library paths (junction points?) appear to be broken
  paths <- list.files(library, full.names = TRUE)
  broken <- renv_file_broken(paths)
  packages <- basename(paths[broken])
  if (empty(packages)) {
    writef("- No issues found with the project library's cache links.")
    return(invisible(packages))
  }

  # try to find records for these packages in the lockfile
  # TODO: what if one of the requested packages isn't in the lockfile?
  lockfile <- lockfile %||% renv_lockfile_load(project = project)
  records <- renv_repair_records(packages, lockfile, project)

  # install these records
  install(
    packages = records,
    library  = library,
    project  = project
  )

}

renv_repair_records <- function(packages, lockfile, project) {
  map(packages, function(package) {
    lockfile$Packages[[package]] %||% package
  })
}

renv_repair_sources <- function(library, lockfile, project) {

  # get package description files
  db <- installed_packages(lib.loc = library, priority = NA_character_)
  descpaths <- with(db, file.path(LibPath, Package, "DESCRIPTION"))
  dcfs <- map(descpaths, renv_description_read)
  names(dcfs) <- map_chr(dcfs, `[[`, "Package")

  # try to infer sources as necessary
  inferred <- map(dcfs, renv_repair_sources_infer)
  inferred <- filter(inferred, Negate(is.null))
  if (length(inferred) == 0L) {
    writef("- All installed packages appear to be from a known source.")
    return(TRUE)
  }

  # ask used
  renv_scope_options(renv.verbose = TRUE)
  caution_bullets(
    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."
    ),
    sprintf("%s  [%s]", format(names(inferred)), inferred),
    "`renv::restore()` may fail for packages without an explicitly-declared remote source."
  )

  choice <- menu(

    choices =  c(
      update = "Let renv infer the remote sources for these packages.",
      cancel = "Do nothing and resolve the situation another way."
    ),

    title = "What would you like to do?"

  )

  cancel_if(identical(choice, "cancel"))

  enumerate(inferred, function(package, remote) {
    record <- renv_remotes_resolve(remote)
    record[["RemoteSha"]] <- NULL
    renv_package_augment(file.path(library, package), record)
  })

  n <- length(inferred)
  writef("- Updated %i package DESCRIPTION %s.", n, nplural("file", n))

  TRUE

}

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]]))
      return(NULL)

  # ok, this is a package installed from sources that "looks" like
  # the development version of a package; try to guess its remote
  guess <- function(pattern, field) {
    urls <- strsplit(dcf[[field]] %||% "", "\\s*,\\s*")[[1L]]
    for (url in urls) {
      matches <- regmatches(url, regexec(pattern, url, perl = TRUE))[[1L]]
      if (length(matches) == 3L)
        return(paste(matches[[2L]], matches[[3L]], sep = "/"))
    }
  }

  # first, check bug reports
  remote <- guess("^https://(?:www\\.)?github\\.com/([^/]+)/([^/]+)/issues$", "BugReports")
  if (!is.null(remote))
    return(remote)

  # next, check the URL field
  remote <- guess("^https://(?:www\\.)?github\\.com/([^/]+)/([^/]+)", "URL")
  if (!is.null(remote))
    return(remote)

}


# report.R -------------------------------------------------------------------


renv_report_ok <- function(message, elapsed = 0) {

  # treat 'quick' times specially
  if (!testing() && elapsed < 0.1)
    return(writef("OK [%s]", message))

  # otherwise, report step with elapsed time
  fmt <- "OK [%s in %s]"
  writef(fmt, message, renv_difftime_format_short(elapsed))

}


# repos.R --------------------------------------------------------------------


renv_repos_normalize <- function(repos = getOption("repos")) {

  # ensure repos are a character vector
  repos <- convert(repos, "character")

  # force a CRAN mirror when needed
  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
  }

  # return normalized repository
  repos

}

renv_repos_validate <- function(repos = getOption("repos")) {

  # allow empty repository explicitly
  if (empty(repos))
    return(character())

  # otherwise, ensure it's a named list or character vector
  ok <- is.list(repos) || is.character(repos)
  if (!ok)
    stopf("repos has unexpected type '%s'", typeof(repos))

  # read repository names
  nm <- names(repos) %||% rep.int("", length(repos))
  if (any(nm %in% "")) {

    # if this is a length-one repository, assume it's CRAN
    if (length(repos) == 1L) {
      repos <- c(CRAN = repos)
      return(renv_repos_normalize(repos))
    }

    # otherwise, error
    stopf("all repository entries must be named")

  }

  # normalize the repos option
  renv_repos_normalize(repos)

}

renv_repos_info <- function(url) {

  memoize(
    key   = url,
    value = renv_repos_info_impl(url)
  )

}

renv_repos_info_impl <- function(url) {

  # make sure the repository URL includes a trailing slash
  url <- gsub("/*$", "/", url)

  # if this is a file repository, return early
  if (grepl("^file:", url))
    return(list(nexus = FALSE))

  # try to download it
  destfile <- renv_scope_tempfile("renv-repos-")
  status <- catch(download(url, destfile = destfile, quiet = TRUE))
  if (inherits(status, "error"))
    return(status)

  # read the contents of the page
  contents <- renv_file_read(destfile)

  # determine if this is a Nexus repository
  nexus <-
    grepl("Nexus Repository Manager", contents, fixed = TRUE) ||
    grepl("<div class=\"nexus-header\">", contents, fixed = TRUE)

  list(
    nexus = nexus
  )

}


# restart.R ------------------------------------------------------------------


# whether or not we're already trying to restart the session
the$restarting <- FALSE

renv_restart_request <- function(project = NULL, reason = "", ...) {

  project <- renv_project_resolve(project)

  # if we're running in RStudio, explicitly open the project
  # if it differs from the current project
  if (renv_rstudio_available()) {
    status <- renv_restart_request_rstudio(project, reason, ...)
    return(invisible(status))
  }

  renv_restart_request_default(project, reason, ...)

}

renv_restart_request_default <- function(project, reason, ...) {

  # use 'restart' helper defined by front-end (if any)
  restart <- getOption("restart")
  if (is.function(restart))
    return(renv_restart_invoke(restart))

  # otherwise, ask the user to restart
  if (interactive()) {
    fmt <- "- %s -- please restart the R session."
    writef(fmt, sprintf(reason, ...))
  }

}

renv_restart_request_rstudio <- function(project, reason, ...) {

  # if we're running tests, don't restart
  if (renv_tests_running())
    return(renv_restart_request_default(project, reason, ...))

  # if we don't have a tools env, bail
  tools <- catch(as.environment("tools:rstudio"))
  if (inherits(tools, "error"))
    return(renv_restart_request_default(project, reason, ...))

  # if RStudio is too old, use default restart impl
  old <-
    is.null(tools$.rs.getProjectDirectory) ||
    is.null(tools$.rs.api.openProject)

  if (old)
    return(renv_restart_request_default(project, reason, ...))

  # if the requested project matches the current project, just
  # restart the R session -- but note that we cannot respect
  # the 'restart' option here as the version RStudio uses
  # tries to preserve session state that we need to change.
  #
  # https://github.com/rstudio/renv/issues/1530
  projdir <- tools$.rs.getProjectDirectory() %||% ""
  if (renv_file_same(projdir, project)) {
    restart <- getOption("renv.restart.function", default = function() {
      tools$.rs.api.executeCommand("restartR", quiet = TRUE)
    })
    return(renv_restart_invoke(restart))
  }

  # otherwise, explicitly open the new project
  renv_restart_invoke(function() {
    invisible(tools$.rs.api.openProject(project, newSession = FALSE))
  })

}

renv_restart_invoke <- function(callback) {

  # avoid multiple attempts to restart in a single call, just in case
  if (!the$restarting) {
    the$restarting <- TRUE
    callback()
  }

}


# restore.R ------------------------------------------------------------------


the$restore_running <- FALSE
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
#' 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.
#'
#' @inherit renv-params
#'
#' @param library The library paths to be used during restore. See **Library**
#'   for details.
#'
#' @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 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
#'  as the recursive dependency of another package, your request will be
#'  ignored.
#'
#' @return A named list of package records which were installed by renv.
#'
#' @family reproducibility
#'
#' @export
#'
#' @example examples/examples-init.R
restore <- function(project  = NULL,
                    ...,
                    library  = NULL,
                    lockfile = NULL,
                    packages = NULL,
                    exclude  = NULL,
                    rebuild  = FALSE,
                    repos    = NULL,
                    clean    = FALSE,
                    prompt   = interactive())
{
  renv_consent_check()
  renv_scope_error_handler()
  renv_dots_check(...)

  renv_scope_binding(the, "restore_running", TRUE)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_scope_verbose_if(prompt)

  # resolve library, lockfile arguments
  libpaths <- renv_libpaths_resolve(library)
  lockfile <- lockfile %||% renv_lockfile_load(project = project, strict = TRUE)

  # check and ask user if they need to activate first
  renv_activate_prompt("restore", library, prompt, project)

  # activate the requested library (place at front of library paths)
  library <- nth(libpaths, 1L)
  ensure_directory(library)
  renv_scope_libpaths(libpaths)

  # resolve the lockfile
  if (is.character(lockfile))
    lockfile <- renv_lockfile_read(lockfile)

  # inject overrides (if any)
  lockfile <- renv_lockfile_override(lockfile)

  # repair potential issues in the lockfile
  lockfile <- renv_lockfile_repair(lockfile)

  # override repositories if requested
  repos <- repos %||% config$repos.override() %||% lockfile$R$Repositories

  # transform PPM repositories if appropriate
  if (renv_ppm_enabled())
    repos <- renv_ppm_transform(repos)

  if (length(repos))
    renv_scope_options(repos = convert(repos, "character"))

  # if users have requested the use of pak, delegate there
  if (config$pak.enabled() && !recursing()) {
    renv_pak_init()
    renv_pak_restore(
      lockfile = lockfile,
      packages = packages,
      exclude  = exclude,
      project  = project
    )
  }

  # set up Bioconductor version + repositories
  biocversion <- lockfile$Bioconductor$Version
  if (!is.null(biocversion)) {
    renv_bioconductor_init(library = library)
    biocversion <- package_version(biocversion)
    renv_scope_options(renv.bioconductor.version = biocversion)
  }

  # get records for R packages currently installed
  current <- snapshot(project  = project,
                      library  = libpaths,
                      lockfile = NULL,
                      type     = "all")

  # compare lockfile vs. currently-installed packages
  diff <- renv_lockfile_diff_packages(current, lockfile)

  # don't remove packages unless 'clean = TRUE'
  diff <- renv_vector_diff(diff, if (!clean) "remove")

  # only remove packages from the project library
  is_package <- 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)]

  # don't take any actions with ignored packages
  ignored <- renv_project_ignored_packages(project = project)
  diff <- diff[renv_vector_diff(names(diff), ignored)]

  # only take action with requested packages
  packages <- setdiff(packages %||% names(diff), exclude)
  diff <- diff[intersect(names(diff), packages)]

  if (!length(diff)) {
    name <- if (!missing(library)) "library" else "project"
    writef("- The %s is already synchronized with the lockfile.", name)
    return(renv_restore_successful(diff, prompt, project))
  }

  # 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.
  if (!renv_restore_preflight(project, libpaths, diff, current, lockfile))
    cancel_if(prompt && !proceed())

  if (prompt || renv_verbose()) {
    renv_restore_report_actions(diff, current, lockfile)
    cancel_if(prompt && !proceed())
  }

  # perform the restore
  records <- renv_restore_run_actions(project, diff, current, lockfile, rebuild)
  renv_restore_successful(records, prompt, project)
}

renv_restore_run_actions <- function(project, actions, current, lockfile, rebuild) {

  packages <- names(actions)

  renv_scope_restore(
    project  = project,
    library  = renv_libpaths_active(),
    records  = renv_lockfile_records(lockfile),
    packages = packages,
    rebuild  = rebuild
  )

  # first, handle package removals
  removes <- actions[actions == "remove"]
  enumerate(removes, function(package, action) {
    renv_restore_remove(project, package, current)
  })

  # next, handle installs
  installs <- actions[actions != "remove"]
  packages <- names(installs)

  # perform the install
  records <- retrieve(packages)
  renv_install_impl(records)

  # detect dependency tree repair
  diff <- renv_lockfile_diff_packages(renv_lockfile_records(lockfile), records)
  diff <- diff[diff != "remove"]
  if (!empty(diff)) {
    renv_pretty_print_records(
      "The dependency tree was repaired during package installation:",
      records[names(diff)],
      "Call `renv::snapshot()` to capture these dependencies in the lockfile."
    )
  }

  # check installed packages and prompt for reload if needed
  renv_install_postamble(names(records))

  # return status
  invisible(records)

}

renv_restore_state <- function(key = NULL) {
  state <- the$restore_state
  if (is.null(key)) state else state[[key]]
}

renv_restore_begin <- function(project = NULL,
                               library = NULL,
                               records = NULL,
                               packages = NULL,
                               handler = NULL,
                               rebuild = NULL,
                               recursive = TRUE)
{
  # resolve rebuild request
  rebuild <- case(
    identical(rebuild, TRUE)  ~ packages,
    identical(rebuild, FALSE) ~ character(),
    identical(rebuild, "*")   ~ NA_character_,
    as.character(rebuild)
  )

  # get previous restore state (so we can restore it after if needed)
  oldstate <- the$restore_state

  # set new restore state
  the$restore_state <- env(

    # the active project (if any) used for restore
    project = project,

    # the library path into which packages will be installed.
    # this is set because some behaviors depend on whether the target
    # library is the project library, but during staged installs the
    # library paths might be mutated during restore
    library = library,

    # the package records used for restore, providing information
    # on the packages to be installed (their version, source, etc)
    records = records,

    # the set of packages to be installed in this restore session;
    # as explicitly requested by the user / front-end API call.
    # packages in this list should be re-installed even if a compatible
    # version appears to be already installed
    packages = packages,

    # an optional handler, to be used during retrieve / restore
    # TODO: should we split this into separate handlers?
    handler = handler %||% function(package, action) action,

    # packages which should be rebuilt (skipping the cache)
    rebuild = rebuild,

    # should package dependencies be crawled recursively? this is useful if
    # the records list is incomplete and needs to be built as packages are
    # downloaded
    recursive = recursive,

    # packages which we have attempted to retrieve
    retrieved = new.env(parent = emptyenv()),

    # packages which need to be installed
    install = stack(),

    # a collection of the requirements imposed on dependent packages
    # as they are discovered
    requirements = new.env(parent = emptyenv()),

    # the number of packages that were downloaded
    downloaded = 0L

  )

  # return prior state
  oldstate

}

renv_restore_end <- function(state) {
  the$restore_state <- state
}

# nocov start

renv_restore_report_actions <- function(actions, current, lockfile) {

  if (!renv_verbose() || empty(actions))
    return(invisible(NULL))

  lhs <- renv_lockfile_records(current)
  rhs <- renv_lockfile_records(lockfile)
  renv_pretty_print_records_pair(
    "The following package(s) will be updated:",
    lhs[names(lhs) %in% names(actions)],
    rhs[names(rhs) %in% names(actions)]
  )

}

# nocov end

renv_restore_remove <- function(project, package, lockfile) {
  records <- renv_lockfile_records(lockfile)
  record <- records[[package]]
  printf("- Removing %s [%s] ... ", package, record$Version)
  paths <- renv_paths_library(project = project, package)
  recursive <- renv_file_type(paths) == "directory"
  unlink(paths, recursive = recursive)
  writef("OK [removed from library]")
  TRUE
}

renv_restore_preflight <- function(project, libpaths, actions, current, lockfile) {
  records <- renv_lockfile_records(lockfile)
  matching <- keep(records, names(actions))
  renv_install_preflight(project, libpaths, matching)
}

renv_restore_find <- function(package, record) {

  # skip packages whose installation was explicitly requested
  state <- renv_restore_state()
  record <- renv_record_validate(package, record)
  if (package %in% state$packages)
    return("")

  # check the active library paths to see if this package is already installed
  for (library in renv_libpaths_all()) {
    path <- renv_restore_find_impl(package, record, library)
    if (nzchar(path))
      return(path)
  }

  ""

}

renv_restore_find_impl <- function(package, record, library) {

  path <- file.path(library, package)
  if (!file.exists(path))
    return("")

  # attempt to read DESCRIPTION
  current <- catch(as.list(renv_description_read(path)))
  if (inherits(current, "error"))
    return("")

  # check for an up-to-date version from R package repository
  if (renv_record_source(record) %in% c("cran", "repository")) {
    fields <- c("Package", "Version")
    if (identical(record[fields], current[fields]))
      return(path)
  }

  # otherwise, match on remote fields
  fields <- renv_record_names(record, c("Package", "Version"))
  if (identical(record[fields], current[fields]))
    return(path)

  # failed to match; return empty path
  ""

}

renv_restore_rebuild_required <- function(record) {
  state <- renv_restore_state()
  any(c(NA_character_, record$Package) %in% state$rebuild)
}

renv_restore_successful <- function(records, prompt, project) {

  # ensure the activate script is up-to-date
  renv_infrastructure_write_activate(project, create = FALSE)

  # perform python-related restore steps
  renv_python_restore(project, prompt)

  # return restored records
  invisible(records)

}


# retrieve.R -----------------------------------------------------------------


the$repos_archive <- new.env(parent = emptyenv())

# 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) {

  # confirm that we have restore state set up
  state <- renv_restore_state()
  if (is.null(state))
    stopf("renv_restore_begin() must be called first")

  # normalize repositories (ensure @CRAN@ is resolved)
  options(repos = renv_repos_normalize())

  # transform repository URLs for PPM
  if (renv_ppm_enabled()) {
    repos <- getOption("repos")
    renv_scope_options(repos = renv_ppm_transform(repos))
  }

  # ensure HTTPUserAgent is set (required for PPM binaries)
  agent <- renv_http_useragent()
  if (!grepl("renv", agent)) {
    renv <- sprintf("renv (%s)", renv_metadata_version())
    agent <- paste(renv, agent, sep = "; ")
  }
  renv_scope_options(HTTPUserAgent = agent)

  before <- Sys.time()
  handler <- state$handler
  for (package in packages)
    handler(package, renv_retrieve_impl(package))
  after <- Sys.time()

  state <- renv_restore_state()
  count <- state$downloaded
  if (count) {
    elapsed <- difftime(after, before, units = "secs")
    writef("Successfully downloaded %s in %s.", nplural("package", count), renv_difftime_format(elapsed))
    writef("")
  }

  data <- state$install$data()
  names(data) <- extract_chr(data, "Package")
  data

}

renv_retrieve_impl <- function(package) {

  # skip packages with 'base' priority
  if (package %in% renv_packages_base())
    return()

  # if we've already attempted retrieval of this package, skip
  state <- renv_restore_state()
  if (visited(package, envir = state$retrieved))
    return()

  # extract record for package
  records <- state$records
  record <- records[[package]] %||% renv_retrieve_resolve(package)

  # normalize the record source
  source <- renv_record_source(record, normalize = TRUE)

  # don't install packages from incompatible OS
  ostype <- tolower(record[["OS_type"]] %||% "")

  skip <-
    renv_platform_unix() && identical(ostype, "windows") ||
    renv_platform_windows() && identical(ostype, "unix")

  if (skip)
    return()

  # if this is a package from Bioconductor, activate those repositories now
  if (source %in% c("bioconductor")) {
    project <- renv_restore_state(key = "project")
    renv_scope_bioconductor(project = project)
  }

  # if this is a package from R-Forge, activate its repository
  if (source %in% c("repository")) {
    repository <- record$Repository %||% ""
    if (tolower(repository) %in% c("rforge", "r-forge")) {
      repos <- getOption("repos")
      if (!"R-Forge" %in% names(repos)) {
        repos[["R-Forge"]] <- "https://R-Forge.R-project.org"
        renv_scope_options(repos = repos)
      }
    }
  }

  # if the record doesn't declare the package version,
  # treat it as a request for the latest version on CRAN
  # TODO: should make this behavior configurable
  uselatest <-
    source %in% c("repository", "bioconductor") &&
    is.null(record$Version)

  if (uselatest) {
    record <- withCallingHandlers(
      renv_available_packages_latest(package),
      error = function(err) stopf("package '%s' is not available", package)
    )
  }

  # if the requested record is incompatible with the set
  # of requested package versions thus far, request the
  # latest version on the R package repositories
  #
  # TODO: handle more explicit dependency requirements
  # TODO: report to the user if they have explicitly requested
  # installation of this package version despite it being incompatible
  compat <- renv_retrieve_incompatible(package, record)
  if (NROW(compat)) {

    # get the latest available package version
    replacement <- renv_available_packages_latest(package)
    if (is.null(replacement))
      stopf("package '%s' is not available", package)

    # if it's not compatible, then we might need to try again with
    # a source version (assuming type = "both")
    pkgtype <- getOption("pkgType")
    if (identical(pkgtype, "both")) {
      iscompat <- renv_retrieve_incompatible(package, replacement)
      if (NROW(iscompat)) {
        replacement <- renv_available_packages_latest(package, type = "source")
      }
    }

    # report if we couldn't find a compatible package
    renv_retrieve_incompatible_report(package, record, replacement, compat)
    record <- replacement

  }

  if (!renv_restore_rebuild_required(record)) {

    # if we have an installed package matching the requested record, finish early
    path <- renv_restore_find(package, record)
    if (file.exists(path)) {
      install <- !dirname(path) %in% renv_libpaths_all()
      return(renv_retrieve_successful(record, path, install = install))
    }

    # if the requested record already exists in the cache,
    # we'll use that package for install
    cacheable <-
      renv_cache_config_enabled(project = state$project) &&
      renv_record_cacheable(record)

    if (cacheable) {

      # try to find the record in the cache
      path <- renv_cache_find(record)
      if (nzchar(path) && renv_cache_package_validate(path))
        return(renv_retrieve_successful(record, path))
    }

  }

  # if this is a URL source, then it should already have a local path
  # check for the Path and Source fields and see if they resolve
  fields <- c("Path", "Source")
  for (field in fields) {

    # check for a valid field
    path <- record[[field]]
    if (is.null(path))
      next

    # check whether it looks like an explicit source
    isurl <-
      is.character(path) &&
      nzchar(path) &&
      grepl("[/\\]|[.](?:zip|tgz|gz)$", path)

    if (!isurl)
      next

    # error if the field is declared but doesn't exist
    if (!file.exists(path)) {
      fmt <- "record for package '%s' declares local source '%s', but that file does not exist"
      stopf(fmt, record$Package, path)
    }

    # otherwise, success
    path <- renv_path_normalize(path, mustWork = TRUE)
    return(renv_retrieve_successful(record, path))

  }

  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)
    }

  }

  state$downloaded <- state$downloaded + 1L
  if (state$downloaded == 1L)
    writef(header("Downloading packages"))

  # time to retrieve -- delegate based on previously-determined source
  switch(source,
         bioconductor = renv_retrieve_bioconductor(record),
         bitbucket    = renv_retrieve_bitbucket(record),
         git          = renv_retrieve_git(record),
         github       = renv_retrieve_github(record),
         gitlab       = renv_retrieve_gitlab(record),
         repository   = renv_retrieve_repos(record),
         url          = renv_retrieve_url(record),
         renv_retrieve_unknown_source(record)
  )

}

renv_retrieve_name <- function(record, type = "source", ext = NULL) {
  package <- record$Package
  version <- record$RemoteSha %||% record$Version
  ext <- ext %||% renv_package_ext(type)
  sprintf("%s_%s%s", package, version, ext)
}

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)

  # check for packages from an PPM binary URL, and
  # update the package type if known
  if (renv_ppm_enabled()) {
    url <- attr(record, "url")
    if (is.character(url) && grepl("/__[^_]+__/", url))
      type <- "binary"
  }

  # form path for package to be downloaded
  if (type == "source")
    renv_paths_source(source, package, name)
  else if (type == "binary")
    renv_paths_binary(source, package, name)
  else
    stopf("unrecognized type '%s'", type)
}

renv_retrieve_bioconductor <- function(record) {

  # try to read the bioconductor version from the record
  version <- renv_retrieve_bioconductor_version(record)

  # activate Bioconductor repositories in this context
  project <- renv_restore_state(key = "project")
  renv_scope_bioconductor(project = project, version = version)

  # retrieve record using updated repositories
  renv_retrieve_repos(record)

}

renv_retrieve_bioconductor_version <- function(record) {

  # read git branch
  branch <- record[["git_branch"]]
  if (is.null(branch))
    return(NULL)

  # try and parse version
  parts <- strsplit(branch, "_", fixed = TRUE)[[1L]]
  ok <-
    length(parts) == 3L &&
    tolower(parts[[1L]]) == "release"

  if (!ok)
    return(NULL)

  # we have a version; use it
  paste(tail(parts, n = -1L), collapse = ".")

}

renv_retrieve_bitbucket <- function(record) {

  # query repositories endpoint to find download URL
  host <- record$RemoteHost %||% config$bitbucket.host()
  origin <- renv_retrieve_origin(host)
  username <- record$RemoteUsername
  repo <- record$RemoteRepo

  # scope authentication
  renv_scope_auth(repo)

  fmt <- "%s/repositories/%s/%s"
  url <- sprintf(fmt, origin, username, repo)

  destfile <- renv_scope_tempfile("renv-bitbucket-")
  download(url, destfile = destfile, quiet = TRUE)
  json <- renv_json_read(destfile)

  # now build URL to tarball
  base <- json$links$html$href
  ref <- record$RemoteSha %||% record$RemoteRef

  fmt <- "%s/get/%s.tar.gz"
  url <- sprintf(fmt, base, ref)

  path <- renv_retrieve_path(record)

  renv_retrieve_package(record, url, path)

}

renv_retrieve_github <- function(record) {

  host <- record$RemoteHost %||% config$github.host()
  origin <- renv_retrieve_origin(host)
  username <- record$RemoteUsername
  repo <- record$RemoteRepo
  ref <- record$RemoteSha %||% record$RemoteRef

  if (is.null(ref)) {
    fmt <- "GitHub record for package '%s' has no recorded 'RemoteSha' / 'RemoteRef'"
    stopf(fmt, record$Package)
  }

  fmt <- "%s/repos/%s/%s/tarball/%s"
  url <- with(record, sprintf(fmt, origin, username, repo, ref))
  path <- renv_retrieve_path(record)
  renv_retrieve_package(record, url, path)

}

renv_retrieve_gitlab <- function(record) {

  host <- record$RemoteHost %||% config$gitlab.host()
  origin <- renv_retrieve_origin(host)

  user <- record$RemoteUsername
  repo <- record$RemoteRepo
  id <- URLencode(paste(user, repo, sep = "/"), reserved = TRUE)

  fmt <- "%s/api/v4/projects/%s/repository/archive.tar.gz"
  url <- sprintf(fmt, origin, id)
  path <- renv_retrieve_path(record)

  sha <- record$RemoteSha %||% record$RemoteRef
  if (!is.null(sha))
    url <- paste(url, paste("sha", sha, sep = "="), sep = "?")

  renv_retrieve_package(record, url, path)

}

renv_retrieve_git <- function(record) {
  # NOTE: This path will later be used during the install step, so we don't
  # want to clean it up afterwards
  path <- tempfile("renv-git-")
  ensure_directory(path)
  renv_retrieve_git_impl(record, path)
  renv_retrieve_successful(record, path)
}

renv_retrieve_git_impl <- function(record, path) {

  renv_git_preflight()

  package <- record$Package
  url     <- record$RemoteUrl
  ref     <- record$RemoteRef
  sha     <- record$RemoteSha

  # figure out the default ref
  gitref <- case(
    nzchar(sha %||% "") ~ sha,
    nzchar(ref %||% "") ~ ref,
    "HEAD"
  )

  # be quiet if requested
  quiet <- getOption("renv.git.quiet", default = TRUE)
  quiet <- if (quiet) "--quiet" else ""

  template <- heredoc('
    git init ${QUIET}
    git remote add origin "${ORIGIN}"
    git fetch ${QUIET} --depth=1 origin "${REF}"
    git reset ${QUIET} --hard FETCH_HEAD
  ')

  data <- list(
    ORIGIN = url,
    REF    = gitref,
    QUIET  = quiet
  )

  commands <- renv_template_replace(template, data)
  command <- gsub("\n", " && ", commands, fixed = TRUE)
  if (renv_platform_windows())
    command <- paste(comspec(), "/C", command)

  printf("- Cloning '%s' ... ", url)

  before <- Sys.time()

  status <- local({
    ensure_directory(path)
    renv_scope_wd(path)
    renv_scope_auth(record)
    renv_scope_git_auth()
    system(command)
  })

  after <- Sys.time()

  if (status != 0L) {
    fmt <- "error cloning '%s' from '%s' [status code %i]"
    stopf(fmt, package, url, status)
  }

  fmt <- "OK [cloned repository in %s]"
  elapsed <- difftime(after, before, units = "auto")
  writef(fmt, renv_difftime_format(elapsed))

  TRUE

}


renv_retrieve_cellar_find <- function(record, project = NULL) {

  project <- renv_project_resolve(project)

  # packages installed with 'remotes::install_local()' will
  # have a RemoteUrl entry that we can use
  url <- record$RemoteUrl %||% ""
  if (file.exists(url)) {
    path <- renv_path_normalize(url, mustWork = TRUE)
    type <- if (fileext(path) %in% c(".tgz", ".zip")) "binary" else "source"
    return(named(path, type))
  }

  # otherwise, look in the cellar
  roots <- renv_cellar_roots(project)
  for (type in c("binary", "source")) {

    name <- renv_retrieve_name(record, type = type)
    for (root in roots) {

      package <- record$Package
      paths <- c(
        file.path(root, package, name),
        file.path(root, name)
      )

      for (path in paths)
        if (file.exists(path))
          return(named(path, type))

    }
  }

  fmt <- "%s [%s] is not available locally"
  stopf(fmt, record$Package, record$Version)

}

renv_retrieve_cellar_report <- function(record) {

  source <- renv_record_source(record)
  if (source == "cellar")
    return(record)

  fmt <- "- Package %s [%s] will be installed from the cellar."
  with(record, writef(fmt, Package, Version))

  record

}

renv_retrieve_cellar <- function(record) {
  source <- renv_retrieve_cellar_find(record)
  record <- renv_retrieve_cellar_report(record)
  renv_retrieve_successful(record, source)
}

renv_retrieve_libpaths <- function(record) {

  libpaths <- c(renv_libpaths_user(), renv_libpaths_site())
  for (libpath in libpaths)
    if (renv_retrieve_libpaths_impl(record, libpath))
      return(TRUE)

}

renv_retrieve_libpaths_impl <- function(record, libpath) {

  # form path to installed package's DESCRIPTION
  path <- file.path(libpath, record$Package)
  if (!file.exists(path))
    return(FALSE)

  # read DESCRIPTION
  desc <- renv_description_read(path = path)

  # check if it's compatible with the requested record
  fields <- c("Package", "Version", grep("^Remote", names(record), value = TRUE))
  compatible <- identical(record[fields], desc[fields])
  if (!compatible)
    return(FALSE)

  # check that it was built for a compatible version of R
  built <- desc[["Built"]]
  if (is.null(built))
    return(FALSE)

  ok <- catch(renv_description_built_version(desc))
  if (!identical(ok, TRUE))
    return(FALSE)

  # check that this package has a known source
  source <- renv_snapshot_description_source(desc)
  if (identical(source$Source, "unknown"))
    return(FALSE)

  # OK: copy this package as-is
  renv_retrieve_successful(record, path)

}

renv_retrieve_explicit <- function(record) {

  # try parsing as a local remote
  source <- record$Path %||% record$RemoteUrl %||% ""
  if (nzchar(source)) {
    resolved <- catch(renv_remotes_resolve_path(source))
    if (inherits(resolved, "error"))
      return(FALSE)
  }

  # treat as 'local' source but extract path
  normalized <- renv_path_normalize(source, mustWork = TRUE)
  resolved$Source <- "Local"
  renv_retrieve_successful(resolved, normalized)

}

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))))
    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") ||
    getOption("install.packages.check.source", default = "yes") %in% "yes"

  binok <- pkgtype %in% c("both") || grepl("binary", pkgtype, fixed = TRUE)

  # collect list of 'methods' for retrieval
  methods <- stack(mode = "list")

  # add binary package methods
  if (binok) {

    # prefer repository binaries if available
    methods$push(renv_retrieve_repos_binary)

    # 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)

  }

  # next, try to retrieve from sources
  if (srcok) {

    # retrieve from source repositories
    methods$push(renv_retrieve_repos_source)

    # also try fallback source locations (for Nexus)
    methods$push(renv_retrieve_repos_source_fallback)

    # if this is a package from r-universe, try restoring from github
    # (currently inferred from presence for RemoteUrl field)
    unifields <- c("RemoteUrl", "RemoteRef", "RemoteSha")
    if (all(unifields %in% names(record)))
      methods$push(renv_retrieve_git)
    else
      methods$push(renv_retrieve_repos_archive)

  }

  # capture errors for reporting
  errors <- stack()

  for (method in methods$data()) {

    status <- catch(
      withCallingHandlers(
        method(record),
        renv.retrieve.error = function(error) {
          errors$push(error$data)
        }
      )
    )

    if (inherits(status, "error")) {
      errors$push(status)
      next
    }

    if (identical(status, TRUE))
      return(TRUE)

    if (!is.logical(status)) {
      fmt <- "internal error: unexpected status code '%s'"
      warningf(fmt, stringify(status))
    }

  }

  # if we couldn't download the package, report the errors we saw
  local({
    renv_scope_options(warn = 1)
    for (error in errors$data())
      warning(error)
  })

  stopf("failed to retrieve package '%s'", renv_record_format_remote(record))

}

renv_retrieve_repos_error_report <- function(record, errors) {

  if (empty(errors))
    return()

  messages <- extract(errors, "message")
  if (empty(messages))
    return()

  messages <- unlist(messages, recursive = TRUE, use.names = FALSE)
  if (empty(messages))
    return()

  fmt <- "The following error(s) occurred while retrieving '%s':"
  preamble <- sprintf(fmt, record$Package)

  caution_bullets(
    preamble = preamble,
    values   = paste("-", messages)
  )

  if (renv_verbose())
    str(errors)

}

renv_retrieve_url <- function(record) {

  if (is.null(record$RemoteUrl)) {
    fmt <- "package '%s' has no recorded RemoteUrl"
    stopf(fmt, record$Package)
  }

  resolved <- renv_remotes_resolve_url(record$RemoteUrl, quiet = FALSE)
  renv_retrieve_successful(record, resolved$Path)

}

renv_retrieve_repos_archive_name <- function(record, type = "source") {

  file <- record$File
  if (length(file) && !is.na(file))
    return(file)

  ext <- renv_package_ext(type)
  paste0(record$Package, "_", record$Version, ext)

}

renv_retrieve_repos_mran <- function(record) {

  # MRAN does not make binaries available on Linux
  if (renv_platform_linux())
    return(FALSE)

  # ensure local MRAN database is up-to-date
  renv_mran_database_refresh(explicit = FALSE)

  # check that we have an available database
  path <- renv_mran_database_path()
  if (!file.exists(path))
    return(FALSE)

  # attempt to read it
  database <- catch(renv_mran_database_load())
  if (inherits(database, "error")) {
    warning(database)
    return(FALSE)
  }

  # get entry for this version of R + platform
  suffix <- contrib.url("", type = "binary")
  entry <- database[[suffix]]
  if (is.null(entry))
    return(FALSE)

  # check for known entry for this package + version
  key <- paste(record$Package, record$Version)
  idate <- entry[[key]]
  if (is.null(idate))
    return(FALSE)

  # convert from integer to date
  date <- as.Date(idate, origin = "1970-01-01")

  # form url to binary package
  base <- renv_mran_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")

  # attempt to retrieve
  renv_retrieve_package(record, url, path)

}

renv_retrieve_repos_binary <- function(record) {
  renv_retrieve_repos_impl(record, "binary")
}

renv_retrieve_repos_binary_fallback <- function(record) {

  for (repo in getOption("repos")) {
    if (renv_nexus_enabled(repo)) {
      repourl <- contrib.url(repo, type = "binary")
      status <- catch(renv_retrieve_repos_impl(record, "binary", repo = repourl))
      if (!inherits(status, "error"))
        return(status)
    }
  }

  FALSE

}

renv_retrieve_repos_source <- function(record) {
  renv_retrieve_repos_impl(record, "source")
}

renv_retrieve_repos_source_fallback <- function(record, repo) {

  for (repo in getOption("repos")) {
    if (renv_nexus_enabled(repo)) {
      repourl <- contrib.url(repo, type = "source")
      status <- catch(renv_retrieve_repos_impl(record, "source", repo = repourl))
      if (!inherits(status, "error"))
        return(status)
    }
  }

  FALSE

}

renv_retrieve_repos_archive <- function(record) {

  for (repo in getOption("repos")) {

    # try to determine path to package in archive
    url <- renv_retrieve_repos_archive_path(repo, record)
    if (is.null(url))
      next

    # attempt download
    name <- renv_retrieve_repos_archive_name(record, type = "source")
    status <- catch(renv_retrieve_repos_impl(record, "source", name, url))
    if (identical(status, TRUE))
      return(TRUE)

  }

  return(FALSE)

}

renv_retrieve_repos_archive_path <- function(repo, record) {

  # allow users to provide a custom archive path for a record,
  # in case they're using a repository that happens to archive
  # packages with a different format than regular CRAN network
  # https://github.com/rstudio/renv/issues/602
  override <- getOption("renv.retrieve.repos.archive.path")
  if (is.function(override)) {
    result <- override(repo, 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)
  }

  # otherwise, try determining the archive paths with a couple
  # custom locations, and cache the version that works for the
  # associated repository
  formatters <- list(

    # default CRAN format
    function(repo, record) {
      with(record, file.path(repo, "src/contrib/Archive", Package))
    },

    # format used by Artifactory
    # https://github.com/rstudio/renv/issues/602
    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) {
      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)
    }
  }

}

# NOTE: If 'repo' is provided, it should be the path to the appropriate 'arm'
# of a repository, which is normally generated from the repository URL via
# 'contrib.url()'.
renv_retrieve_repos_impl <- function(record,
                                     type = NULL,
                                     name = NULL,
                                     repo = NULL)
{
  package <- record$Package
  version <- record$Version

  type <- type %||% attr(record, "type", exact = TRUE)
  name <- name %||% renv_retrieve_repos_archive_name(record, type)
  repo <- repo %||% attr(record, "url", exact = TRUE)

  # if we weren't provided a repository for this package, try to find it
  if (is.null(repo)) {

    entry <- catch(
      renv_available_packages_entry(
        package = package,
        type    = type,
        filter  = version,
        prefer  = record[["Repository"]]
      )
    )

    if (inherits(entry, "error")) {
      attr(entry, "record") <- record
      renv_condition_signal("renv.retrieve.error", entry)
      return(FALSE)
    }

    # get repository path
    repo <- entry$Repository

    # add in the path if available
    path <- entry$Path
    if (length(path) && !is.na(path))
      repo <- file.path(repo, path)

    # update the tarball name if it was declared
    file <- entry$File
    if (length(file) && !is.na(file))
      name <- file

  }

  url <- file.path(repo, name)
  path <- renv_retrieve_path(record, type)

  renv_retrieve_package(record, url, path)

}


renv_retrieve_package <- function(record, url, path) {

  ensure_parent_directory(path)
  type <- renv_record_source(record)
  status <- local({
    renv_scope_auth(record)
    preamble <- renv_retrieve_package_preamble(record, url)
    catch(download(url, preamble = preamble, destfile = path, type = type))
  })

  # report error for logging upstream
  if (inherits(status, "error")) {
    attr(status, "record") <- record
    renv_condition_signal("renv.retrieve.error", status)
  }

  # handle FALSE returns (shouldn't normally happen?)
  if (identical(status, FALSE)) {
    fmt <- "an unknown error occurred installing '%s' (%s)"
    msg <- sprintf(fmt, record$Package, renv_record_format_remote(record))
    status <- simpleError(msg)
  }

  # handle errors
  if (inherits(status, "error"))
    stop(status)

  # handle success
  renv_retrieve_successful(record, path)

}

renv_retrieve_package_preamble <- function(record, url) {

  message <- sprintf(
    "- Downloading %s from %s ... ",
    record$Package,
    record$Repository %||% record$Source
  )

  format(message, width = the$install_step_width)

}

renv_retrieve_successful_subdir <- function(record, path) {

  # if it's a file, assume RemoteSubdir needs to be honored
  info <- file.info(path, extra_cols = FALSE)
  if (identical(info$isdir, FALSE))
    return(record$RemoteSubdir)

  # otherwise, respect RemoteSubdir only if it seems to
  # point at a valid DESCRPITION file
  if (!is.null(record$RemoteSubdir)) {
    parts <- c(path, record$RemoteSubdir, "DESCRIPTION")
    descpath <- paste(parts, collapse = "/")
    if (file.exists(descpath))
      return(record$RemoteSubdir)
  }

}

renv_retrieve_successful <- function(record, path, install = TRUE) {

  # if we downloaded an archive, adjust its permissions here
  mode <- Sys.getenv("RENV_CACHE_MODE", unset = NA)
  if (!is.na(mode)) {
    info <- file.info(path, extra_cols = FALSE)
    if (identical(info$isdir, FALSE)) {
      parent <- dirname(path)
      renv_system_exec(
        command = "chmod",
        args    = c("-Rf", renv_shell_quote(mode), renv_shell_path(parent)),
        action  = "chmoding cached package",
        quiet   = TRUE,
        success = NULL
      )
    }
  }

  # the handling of 'subdir' here is a little awkward, as this function
  # can receive:
  #
  # - archives, whose package might live within a sub-directory;
  # - folders, whose package might live within a sub-directory;
  # - cache paths, for which the subdir is no longer relevant
  #
  # this warrants a proper cleanup, but for now we we use a hack
  subdir <- renv_retrieve_successful_subdir(record, path)

  # augment record with information from DESCRIPTION file
  desc <- renv_description_read(path, subdir = subdir)

  # update the record's package name, version
  # TODO: should we warn if they didn't match for some reason?
  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
  state <- renv_restore_state()
  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"
  deps <- renv_dependencies_discover_description(path, subdir = subdir, fields = fields)
  if (length(deps$Source))
    deps$Source <- record$Package

  rowapply(deps, function(dep) {
    package <- dep$Package
    requirements[[package]] <- requirements[[package]] %||% stack()
    requirements[[package]]$push(dep)
  })

  # read and handle remotes declared by this package
  remotes <- desc$Remotes
  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)
  })

  # mark package as requiring install if needed
  if (install)
    state$install$push(record)

  TRUE

}

renv_retrieve_successful_recurse <- function(deps) {
  remotes <- unique(deps$Package)
  for (remote in remotes)
    renv_retrieve_successful_recurse_impl(remote)
}

renv_retrieve_successful_recurse_impl <- function(remote) {

  dynamic(
    key   = list(remote = remote),
    value = renv_retrieve_successful_recurse_impl_one(remote)
  )

}

renv_retrieve_successful_recurse_impl_one <- function(remote) {

  # ignore base packages
  base <- renv_packages_base()
  if (remote %in% base)
    return(list())

  # if this is a 'plain' package remote, retrieve it
  if (grepl(renv_regexps_package_name(), remote)) {
    renv_retrieve_impl(remote)
    return(list())
  }

  # otherwise, handle custom remotes
  record <- renv_retrieve_remotes_impl(remote)
  if (length(record)) {
    renv_retrieve_impl(record$Package)
    return(list())
  }

  list()

}

renv_retrieve_unknown_source <- function(record) {

  # try to find a matching local package
  status <- catch(renv_retrieve_cellar(record))
  if (!inherits(status, "error"))
    return(status)

  # failed; parse as though from R package repository
  record$Source <- "Repository"
  renv_retrieve_repos(record)

}

# TODO: what should we do if we detect incompatible remotes?
# e.g. if pkg A requests 'r-lib/rlang@0.3' but pkg B requests
# 'r-lib/rlang@0.2'.
renv_retrieve_remotes <- function(remotes) {
  remotes <- strsplit(remotes, "\\s*,\\s*")[[1L]]
  for (remote in remotes)
    renv_retrieve_remotes_impl(remote)
}

renv_retrieve_remotes_impl <- function(remote) {

  dynamic(
    key   = list(remote = remote),
    value = renv_retrieve_remotes_impl_one(remote)
  )

}

renv_retrieve_remotes_impl_one <- function(remote) {

  # TODO: allow customization of behavior when remote parsing fails?
  resolved <- catch(renv_remotes_resolve(remote))
  if (inherits(resolved, "error")) {
    warningf("failed to resolve remote '%s'; skipping", remote)
    return(invisible(NULL))
  }

  # get the current package record
  state <- renv_restore_state()
  package <- resolved$Package
  record <- state$records[[package]]

  # if we already have a package record, and it's not a 'plain'
  # repository record, skip
  skip <-
    !is.null(record) &&
    !identical(record, list(Package = package, Source = "Repository"))

  if (skip) {
    dlog("retrieve", "skipping remote '%s'; it's already been declared", remote)
    dlog("retrieve", "using existing remote '%s'", stringify(record))
    return(invisible(NULL))
  }

  # update the requested record
  dlog("retrieve", "using remote '%s'", remote)
  state$records[[package]] <- resolved

  # mark the record as needing retrieval
  state$retrieved[[package]] <- FALSE

  # return new record
  invisible(resolved)

}

renv_retrieve_resolve <- function(package) {
  tryCatch(
    renv_snapshot_description(package = package),
    error = function(e) {
      renv_retrieve_missing_record(package)
    }
  )
}

renv_retrieve_missing_record <- function(package) {

  # TODO: allow users to configure the action to take here, e.g.
  #
  #   1. retrieve latest from R repositories (the default),
  #   2. request a package + version to be retrieved,
  #   3. hard error
  #
  record <- renv_available_packages_latest(package)
  if (!is.null(record))
    return(record)

  fmt <- heredoc("
    renv was unable to find a compatible version of package '%1$s'.

    The latest-available version %1$s is '%2$s', but that version
    does not appear to be compatible with this version of R.

    You may need to manually re-install a different version of '%1$s'.
  ")

  entry <- renv_available_packages_entry(package, type = "source")
  version <- entry$Version %||% "<unknown>"

  writef(fmt, package, version)

  stopf("failed to find a compatible version of the '%s' package", package)

}

# check to see if this requested record is incompatible
# with the set of required dependencies recorded thus far
# during the package retrieval process
renv_retrieve_incompatible <- function(package, record) {

  state <- renv_restore_state()
  record <- renv_record_validate(package, record)

  # check and see if the installed version satisfies all requirements
  requirements <- state$requirements[[package]]
  if (is.null(requirements))
    return(NULL)

  data <- bind(requirements$data())
  explicit <- data[nzchar(data$Require) & nzchar(data$Version), ]
  if (nrow(explicit) == 0)
    return(NULL)

  # drop 'Dev' column
  explicit$Dev <- NULL

  # retrieve record version
  version <- record$Version
  if (is.null(version))
    return(NULL)

  # for each row, compute whether we're compatible
  rversion <- numeric_version(version)
  compatible <- map_lgl(seq_len(nrow(explicit)), function(i) {
    expr <- call(explicit$Require[[i]], rversion, explicit$Version[[i]])
    eval(expr, envir = baseenv())
  })

  # keep whatever wasn't compatible
  explicit[!compatible, ]

}

renv_retrieve_incompatible_report <- function(package, record, replacement, compat) {

  # only report if the user explicitly requesting installation of a particular
  # version of a package, but that package isn't actually compatible
  state <- renv_restore_state()
  if (!package %in% state$packages)
    return()

  fmt <- "%s (requires %s %s %s)"
  values <- with(compat, sprintf(fmt, Source, Package, Require, Version))

  fmt <- "Installation of '%s %s' was requested, but the following constraints are not met:"
  preamble <- with(record, sprintf(fmt, Package, Version))

  fmt <- "renv will try to install '%s %s' instead."
  postamble <- with(replacement, sprintf(fmt, Package, Version))

  if (!renv_tests_running()) {
    caution_bullets(
      preamble = preamble,
      values = values,
      postamble = postamble
    )
  }

}

renv_retrieve_origin <- function(host) {

  # NOTE: some host URLs may come with a protocol already formed;
  # if we find a protocol, use it as-is
  if (grepl("://", host, fixed = TRUE))
    return(host)

  # otherwise, prepend protocol (assume https)
  paste("https", host, sep = "://")

}


# robocopy.R -----------------------------------------------------------------


renv_robocopy_exec <- function(source, target, flags = NULL) {

  source <- path.expand(source)
  target <- path.expand(target)

  # add other flags
  flags <- c(flags, "/E", "/Z", "/R:5", "/W:10")

  # https://docs.microsoft.com/en-us/windows-server/administration/windows-commands/robocopy
  # > Any value greater than 8 indicates that there was at least one failure
  # > during the copy operation.
  renv_system_exec(
    command = "robocopy",
    args    = c(flags, renv_shell_path(source), renv_shell_path(target)),
    action  = "copying directory",
    success = 0:8,
    quiet   = TRUE
  )

}

renv_robocopy_copy <- function(source, target) {
  renv_robocopy_exec(source, target)
}

renv_robocopy_move <- function(source, target) {
  renv_robocopy_exec(source, target, "/MOVE")
}


# roxygen.R ------------------------------------------------------------------


#' @param project The project directory. If `NULL`, then the active project will
#'   be used. If no project is currently active, then the current working
#'   directory is used instead.
#'
#' @param type The type of package to install ("source" or "binary"). Defaults
#'   to the value of `getOption("pkgType")`.
#'
#' @param lockfile Path to a lockfile. When `NULL` (the default), the
#'   `renv.lock` located in the root of the current project will be used.
#'
#' @param library The \R library to be used. When `NULL`, the active project
#'  library will be used instead.
#'
#' @param prompt Boolean; prompt the user before taking any action? For backwards
#'   compatibility, `confirm` is accepted as an alias for `prompt`.
#'
#' @param ... Unused arguments, reserved for future expansion. If any arguments
#'   are matched to `...`, renv will signal an error.
#'
#' @param clean Boolean; remove packages not recorded in the lockfile from
#'   the target library? Use `clean = TRUE` if you'd like the library state
#'   to exactly reflect the lockfile contents after `restore()`.
#'
#' @param rebuild Force packages to be rebuilt, thereby bypassing any installed
#'   versions of the package available in the cache? This can either be a
#'   boolean (indicating that all installed packages should be rebuilt), or a
#'   vector of package names indicating which packages should be rebuilt.
#'
#' @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
#'   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 dependencies A vector of DESCRIPTION field names that should be used
#'   for package dependency resolution. When `NULL` (the default), the value
#'   of `renv::settings$package.dependency.fields` is used. The aliases
#'   "strong", "most", and "all" are also supported.
#'   See [tools::package_dependencies()] for more details.
#'
#' @return The project directory, invisibly. Note that this function is normally
#'   called for its side effects.
#'
#' @name renv-params
NULL

renv_roxygen_config_section <- function() {

  # read config
  config <- yaml::read_yaml("inst/config.yml")

  # generate items
  items <- map_chr(config, function(entry) {

    # extract fields
    name <- entry$name
    type <- entry$type
    default <- entry$default
    description <- entry$description

    # deparse default value
    default <- case(
      identical(default, list()) ~ "NULL",
      TRUE                       ~ deparse(default)
    )

    # generate table row
    fmt <- "\\subsection{renv.config.%s}{%s Defaults to \\code{%s}.}"
    sprintf(fmt, name, description, default)

  })

  c(
    "@section Configuration:",
    "",
    "The following renv configuration options are available:",
    "",
    items,
    ""
  )

}


# rstudio.R ------------------------------------------------------------------


renv_rstudio_available <- function() {

  # NOTE: detecting whether we're running within RStudio is a bit
  # tricky because not all of the expected RStudio bits have been
  # initialized when the R session is being initialized (e.g.
  # when the .Rprofile is being executed)
  args <- commandArgs(trailingOnly = FALSE)
  args[[1L]] == "RStudio" || .Platform$GUI == "RStudio"

}

renv_rstudio_initialize <- function(project) {

  tools <- catch(as.environment("tools:rstudio"))
  if (inherits(tools, "error"))
    return(FALSE)

  if (is.null(tools$.rs.api.initializeProject))
    return(FALSE)

  tools$.rs.api.initializeProject(project)
  TRUE

}

renv_rstudio_fixup <- function() {

  # if RStudio's tools are on the search path, we should try
  # to fix them up so that renv's own routines don't get seen
  tools <- catch(as.environment("tools:rstudio"))
  if (inherits(tools, "error"))
    return(FALSE)

  helper <- tools[[".rs.clearVar"]]
  if (is.null(helper))
    return(FALSE)

  # if the helper environment has been fixed up (as e.g. by
  # newer versions of RStudio) then nothing to do
  if (identical(tools, environment(helper)))
    return(FALSE)

  # put common tools from base into the environment
  envir <- environment(helper)
  for (var in c("assign", "exists", "get", "remove", "paste"))
    envir[[var]] <- get(var, envir = baseenv())

  TRUE

}


# rtools.R -------------------------------------------------------------------


renv_rtools_list <- function() {

  drive <- Sys.getenv("SYSTEMDRIVE", unset = "C:")

  roots <- c(

    renv_rtools_registry(),

    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")),
    file.path(drive, "Rtools"),
    list.files(file.path(drive, "RBuildTools"), full.names = TRUE),

    "~/Rtools",
    list.files("~/RBuildTools", full.names = TRUE)

  )

  roots <- unique(roots[file.exists(roots)])
  lapply(roots, renv_rtools_read)

}

renv_rtools_find <- function() {

  for (spec in renv_rtools_list())
    if (renv_rtools_compatible(spec))
      return(spec)

  NULL

}

renv_rtools_read <- function(root) {

  list(
    root    = root,
    version = renv_rtools_version(root)
  )

}

renv_rtools_version <- function(root) {

  name <- basename(root)

  # check for 'rtools<xyz>' folder
  # e.g. C:/rtools42
  pattern <- "^rtools(\\d)(\\d)$"
  if (grepl(pattern, name, perl = TRUE, ignore.case = TRUE))
    return(gsub(pattern, "\\1.\\2", name, perl = TRUE, ignore.case = TRUE))

  # check for versioned installation path
  # e.g. C:/RBuildTools/4.2
  version <- catch(numeric_version(name))
  if (!inherits(version, "error"))
    return(format(version))

  # detect older Rtools installations
  path <- file.path(root, "VERSION.txt")
  if (!file.exists(path))
    return(NULL)

  contents <- readLines(path, warn = FALSE)
  version <- gsub("[^[:digit:].]", "", contents)
  numeric_version(version)

}

renv_rtools_compatible <- function(spec) {

  if (is.null(spec$version))
    return(FALSE)

  ranges <- list(
    "4.3" = c("4.3.0", "9.9.9"),
    "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"),
    "3.4" = c("3.3.0", "4.0.0"),
    "3.3" = c("3.2.0", "3.3.0"),
    "3.2" = c("3.1.0", "3.2.0"),
    "3.1" = c("3.0.0", "3.1.0")
  )

  version <- numeric_version(spec$version)[1, 1:2]
  range <- ranges[[format(version)]]
  if (is.null(range))
    return(FALSE)

  rversion <- getRversion()
  range[[1]] <= rversion && rversion < range[[2]]

}

renv_rtools_registry <- function() {

  status <- tryCatch(
    utils::readRegistry(
      key = "SOFTWARE\\R-Core\\Rtools",
      hive = "HLM"
    ),
    error = function(e) list()
  )

  path <- status$InstallPath %||% ""
  if (file.exists(path))
    return(renv_path_normalize(path))

}

renv_rtools_envvars <- function(root) {

  version <- renv_rtools_version(root)

  if (version < "4.0")
    renv_rtools_envvars_default(root)
  else if (version < "4.2")
    renv_rtools_envvars_rtools40(root)
  else if (version < "4.3")
    renv_rtools_envvars_rtools42(root)
  else
    renv_rtools_envvars_rtools43(root)

}

renv_rtools_envvars_default <- function(root) {

  # add Rtools utilities to path
  bin <- normalizePath(file.path(root, "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 = "/")

  list(PATH = path, BINPREF = binpref)

}

renv_rtools_envvars_rtools43 <- function(root) {

  # add Rtools utilities to path
  bin <- normalizePath(file.path(root, "usr/bin"), mustWork = FALSE)
  path <- paste(bin, Sys.getenv("PATH"), sep = .Platform$path.sep)

  # set BINPREF
  binpref <- ""

  list(PATH = path, BINPREF = binpref)

}

renv_rtools_envvars_rtools42 <- function(root) {

  # add Rtools utilities to path
  bin <- normalizePath(file.path(root, "usr/bin"), mustWork = FALSE)

  path <- paste(bin, Sys.getenv("PATH"), sep = .Platform$path.sep)

  # set BINPREF
  binpref <- ""

  list(PATH = path, BINPREF = binpref)

}

renv_rtools_envvars_rtools40 <- function(root) {

  # add Rtools utilities to path
  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)
  binpref <- "/mingw$(WIN)/bin/"

  list(PATH = path, BINPREF = binpref)

}


# run.R ----------------------------------------------------------------------


#' Run a script
#'
#' Run an \R script, in the context of a project using renv. The script will
#' be run within an \R sub-process.
#'
#' @inherit renv-params
#'
#' @param script The path to an \R script.
#'
#' @param job Run the requested script as an RStudio job? Requires a recent
#'   version of both RStudio and the rstudioapi packages. When `NULL`, the
#'   script will be run as a job if possible, and as a regular \R process
#'   launched by [system2()] if not.
#'
#' @param name The name to associate with the job, for scripts run as a job.
#'
#' @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) {

  renv_scope_error_handler()
  renv_dots_check(...)

  script <- renv_path_normalize(script, mustWork = TRUE)

  # find the project directory
  project <- project %||% renv_file_find(script, function(path) {
    paths <- file.path(path, c("renv", "renv.lock"))
    if (any(file.exists(paths)))
      return(path)
  })

  if (is.null(project)) {
    fmt <- "could not determine project root for script '%s'"
    stopf(fmt, renv_path_aliased(script))
  }

  # ensure that it has an activate script
  activate <- renv_paths_activate(project = project)
  if (!file.exists(activate)) {
    fmt <- "project '%s' does not have an renv activate script"
    stopf(fmt, renv_path_aliased(project))
  }

  # run as a job when possible in RStudio
  jobbable <-
    !identical(job, FALSE) &&
    renv_rstudio_available() &&
    renv_package_installed("rstudioapi") &&
    renv_package_version("rstudioapi") >= "0.10" &&
    rstudioapi::verifyAvailable("1.2.1335")

  if (identical(job, TRUE) && identical(jobbable, FALSE))
    stopf("cannot run script as job: required versions of RStudio + rstudioapi not available")

  if (jobbable)
    renv_run_job(script = script, name = name, project = project)
  else
    renv_run_impl(script = script, name = name, project = project)

}

renv_run_job <- function(script, name, project) {

  activate <- renv_paths_activate(project = project)
  jobscript <- tempfile("renv-job-", fileext = ".R")

  exprs <- substitute(local({
    defer(unlink(jobscript))
    source(activate)
    source(script)
  }), list(activate = activate, script = script, jobscript = jobscript))

  code <- deparse(exprs)
  writeLines(code, con = jobscript)

  rstudioapi::jobRunScript(
    path       = jobscript,
    workingDir = project,
    name       = name
  )

}

renv_run_impl <- function(script, name, project) {
  renv_scope_wd(project)
  system2(R(), c("-s", "-f", renv_shell_path(script)))
}


# sandbox.R ------------------------------------------------------------------


renv_sandbox_init <- function() {

  # check for envvar override
  enabled <- Sys.getenv("RENV_SANDBOX_LOCKING_ENABLED", unset = NA)
  if (!is.na(enabled)) {
    enabled <- truthy(enabled, default = FALSE)
    options(renv.sandbox.locking_enabled = enabled)
  }

  # don't use sandbox in watchdog process
  type <- Sys.getenv("RENV_PROCESS_TYPE")
  if (type == "watchdog-server")
    return()

  # if renv was launched with a sandbox path on the library paths,
  # then immediately try to activate the sandbox
  # https://github.com/rstudio/renv/issues/1565
  for (libpath in .libPaths()) {
    if (file.exists(file.path(libpath, ".renv-sandbox"))) {
      renv_sandbox_activate_impl(sandbox = libpath)
      break
    }
  }

}

renv_sandbox_activate <- function(project = NULL) {

  # record start time
  before <- Sys.time()

  # attempt the activation
  status <- catch(renv_sandbox_activate_impl(project))
  if (inherits(status, "error"))
    warnify(status)

  # record end time
  after <- Sys.time()

  # check for long elapsed time
  elapsed <- difftime(after, before, units = "secs")

  # if it took too long to activate the sandbox, warn the user
  if (elapsed > 10) {

    fmt <- heredoc("
    renv took longer than expected (%s) to activate the sandbox.

    The sandbox can be disabled by setting:

        RENV_CONFIG_SANDBOX_ENABLED = FALSE

    within an appropriate start-up .Renviron file.

    See `?renv::config` for more details.
    ")


    warningf(fmt, renv_difftime_format(elapsed))

  }

  # return status
  status

}

renv_sandbox_activate_impl <- function(project = NULL, sandbox = NULL) {

  # lock access to the sandbox
  if (config$sandbox.enabled()) {
    sandbox <- sandbox %||% renv_sandbox_path(project = project)
    lockfile <- paste(sandbox, "lock", sep = ".")
    ensure_parent_directory(lockfile)
    renv_scope_lock(lockfile)
    ensure_directory(sandbox)
  }

  # get current library paths
  oldlibs <- .libPaths()
  syslibs <- c(renv_libpaths_site(), renv_libpaths_system())
  syslibs <- renv_path_normalize(syslibs)

  # override .Library.site
  base <- .BaseNamespaceEnv
  renv_binding_replace(base, ".Library.site", NULL)

  # generate sandbox
  if (config$sandbox.enabled()) {
    renv_sandbox_generate(sandbox)
    renv_binding_replace(base, ".Library", sandbox)
  }

  # update library paths
  newlibs <- renv_vector_diff(oldlibs, syslibs)
  renv_libpaths_set(newlibs)

  # protect against user profiles that might update library paths
  if (config$sandbox.enabled())
    renv_sandbox_activate_check(newlibs)

  # return new library paths
  renv_libpaths_all()

}

renv_sandbox_activated <- function() {
  !identical(.Library, renv_libpaths_system())
}

renv_sandbox_activate_check <- function(libs) {

  envir <- globalenv()

  danger <-
    exists(".First", envir = envir, inherits = FALSE) &&
    identical(getOption("renv.autoloader.running"), TRUE)

  if (!danger)
    return(FALSE)

  .First <- get(".First", envir = envir, inherits = FALSE)
  wrapper <- function() {

    # scope the library paths as currently defined
    renv_scope_libpaths()

    # call the user-defined .First function
    status <- tryCatch(.First(), error = warnify)

    # double-check if we should restore .First (this is extra
    # paranoid but in theory .First could remove itself)
    if (identical(wrapper, get(".First", envir = envir)))
      assign(".First", .First, envir = envir)

    # return result of .First
    invisible(status)

  }

  assign(".First", wrapper, envir = envir)
  return(TRUE)

}

renv_sandbox_generate <- function(sandbox) {

  # make the library temporarily writable
  lock <- getOption("renv.sandbox.locking_enabled", default = TRUE)

  if (lock) {
    dlog("sandbox", "unlocking sandbox")
    renv_sandbox_unlock(sandbox)
  }

  # find system packages in the system library
  priority <- getOption("renv.sandbox.priority", default = c("base", "recommended"))
  syspkgs <- installed_packages(
    lib.loc = renv_libpaths_system(),
    priority = priority
  )

  # link into sandbox
  sources <- with(syspkgs, file.path(LibPath, Package))
  targets <- with(syspkgs, file.path(sandbox, Package))
  names(targets) <- sources
  enumerate(targets, function(source, target) {
    if (!renv_file_same(source, target))
      renv_file_link(source, target, overwrite = TRUE)
  })

  # create marker indicating this is a sandbox
  # (or, if it already exists, re-create it and update its ctime / mtime)
  marker <- file.path(sandbox, ".renv-sandbox")
  file.create(marker)

  # update mtime on the sandbox itself as well
  Sys.setFileTime(sandbox, time = Sys.time())

  # make the library unwritable again
  if (lock) {
    dlog("sandbox", "locking sandbox")
    renv_sandbox_lock(sandbox)
  }

  # return sandbox path
  sandbox

}

renv_sandbox_deactivate <- function() {

  # get library paths sans .Library, .Library.site
  old <- renv_libpaths_all()
  syslibs <- renv_path_normalize(c(.Library, .Library.site))

  # restore old bindings
  base <- .BaseNamespaceEnv
  renv_binding_replace(base, ".Library",      renv_libpaths_system())
  renv_binding_replace(base, ".Library.site", renv_libpaths_site())

  # update library paths
  new <- renv_vector_diff(old, syslibs)
  renv_libpaths_set(new)

  renv_libpaths_all()

}

renv_sandbox_task <- function(...) {

  # check if we're enabled
  if (!renv_sandbox_activated())
    return()

  # allow opt-out if necessary
  enabled <- getOption("renv.sandbox.task", default = TRUE)
  if (!enabled)
    return()

  # get sandbox path
  sandbox <- tail(.libPaths(), n = 1L)

  # make sure it exists
  if (!file.exists(sandbox)) {
    warning("the renv sandbox was deleted; it will be re-generated", call. = FALSE)
    ensure_directory(sandbox)
    renv_sandbox_generate(sandbox)
  }

  # update the sandbox write time / mtime
  Sys.setFileTime(sandbox, time = Sys.time())

}

renv_sandbox_path <- function(project = NULL) {
  renv_paths_sandbox(project = project)
}

renv_sandbox_lock <- function(sandbox = NULL, project = NULL) {
  sandbox <- sandbox %||% renv_sandbox_path(project = project)
  Sys.chmod(sandbox, mode = "0555")
}

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"))
}

renv_sandbox_unlock <- function(sandbox = NULL, project = NULL) {
  sandbox <- sandbox %||% renv_sandbox_path(project = project)
  Sys.chmod(sandbox, mode = "0755")
}

#' The default library sandbox
#'
#' @description
#' An \R installation can have up to three types of library paths available
#' to the user:
#'
#' - The _user library_, where \R packages downloaded and installed by the
#'   current user are installed. This library path is only visible to that
#'   specific user.
#'
#' - The _site library_, where \R packages maintained by administrators of a
#'   system are installed. This library path, if it exists, is visible to all
#'   users on the system.
#'
#' - The _default library_, where \R packages distributed with \R itself are
#'   installed. This library path is visible to all users on the system.
#'
#' Normally, only so-called "base" and "recommended" packages should be installed
#' in the default library. (You can get a list of these packages with
#' `installed.packages(priority = c("base", "recommended"))`). However, it is
#' possible for users and administrators to install packages into the default
#' library, if the filesystem permissions permit them to do so. (This, for
#' example, is the default behavior on macOS.)
#'
#' Because the site and default libraries are visible to all users, having those
#' accessible in renv projects can potentially break isolation -- that is,
#' if a package were updated in the default library, that update would be visible
#' to all \R projects on the system.
#'
#' To help defend against this, renv uses something called the "sandbox" to
#' isolate renv projects from non-"base" packages that are installed into the
#' default library. When an renv project is loaded, renv will:
#'
#' - Create a new, empty library path (called the "sandbox"),
#'
#' - Link only the "base" and "recommended" packages from the default library
#'   into the sandbox,
#'
#' - Mark the sandbox as read-only, so that users are unable to install packages
#'   into this library,
#'
#' - Instruct the \R session to use the "sandbox" as the default library.
#'
#' This process is mostly transparent to the user. However, because the sandbox
#' is read-only, if you later need to remove the sandbox, you'll need to reset
#' file permissions manually; for example, with `renv::sandbox$unlock()`.
#'
#' If you'd prefer to keep the sandbox unlocked, you can also set:
#'
#' ```
#' RENV_SANDBOX_LOCKING_ENABLED = FALSE
#' ```
#'
#' in an appropriate startup `.Renviron` or `Renviron.site` file.
#'
#' The sandbox can also be disabled entirely with:
#'
#' ```
#' RENV_CONFIG_SANDBOX_ENABLED = FALSE
#' ```
#'
#' The sandbox library path can also be configured using the `RENV_PATHS_SANDBOX`
#' environment variable: see [paths] for more details.
#'
#' @format NULL
#' @export
sandbox <- list(
  path   = renv_sandbox_path,
  lock   = renv_sandbox_lock,
  locked = renv_sandbox_locked,
  unlock = renv_sandbox_unlock
)


# scaffold.R -----------------------------------------------------------------

#' Generate project infrastructure
#'
#' @description
#' Create the renv project infrastructure. This will:
#'
#' - Create a project library, `renv/library`.
#'
#' - Install renv into the project library.
#'
#' - Update the project `.Rprofile` to call `source("renv/activate.R")` so
#'   that renv is automatically loaded for new \R sessions launched in
#'   this project.
#'
#' - Create `renv/.gitignore`, which tells git to ignore the project library.
#'
#' - Create `.Rbuildignore`, if the project is also a package. This tells
#'   `R CMD build` to ignore the renv infrastructure,
#'
#' - Write a (bare) [lockfile], `renv.lock`.
#'
#' @inheritParams renv-params
#'
#' @param version The version of renv to associate with this project. By
#'   default, the version of renv currently installed is used.
#'
#' @param repos The \R repositories to associate with this project.
#'
#' @param settings A list of renv settings, to be applied to the project
#'   after creation. These should map setting names to the desired values.
#'   See [settings] for more details.
#'
#' @examples
#'
#' \dontrun{
#' # create scaffolding with 'devtools' ignored
#' renv::scaffold(settings = list(ignored.packages = "devtools"))
#' }
#'
#' @export
scaffold <- function(project  = NULL,
                     version  = NULL,
                     repos    = getOption("repos"),
                     settings = NULL)
{
  renv_scope_error_handler()
  renv_scope_options(repos = repos)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  # install renv into project library
  renv_imbue_impl(project, version)

  # write out project infrastructure
  renv_infrastructure_write(project, version)

  # update project settings
  if (is.list(settings))
    renv_settings_persist(project, settings)

  # generate a lockfile
  lockfile <- renv_lockfile_create(
    project  = project,
    libpaths = renv_paths_library(project = project),
    type     = "implicit"
  )

  renv_lockfile_write(lockfile, file = renv_lockfile_path(project))

  # notify user
  fmt <- "- renv infrastructure has been generated for project %s."
  writef(fmt, renv_path_pretty(project))

  # return project invisibly
  invisible(project)
}


# scope.R --------------------------------------------------------------------


renv_scope_tempdir <- function(pattern = "renv-tempdir-",
                               tmpdir = tempdir(),
                               umask = NULL,
                               scope = parent.frame())
{
  dir <- renv_scope_tempfile(pattern = pattern, tmpdir = tmpdir, scope = scope)
  ensure_directory(dir, umask = umask)

  renv_scope_wd(dir, scope = scope)
  dir
}

renv_scope_auth <- function(record, scope = parent.frame()) {

  package <- if (is.list(record)) record$Package else record
  auth <- renv_options_override("renv.auth", package, extra = record)

  if (empty(auth))
    return(FALSE)

  envvars <- catch({
    if (is.function(auth))
      auth(record)
    else
      auth
  })

  # warn user if auth appears invalid
  if (inherits(envvars, "error")) {
    warning(envvars)
    return(FALSE)
  }

  if (empty(envvars))
    return(FALSE)

  renv_scope_envvars(list = as.list(envvars), scope = scope)
  return(TRUE)

}

renv_scope_libpaths <- function(new = .libPaths(), scope = parent.frame()) {
  old <- renv_libpaths_set(new)
  defer(renv_libpaths_set(old), scope = scope)
}

renv_scope_options <- function(..., scope = parent.frame()) {
  new <- list(...)
  old <- options(new)
  defer(options(old), scope = scope)
}

renv_scope_locale <- function(category = "LC_ALL", locale = "", scope = parent.frame()) {
  saved <- Sys.getlocale(category)
  Sys.setlocale(category, locale)
  defer(Sys.setlocale(category, saved), scope = scope)
}

renv_scope_envvars <- function(..., list = NULL, scope = parent.frame()) {

  dots <- list %||% list(...)
  old <- as.list(Sys.getenv(names(dots), unset = NA))
  names(old) <- names(dots)

  unset <- map_lgl(dots, is.null)
  Sys.unsetenv(names(dots[unset]))
  if (length(dots[!unset]))
    do.call(Sys.setenv, dots[!unset])

  defer({
    na <- is.na(old)
    Sys.unsetenv(names(old[na]))
    if (length(old[!na]))
      do.call(Sys.setenv, old[!na])
  }, scope = scope)

}

renv_scope_error_handler <- function(scope = parent.frame()) {

  error <- getOption("error")
  if (!is.null(error))
    return(FALSE)

  call <- renv_error_handler_call()
  options(error = call)

  defer({
    if (identical(getOption("error"), call))
      options(error = error)
  }, scope = scope)

  TRUE

}

# used to enforce usage of curl 7.64.1 within the
# renv_paths_extsoft folder when available on Windows

# nocov start
renv_scope_downloader <- function(scope = parent.frame()) {

  if (!renv_platform_windows())
    return(FALSE)

  if (nzchar(Sys.which("curl")))
    return(FALSE)

  curlroot <- sprintf("curl-%s-win32-mingw", renv_extsoft_curl_version())
  curl <- renv_paths_extsoft(curlroot, "bin/curl.exe")
  if (!file.exists(curl))
    return(FALSE)

  old <- Sys.getenv("PATH", unset = NA)
  if (is.na(old))
    return(FALSE)

  new <- paste(renv_path_normalize(dirname(curl)), old, sep = .Platform$path.sep)

  renv_scope_envvars(PATH = new, scope = scope)

}
# nocov end

# nocov start
renv_scope_rtools <- function(scope = parent.frame()) {

  if (!renv_platform_windows())
    return(FALSE)

  # check for Rtools
  root <- renv_paths_rtools()
  if (!file.exists(root))
    return(FALSE)

  # get environment variables appropriate for version of Rtools
  vars <- renv_rtools_envvars(root)

  # scope envvars in parent
  renv_scope_envvars(list = vars, scope = scope)

}
# nocov end

# nocov start
renv_scope_install <- function(scope = parent.frame()) {

  if (renv_platform_macos())
    renv_scope_install_macos(scope)

  if (renv_platform_wsl())
    renv_scope_install_wsl(scope)

}

renv_scope_install_macos <- function(scope = parent.frame()) {

  # check that we have command line tools available before invoking
  # R CMD config, as this might fail otherwise
  if (once()) {
    if (!renv_xcode_available()) {
      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.")
    }
  }

  # get the current compiler
  args <- c("CMD", "config", "CC")
  cc <- system2(R(), args, stdout = TRUE, stderr = TRUE)

  # check to see if we're using the system toolchain
  # (need to be careful since users might put e.g. ccache or other flags
  # into the CC variable)

  # helper for creating regex matching compiler bits
  matches <- function(pattern) {
    regex <- paste("(?:[[:space:]]|^)", pattern, "(?:[[:space:]]|$)", sep = "")
    grepl(regex, cc)
  }

  sysclang <- case(
    matches("/usr/bin/clang") ~ TRUE,
    matches("clang")          ~ Sys.which("clang") == "/usr/bin/clang",
    FALSE
  )

  # check for an appropriate LLVM toolchain -- if it exists, use it
  spec <- renv_equip_macos_spec()
  if (sysclang && !is.null(spec) && file.exists(spec$dst)) {
    path <- paste(file.path(spec$dst, "bin"), Sys.getenv("PATH"), sep = ":")
    renv_scope_envvars(PATH = path, scope = scope)
  }

  # generate a custom makevars that should better handle compilation
  # with the system toolchain (or other toolchains)
  makevars <- stack()

  # if we don't have an LLVM toolchain available, then try to generate
  # a Makeconf that shields compilation from usages of '-fopenmp'
  if (sysclang) {

    makeconf <- readLines(file.path(R.home("etc"), "Makeconf"), warn = FALSE)
    mplines <- grep(" -fopenmp", makeconf, fixed = TRUE, value = TRUE)

    # read a user makevars (if any)
    contents <- character()
    mvsite <- Sys.getenv(
      "R_MAKEVARS_SITE",
      unset = file.path(R.home("etc"), "Makevars.site")
    )

    if (file.exists(mvsite))
      contents <- readLines(mvsite, warn = FALSE)

    # override usages of '-fopenmp'
    replaced <- gsub(" -fopenmp", "", mplines, fixed = TRUE)
    amended <- unique(c(contents, replaced))
    makevars$push(amended)

  }

  # write makevars to file
  path <- tempfile("Makevars-")
  contents <- unlist(makevars$data(), recursive = TRUE, use.names = FALSE)
  if (length(contents)) {
    writeLines(contents, con = path)
    renv_scope_envvars(R_MAKEVARS_SITE = path, scope = scope)
  }

  TRUE

}

renv_scope_install_wsl <- function(scope = parent.frame()) {
  renv_scope_envvars(R_INSTALL_STAGED = "FALSE", scope = scope)
}
# nocov end

renv_scope_restore <- function(..., scope = parent.frame()) {
  state <- renv_restore_begin(...)
  defer(renv_restore_end(state), scope = scope)
}

renv_scope_git_auth <- function(scope = parent.frame()) {

  # try and tell git to be non-interactive by default
  if (renv_platform_windows()) {
    renv_scope_envvars(
      GIT_TERMINAL_PROMPT = "0",
      scope              = scope
    )
  } else {
    renv_scope_envvars(
      GIT_TERMINAL_PROMPT = "0",
      GIT_ASKPASS         = "/bin/echo",
      scope              = scope
    )
  }

  # use GIT_PAT when provided
  pat <- Sys.getenv("GIT_PAT", unset = NA)
  if (!is.na(pat)) {
    renv_scope_envvars(
      GIT_USERNAME = pat,
      GIT_PASSWORD = "x-oauth-basic",
      scope = scope
    )
  }

  # only set askpass when GIT_USERNAME + GIT_PASSWORD are set
  user <-
    Sys.getenv("GIT_USERNAME", unset = NA) %NA%
    Sys.getenv("GIT_USER",     unset = NA)

  pass <-
    Sys.getenv("GIT_PASSWORD", unset = NA) %NA%
    Sys.getenv("GIT_PASS",     unset = NA)

  if (is.na(user) || is.na(pass))
    return(FALSE)

  askpass <- if (renv_platform_windows())
    system.file("resources/scripts-git-askpass.cmd", package = "renv")
  else
    system.file("resources/scripts-git-askpass.sh", package = "renv")

  renv_scope_envvars(GIT_ASKPASS = askpass, scope = scope)
  return(TRUE)

}

renv_scope_bioconductor <- function(project = NULL,
                                    version = NULL,
                                    scope = parent.frame())
{
  # get current repository
  repos <- getOption("repos")

  # remove old / stale bioc repositories
  stale <- grepl("Bioc", names(repos))
  repos <- repos[!stale]

  # retrieve bioconductor repositories appropriate for this project
  biocrepos <- renv_bioconductor_repos(project = project, version = version)

  # put it all together
  allrepos <- c(repos, biocrepos)

  # activate repositories in this context
  renv_scope_options(repos = renv_vector_unique(allrepos), scope = scope)
}

renv_scope_lock <- function(path = NULL, scope = parent.frame()) {
  renv_lock_acquire(path)
  defer(renv_lock_release(path), scope = scope)
}

renv_scope_trace <- function(what, tracer, scope = parent.frame()) {

  call <- sys.call()
  call[[1L]] <- base::trace
  call[["print"]] <- FALSE
  defer(suppressMessages(untrace(substitute(what))), scope = scope)

  suppressMessages(eval(call, envir = parent.frame()))

}


renv_scope_binding <- function(envir, symbol, replacement, scope = parent.frame()) {
  if (exists(symbol, envir, inherits = FALSE)) {
    old <- renv_binding_replace(envir, symbol, replacement)
    defer(renv_binding_replace(envir, symbol, old), scope = scope)
  } else {
    assign(symbol, replacement, envir)
    defer(rm(list = symbol, envir = envir, inherits = FALSE), scope = scope)
  }
}

renv_scope_tempfile <- function(pattern = "renv-tempfile-",
                                tmpdir  = tempdir(),
                                fileext = "",
                                scope  = parent.frame())
{
  tmpdir <- normalizePath(tmpdir, winslash = "/", mustWork = TRUE)
  path <- renv_path_normalize(tempfile(pattern, tmpdir, fileext))
  defer(unlink(path, recursive = TRUE, force = TRUE), scope = scope)
  invisible(path)
}

renv_scope_umask <- function(umask, scope = parent.frame()) {
  oldmask <- Sys.umask(umask)
  defer(Sys.umask(oldmask), scope = scope)
  invisible(oldmask)
}

renv_scope_wd <- function(dir = getwd(), scope = parent.frame()) {
  owd <- setwd(dir)
  defer(setwd(owd), scope = scope)
  invisible(owd)
}

renv_scope_sandbox <- function(scope = parent.frame()) {
  sandbox <- renv_sandbox_activate()
  defer(renv_sandbox_deactivate(), scope = scope)
  invisible(sandbox)
}

renv_scope_biocmanager <- function(scope = parent.frame()) {

  # silence BiocManager messages when setting repositories
  renv_scope_options(BiocManager.check_repositories = FALSE, scope = scope)

  # R-devel (4.4.0) warns when BiocManager calls .make_numeric_version() without
  # a character argument, so just suppress those warnings in this scope
  #
  # https://github.com/wch/r-source/commit/1338a95618ddcc8a0af77dc06e4018625de06ec3
  renv_scope_options(warn = -1L, scope = scope)

  # return reference to BiocManager namespace
  renv_namespace_load("BiocManager")

}

renv_scope_caution <- function(value) {
  renv_scope_options(
    renv.caution.verbose = value,
    scope = parent.frame()
  )
}

renv_scope_verbose_if <- function(value, scope = parent.frame()) {
  if (value) {
    renv_scope_options(
      renv.verbose = TRUE,
      scope = scope
    )
  }
}


# sdkroot.R ------------------------------------------------------------------


renv_sdkroot_init <- function() {

  if (!renv_platform_macos())
    return()

  enabled <- Sys.getenv("RENV_SDKROOT_ENABLED", unset = "TRUE")
  if (!truthy(enabled, default = TRUE))
    return()

  sdkroot <- Sys.getenv("SDKROOT", unset = NA)
  if (!is.na(sdkroot))
    return()

  sdk <- "/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk"
  if (!file.exists(sdk))
    return()

  makeconf <- file.path(R.home("etc"), "Makeconf")
  if (!file.exists(makeconf))
    return()

  contents <- readLines(makeconf)
  cxx <- grep("^CXX\\s*=", contents, value = TRUE, perl = TRUE)
  if (length(cxx) == 0L)
    return()

  if (!grepl("(?:/usr/local|/opt/homebrew)/opt/llvm", cxx))
    return()

  Sys.setenv(SDKROOT = sdk)

}


# session.R ------------------------------------------------------------------


renv_session_quiet <- function() {

  args <- commandArgs(trailingOnly = FALSE)

  index <- match("--args", args)
  if (!is.na(index))
    args <- head(args, n = index - 1L)

  quiet <- c("-s", "--slave", "--no-echo")
  any(quiet %in% args)

}


# settings.R -----------------------------------------------------------------


the$settings <- new.env(parent = emptyenv())

renv_settings_default <- function(name) {
  default <- the$settings[[name]]$default
  renv_options_override("renv.settings", name, default)
}

renv_settings_defaults <- function() {

  keys <- ls(envir = the$settings, all.names = TRUE)
  vals <- lapply(keys, renv_settings_default)
  names(vals) <- keys
  vals[order(names(vals))]

}

renv_settings_validate <- function(name, value) {

  # NULL implies restore default value
  if (is.null(value))
    return(renv_settings_default(name))

  # run coercion method
  value <- the$settings[[name]]$coerce(value)

  # validate the user-provided value
  validate <- the$settings[[name]]$validate
  ok <- case(
    is.character(validate) ~ value %in% validate,
    is.function(validate)  ~ validate(value),
    TRUE
  )

  if (identical(ok, TRUE))
    return(value)

  # validation failed; warn the user and use default
  fmt <- "%s is an invalid value for setting '%s'; using default %s instead"
  default <- renv_settings_default(name)
  warningf(fmt, deparsed(value), name, deparsed(default))
  default

}

renv_settings_read <- function(path) {

  filebacked(
    context  = "renv_settings_read",
    path     = path,
    callback = renv_settings_read_impl
  )

}

renv_settings_read_impl <- function(path) {

  # check that file exists
  if (!file.exists(path))
    return(NULL)

  # read settings
  settings <- case(
    endswith(path, ".dcf")  ~ renv_settings_read_impl_dcf(path),
    endswith(path, ".json") ~ renv_settings_read_impl_json(path),
    ~ stopf("don't know how to read settings file %s", renv_path_pretty(path))
  )

  # keep only known settings
  known <- ls(envir = the$settings, all.names = TRUE)
  settings <- keep(settings, known)

  # validate
  settings <- enumerate(settings, renv_settings_validate)

  # merge in defaults
  defaults <- renv_settings_defaults()
  missing <- renv_vector_diff(names(defaults), names(settings))
  settings[missing] <- defaults[missing]

  # and return
  settings

}

renv_settings_read_impl_dcf <- function(path) {

  # try to read it
  dcf <- catch(renv_dcf_read(path))
  if (inherits(dcf, "error")) {
    warning(dcf)
    return(NULL)
  }

  # decode encoded values
  enumerate(dcf, function(name, value) {

    case(
      value == "NULL"  ~ NULL,
      value == "NA"    ~ NA,
      value == "NaN"   ~ NaN,
      value == "TRUE"  ~ TRUE,
      value == "FALSE" ~ FALSE,
      ~ strsplit(value, "\\s*,\\s*")[[1]]
    )

  })

}

renv_settings_read_impl_json <- function(path) {

  json <- catch(renv_json_read(path))
  if (inherits(json, "error")) {
    warning(json)
    return(NULL)
  }

  json

}

renv_settings_get <- function(project, name = NULL, default = NULL) {

  # when 'name' is NULL, return all settings
  if (is.null(name)) {
    names <- ls(envir = the$settings, all.names = TRUE)
    settings <- lapply(names, renv_settings_get, project = project)
    names(settings) <- names
    return(settings[order(names(settings))])
  }

  # check for an override via option
  override <- renv_options_override("renv.settings", name)
  if (!is.null(override))
    return(override)

  # try to read settings file
  path <- renv_settings_path(project)
  settings <- renv_settings_read(path)
  if (!is.null(settings))
    return(settings[[name]])

  # if a 'default' value was provided, use it
  if (!missing(default))
    return(default)

  # no value recorded; use default
  renv_settings_default(name)

}

renv_settings_set <- function(project, name, value, persist = TRUE) {

  # read old settings
  settings <- renv_settings_get(project)

  # update setting value
  old <- settings[[name]] %||% renv_settings_default(name)
  new <- renv_settings_validate(name, value)
  settings[[name]] <- new

  # persist if requested
  if (persist)
    renv_settings_persist(project, settings)

  # save session-cached value
  path <- renv_settings_path(project)
  value <- renv_filebacked_set("renv_settings_read", path, settings)

  # invoke update callback if value changed
  if (!identical(old, new))
    renv_settings_updated(project, name, old, new)

  # return value
  invisible(value)

}

renv_settings_updated <- function(project, name, old, new) {
  update <- the$settings[[name]]$update %||% function(...) {}
  update(project, old, new)
}

renv_settings_persist <- function(project, settings) {

  path <- renv_settings_path(project)
  settings <- settings[order(names(settings))]

  # figure out which settings are scalar
  scalar <- map_lgl(names(settings), function(name) {
    the$settings[[name]]$scalar
  })

  # use that to determine which objects should be boxed
  config <- renv_json_config(box = names(settings)[!scalar])

  # write json
  ensure_parent_directory(path)
  renv_json_write(
    object = settings,
    config = config,
    file   = path
  )

}

renv_settings_merge <- function(settings, merge) {
  settings[names(merge)] <- merge
  settings
}

renv_settings_path <- function(project) {
  renv_paths_settings(project = project)
}


# nocov start

renv_settings_updated_cache <- function(project, old, new) {

  # if the cache is being disabled, then copy packages from their
  # symlinks back into the library. note that we don't use symlinks
  # on windows (we use hard links) so in that case there's nothing
  # to be done
  if (renv_platform_windows())
    return(FALSE)

  library <- renv_paths_library(project = project)
  pkgpaths <- list.files(library, full.names = TRUE)
  cachepaths <- map_chr(pkgpaths, renv_cache_path)
  names(pkgpaths) <- cachepaths

  if (empty(pkgpaths)) {
    fmt <- "- The cache has been %s for this project."
    writef(fmt, if (new) "enabled" else "disabled")
    return(TRUE)
  }

  printf("- Synchronizing project library with the cache ... ")

  if (new) {

    # enabling the cache: for any package in the project library, replace
    # that copy with a symlink into the cache, moving the associated package
    # into the cache if appropriate

    # ignore existing symlinks; only copy 'real' packages into the cache
    pkgtypes <- renv_file_type(pkgpaths)
    cachepaths <- cachepaths[pkgtypes != "symlink"]

    # move packages from project library into cache
    callback <- renv_progress_callback(renv_cache_move, length(cachepaths))
    enumerate(cachepaths, callback, overwrite = FALSE)

  } else {

    # disabling the cache: for any package which is a symlink into the cache,
    # replace that symlink with a copy of the cached package

    # figure out which package directories are symlinks
    pkgtypes <- renv_file_type(pkgpaths)
    pkgpaths <- pkgpaths[pkgtypes == "symlink"]

    # remove the existing symlinks
    unlink(pkgpaths)

    # overwrite these symlinks with packages from the cache
    callback <- renv_progress_callback(renv_file_copy, length(pkgpaths))
    enumerate(pkgpaths, callback, overwrite = TRUE)

  }

  writef("Done!")

  fmt <- "- The cache has been %s for this project."
  writef(fmt, if (new) "enabled" else "disabled")

}

renv_settings_updated_ignore <- function(project, old, new) {
  renv_infrastructure_write_gitignore(project = project)
}

renv_settings_migrate <- function(project) {

  old <- renv_paths_renv("settings.dcf",  project = project)
  if (!file.exists(old))
    return()

  new <- renv_paths_renv("settings.json", project = project)
  if (file.exists(new))
    return()

  # update settings
  settings <- renv_settings_read(old)
  renv_settings_persist(project, settings)

}

renv_settings_impl <- function(name, default, scalar, validate, coerce, update) {

  force(name)

  the$settings[[name]] <- list(
    default  = default,
    coerce   = coerce,
    scalar   = scalar,
    validate = validate,
    update   = update
  )

  function(value, project = NULL, persist = TRUE) {
    project <- renv_project_resolve(project)
    if (missing(value))
      renv_settings_get(project, name)
    else
      renv_settings_set(project, name, value, persist)
  }

}


# nocov end

#' Project settings
#'
#' @description
#' Define project-local settings that can be used to adjust the behavior of
#' renv with your particular project.
#'
#' * Get the current value of a setting with (e.g.) `settings$snapshot.type()`
#' * Set current value of a setting with (e.g.)
#'   `settings$snapshot.type("explicit")`.
#'
#' Settings are automatically persisted across project sessions by writing to
#' `renv/settings.json`. You can also edit this file by hand, but you'll need
#' to restart the session for those changes to take effect.
#'
#' ## `bioconductor.version`
#'
#' The Bioconductor version to be used with this project. Use this if you'd
#' like to lock the version of Bioconductor used on a per-project basis.
#' When unset, renv will try to infer the appropriate Bioconductor release
#' using the BiocVersion package if installed; if not, renv uses
#' `BiocManager::version()` to infer the appropriate Bioconductor version.
#'
#' ## `external.libraries`
#'
#' A vector of library paths, to be used in addition to the project's own
#' private library. This can be useful if you have a package available for use
#' in some system library, but for some reason renv is not able to install
#' that package (e.g. sources or binaries for that package are not publicly
#' available, or you have been unable to orchestrate the pre-requisites for
#' installing some packages from source on your machine).
#'
#' ## `ignored.packages`
#'
#' A vector of packages, which should be ignored when attempting to snapshot
#' the project's private library. Note that if a package has already been
#' added to the lockfile, that entry in the lockfile will not be ignored.
#'
#' ## `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
#' `c("Imports", "Depends", "LinkingTo", "Suggests")`.
#'
#' ## `ppm.enabled`
#'
#' Enable [Posit Package Manager](https://packagemanager.posit.co/)
#' integration in this project? When `TRUE`, renv will attempt to transform
#' repository URLs used by PPM into binary URLs as appropriate for the
#' current Linux platform. Set this to `FALSE` if you'd like to continue using
#' source-only PPM URLs, or if you find that renv is improperly transforming
#' your repository URLs. You can still set and use PPM repositories with this
#' option disabled; it only controls whether renv tries to transform source
#' repository URLs into binary URLs on your behalf.
#'
#' ## `ppm.ignored.urls`
#'
#' When [Posit Package Manager](https://packagemanager.posit.co/) integration
#' is enabled, `renv` will attempt to transform source repository URLs into
#' binary repository URLs. This setting can be used if you'd like to avoid this
#' transformation with some subset of repository URLs.
#'
#' ## `r.version`
#'
#' The version of \R to encode within the lockfile. This can be set as a
#' project-specific option if you'd like to allow multiple users to use
#' the same renv project with different versions of \R. renv will
#' still warn the user if the major + minor version of \R used in a project
#' does not match what is encoded in the lockfile.
#'
#' ## `snapshot.type`
#'
#' The type of snapshot to perform by default. See [snapshot] for more
#' details.
#'
#' ## `use.cache`
#'
#' Enable the renv package cache with this project. When active, renv will
#' install packages into a global cache, and link packages from the cache into
#' your renv projects as appropriate. This can greatly save on disk space
#' and install time when for \R packages which are used across multiple
#' projects in the same environment.
#'
#' ## `vcs.manage.ignores`
#'
#' Should renv attempt to manage the version control system's ignore files
#' (e.g. `.gitignore`) within this project? Set this to `FALSE` if you'd
#' prefer to take control. Note that if this setting is enabled, you will
#' need to manually ensure internal data in the project's `renv/` folder
#' is explicitly ignored.
#'
#' ## `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.
#'
#' ## `vcs.ignore.library`
#'
#' Set whether the renv project library is excluded from version control.
#'
#' ## `vcs.ignore.local`
#'
#' Set whether renv project-specific local sources are excluded from version
#' control.
#'
#' # Defaults
#'
#' You can change the default values of these settings for newly-created renv
#' projects by setting \R options for `renv.settings` or `renv.settings.<name>`.
#' For example:
#'
#' ```R
#' options(renv.settings = list(snapshot.type = "all"))
#' options(renv.settings.snapshot.type = "all")
#' ```
#'
#' If both of the `renv.settings` and `renv.settings.<name>` options are set
#' for a particular key, the option associated with `renv.settings.<name>` is
#' used instead. We recommend setting these in an appropriate startup profile,
#' e.g. `~/.Rprofile` or similar.
#'
#' @return
#'   A named list of renv settings.
#'
#' @format NULL
#'
#' @export
#'
#' @examples
#'
#' \dontrun{
#'
#' # view currently-ignored packaged
#' renv::settings$ignored.packages()
#'
#' # ignore a set of packages
#' renv::settings$ignored.packages("devtools", persist = FALSE)
#'
#' }
settings <- list(

  bioconductor.version = renv_settings_impl(
    name     = "bioconductor.version",
    default  = NULL,
    scalar   = TRUE,
    validate = is.character,
    coerce   = as.character,
    update   = NULL
  ),

  ignored.packages = renv_settings_impl(
    name     = "ignored.packages",
    default  = character(),
    scalar   = FALSE,
    validate = is.character,
    coerce   = as.character,
    update   = NULL
  ),

  external.libraries = renv_settings_impl(
    name     = "external.libraries",
    default  = character(),
    scalar   = FALSE,
    validate = is.character,
    coerce   = as.character,
    update   = NULL
  ),

  package.dependency.fields = renv_settings_impl(
    name     = "package.dependency.fields",
    default  = c("Imports", "Depends", "LinkingTo"),
    scalar   = FALSE,
    validate = is.character,
    coerce   = as.character,
    update   = NULL
  ),

  ppm.enabled = renv_settings_impl(
    name     = "ppm.enabled",
    default  = NULL,
    scalar   = TRUE,
    validate = is.logical,
    coerce   = as.logical,
    update   = FALSE
  ),

  ppm.ignored.urls = renv_settings_impl(
    name     = "ppm.ignored.urls",
    default  = NULL,
    scalar   = FALSE,
    validate = is.character,
    coerce   = as.character,
    update   = NULL
  ),

  r.version = renv_settings_impl(
    name     = "r.version",
    default  = NULL,
    scalar   = TRUE,
    validate = is.character,
    coerce   = as.character,
    update   = NULL
  ),

  snapshot.type = renv_settings_impl(
    name     = "snapshot.type",
    default  = "implicit",
    scalar   = TRUE,
    validate = c("all", "custom", "implicit", "explicit", "packrat", "simple"),
    coerce   = as.character,
    update   = NULL
  ),

  use.cache = renv_settings_impl(
    name     = "use.cache",
    default  = TRUE,
    scalar   = TRUE,
    validate = is.logical,
    coerce   = as.logical,
    update   = renv_settings_updated_cache
  ),

  vcs.manage.ignores = renv_settings_impl(
    name     = "vcs.manage.ignores",
    default  = TRUE,
    scalar   = TRUE,
    validate = is.logical,
    coerce   = as.logical,
    update   = NULL
  ),

  vcs.ignore.cellar = renv_settings_impl(
    name     = "vcs.ignore.cellar",
    default  = TRUE,
    scalar   = TRUE,
    validate = is.logical,
    coerce   = as.logical,
    update   = renv_settings_updated_ignore
  ),

  vcs.ignore.library = renv_settings_impl(
    name     = "vcs.ignore.library",
    default  = TRUE,
    scalar   = TRUE,
    validate = is.logical,
    coerce   = as.logical,
    update   = renv_settings_updated_ignore
  ),

  vcs.ignore.local = renv_settings_impl(
    name     = "vcs.ignore.local",
    default  = TRUE,
    scalar   = TRUE,
    validate = is.logical,
    coerce   = as.logical,
    update   = renv_settings_updated_ignore
  )

)


# shell.R --------------------------------------------------------------------


renv_shell_quote <- function(x) {
  if (length(x))
    shQuote(x)
}

renv_shell_path <- function(x) {
  if (length(x))
    shQuote(path.expand(x))
}


# shims.R --------------------------------------------------------------------


the$shims <- new.env(parent = emptyenv())

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) {
    call <- sys.call()
    call[[1L]] <- quote(utils::install.packages)
    return(eval(call, envir = parent.frame()))
  }

  # otherwise, we get to handle it
  install(pkgs)

}

renv_shim_update_packages <- function(lib.loc = NULL, ...) {

  # handle only 0-argument case
  if (nargs() != 0) {
    call <- sys.call()
    call[[1L]] <- quote(utils::update.packages)
    return(eval(call, envir = parent.frame()))
  }

  update(library = lib.loc)

}

renv_shim_remove_packages <- function(pkgs, lib) {

  # handle single-argument case
  if (nargs() != 1) {
    call <- sys.call()
    call[[1L]] <- quote(utils::remove.packages)
    return(eval(call, envir = parent.frame()))
  }

  remove(pkgs)

}

renv_shim_create <- function(shim, sham) {
  formals(shim) <- formals(sham)
  shim
}

renv_shims_enabled <- function(project) {
  config$shims.enabled()
}

renv_shims_activate <- function() {

  renv_shims_deactivate()

  install_shim <- renv_shim_create(renv_shim_install_packages, utils::install.packages)
  assign("install.packages", install_shim, envir = the$shims)

  update_shim <- renv_shim_create(renv_shim_update_packages, utils::update.packages)
  assign("update.packages", update_shim, envir = the$shims)

  remove_shim <- renv_shim_create(renv_shim_remove_packages, utils::remove.packages)
  assign("remove.packages", remove_shim, envir = the$shims)

  args <- list(the$shims, name = "renv:shims", warn.conflicts = FALSE)
  do.call(base::attach, args)

}

renv_shims_deactivate <- function() {
  while ("renv:shims" %in% search())
    detach("renv:shims")
}


# snapshot-auto.R ------------------------------------------------------------


# information about the project library; used to detect whether
# the library appears to have been modified or updated
the$library_info <- NULL

# are we forcing automatic snapshots?
the$auto_snapshot_forced <- FALSE

# did the last attempt at an automatic snapshot fail?
the$auto_snapshot_failed <- FALSE

# are we currently running an automatic snapshot?
the$auto_snapshot_running <- FALSE

# is the next automatic snapshot suppressed?
the$auto_snapshot_suppressed <- FALSE

# nocov start
renv_snapshot_auto <- function(project) {

  # set some state so we know we're running
  the$auto_snapshot_running <- TRUE
  defer(the$auto_snapshot_running <- FALSE)

  # passed pre-flight checks; snapshot the library
  updated <- withCallingHandlers(

    tryCatch(
      renv_snapshot_auto_impl(project),
      error = function(err) FALSE
    ),

    cancel = function() FALSE

  )

  if (updated) {
    lockfile <- renv_path_aliased(renv_lockfile_path(project))
    writef("- Automatic snapshot has updated '%s'.", lockfile)
  }

  invisible(updated)

}

renv_snapshot_auto_impl <- function(project) {

  # validation messages can be noisy; turn off for auto snapshot
  renv_scope_options(
    renv.config.snapshot.validate = FALSE,
    renv.verbose = FALSE
  )

  # get current lockfile state
  lockfile <- renv_paths_lockfile(project)
  old <- file.info(lockfile, extra_cols = FALSE)$mtime

  # perform snapshot without prompting
  snapshot(project = project, prompt = FALSE)

  # check for change in lockfile
  new <- file.info(lockfile, extra_cols = FALSE)$mtime
  old != new

}

renv_snapshot_auto_enabled <- function(project = renv_project_get()) {

  # respect override
  if (the$auto_snapshot_forced)
    return(TRUE)

  # respect config setting
  enabled <- config$auto.snapshot(project = project)
  if (!enabled)
    return(FALSE)

  # only snapshot interactively
  if (!interactive())
    return(FALSE)

  # only automatically snapshot the current project
  if (!renv_project_loaded(project))
    return(FALSE)

  # don't auto-snapshot if the project hasn't been initialized
  if (!renv_project_initialized(project = project))
    return(FALSE)

  # don't auto-snapshot if we don't have a library
  library <- renv_paths_library(project = project)
  if (!file.exists(library))
    return(FALSE)

  # don't auto-snapshot unless the active library is the project library
  if (!renv_file_same(renv_libpaths_active(), library))
    return(FALSE)

  TRUE

}

renv_snapshot_auto_update <- function(project = renv_project_get() ) {

  # check for enabled
  if (!renv_snapshot_auto_enabled(project = project))
    return(FALSE)

  # get path to project library
  libpath <- renv_paths_library(project = project)
  if (!file.exists(libpath))
    return(FALSE)

  # list files + get file info for files in project library
  info <- renv_file_info(libpath)

  # only keep relevant fields
  fields <- c("size", "mtime", "ctime")
  new <- c(info[fields])

  # update our cached info
  old <- the$library_info
  the$library_info <- new

  # if we've suppressed the next automatic snapshot, bail here
  if (the$auto_snapshot_suppressed) {
    the$auto_snapshot_suppressed <- FALSE
    return(FALSE)
  }

  # report if things have changed
  !is.null(old) && !identical(old, new)

}

renv_snapshot_task <- function() {

  # if the previous snapshot attempt failed, do nothing
  if (the$auto_snapshot_failed)
    return(FALSE)

  # treat warnings as errors in this scope
  renv_scope_options(warn = 2L)

  # attempt automatic snapshot, but disable on failure
  tryCatch(
    renv_snapshot_task_impl(),
    error = function(cnd) {
      caution("Error generating automatic snapshot: %s", conditionMessage(cnd))
      caution("Automatic snapshots will be disabled. Use `renv::snapshot()` to manually update the lockfile.")
      the$auto_snapshot_failed <- TRUE
    }
  )

}

renv_snapshot_task_impl <- function() {

  # check for active renv project
  project <- renv_project_get()
  if (is.null(project))
    return(invisible(FALSE))

  # see if library state has updated
  updated <- renv_snapshot_auto_update(project = project)
  if (!updated)
    return(invisible(FALSE))

  # library has updated; perform auto snapshot
  renv_snapshot_auto(project = project)

}

renv_snapshot_auto_suppress_next <- function() {

  # if we're currently running an automatic snapshot, then nothing to do
  if (the$auto_snapshot_running)
    return()

  # otherwise, set the suppressed flag
  the$auto_snapshot_suppressed <- TRUE

}

# nocov end


# 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
#' Call `renv::snapshot()` to update a [lockfile] with the current state of
#' dependencies in the project library. The lockfile can be used to later
#' [restore] these dependencies as required.
#'
#' It's also possible to call `renv::snapshot()` with a non-renv project,
#' in which case it will record the current state of dependencies in the
#' current library paths. This makes it possible to [restore] the current packages,
#' 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.
#'
#' # Snapshot types
#'
#' Depending on how you prefer to manage dependencies, you might prefer
#' selecting a different snapshot mode. The modes available are as follows:
#'
#' \describe{
#'
#' \item{`"implicit"`}{
#' (The default) Capture only packages which appear to be used in your project,
#' as determined by `renv::dependencies()`. This ensures that only the packages
#' actually required by your project will enter the lockfile; the downside
#' if it might be slow if your project contains a large number of files.
#' If speed becomes an issue, you might consider using `.renvignore` files to
#' limit which files renv uses for dependency discovery, or switching to
#' explicit mode, as described next.
#' }
#'
#' \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.
#' }
#'
#' \item{`"all"`}{
#' Capture all packages within the active \R libraries in the lockfile.
#' This is the quickest and simplest method, but may lead to undesired
#' packages (e.g. development dependencies) entering the lockfile.
#' }
#'
#' \item{`"custom"`}{
#' Like `"implicit"`, but use a custom user-defined filter instead. The filter
#' should be specified by the \R option `renv.snapshot.filter`, and should
#' either be a character vector naming a function (e.g. `"package::method"`),
#' or be a function itself. The function should only accept one argument (the
#' project directory), and should return a vector of package names to include
#' in the lockfile.
#' }
#'
#' }
#'
#' You can change the snapshot type for the current project with [settings()].
#' For example, the following code will switch to using `"explicit"` snapshots:
#'
#' ```
#' renv::settings$snapshot.type("explicit")
#' ```
#'
#' When the `packages` argument is set, `type` is ignored, and instead only the
#' requested set of packages, and their recursive dependencies, will be written
#' to the lockfile.
#'
#' @inherit renv-params
#'
#' @param library The \R libraries to snapshot. When `NULL`, the active \R
#'   libraries (as reported by `.libPaths()`) are used.
#'
#' @param lockfile The location where the generated lockfile should be written.
#'   By default, the lockfile is written to a file called `renv.lock` in the
#'   project directory. When `NULL`, the lockfile (as an \R object) is returned
#'   directly instead.
#'
#' @param type The type of snapshot to perform:
#'   * `"implict"`, (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.
#'
#' @inheritParams dependencies
#'
#' @param repos The \R repositories to be recorded in the lockfile. Defaults
#'   to the currently active package repositories, as retrieved by
#'   `getOption("repos")`.
#'
#'
#' @param packages A vector of packages to be included in the lockfile. When
#'   `NULL` (the default), all packages relevant for the type of snapshot being
#'   performed will be included. When set, the `type` argument is ignored.
#'   Recursive dependencies of the specified packages will be added to the
#'   lockfile as well.
#'
#' @param exclude A vector of packages to be explicitly excluded from the lockfile.
#'   Note that transitive package dependencies will always be included, to avoid
#'   potentially creating an incomplete / non-functional lockfile.
#'
#' @param update Boolean; if the lockfile already exists, then attempt to update
#'   that lockfile without removing any prior package records.
#'
#' @param force Boolean; force generation of a lockfile even when pre-flight
#'   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)?
#'
#' @return The generated lockfile, as an \R object (invisibly). Note that
#'   this function is normally called for its side effects.
#'
#'
#' @seealso More on handling package [dependencies()]
#' @family reproducibility
#'
#' @export
#'
#' @example examples/examples-init.R
snapshot <- function(project  = NULL,
                     ...,
                     library  = NULL,
                     lockfile = paths$lockfile(project = project),
                     type     = settings$snapshot.type(project = project),
                     dev      = FALSE,
                     repos    = getOption("repos"),
                     packages = NULL,
                     exclude  = NULL,
                     prompt   = interactive(),
                     update   = FALSE,
                     force    = FALSE,
                     reprex   = FALSE)
{
  renv_consent_check()
  renv_scope_error_handler()
  renv_dots_check(...)

  renv_snapshot_auto_suppress_next()

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_scope_verbose_if(prompt)

  repos <- renv_repos_validate(repos)
  renv_scope_options(repos = repos)

  if (!is.null(lockfile))
    renv_activate_prompt("snapshot", library, prompt, project)

  libpaths <- renv_path_normalize(library %||% renv_libpaths_all())
  if (config$snapshot.validate())
    renv_snapshot_preflight(project, libpaths)

  # when packages is set, we treat this as an 'all' type snapshot, but
  # with explicit package filters turned on
  if (!is.null(packages)) {

    if (!missing(type)) {
      fmt <- "packages argument is set; type argument %s will be ignored"
      warningf(fmt, stringify(type))
    }

    type <- "packages"

  }

  alt <- new <- renv_lockfile_create(
    project  = project,
    type     = type,
    libpaths = libpaths,
    packages = packages,
    exclude  = exclude,
    prompt   = prompt,
    force    = force,
    dev      = dev
  )

  if (is.null(lockfile))
    return(new)

  # if running as part of 'reprex', then render output inline
  if (reprex)
    return(renv_snapshot_reprex(new))

  # check for missing dependencies and warn if any are discovered
  # (note: use 'new' rather than 'alt' here as we don't want to attempt
  # validation on uninstalled packages)
  valid <- renv_snapshot_validate(project, new, libpaths)
  renv_snapshot_validate_report(valid, prompt, force)

  # get prior lockfile state
  old <- list()
  if (file.exists(lockfile)) {

    # read a pre-existing lockfile (if any)
    old <- renv_lockfile_read(lockfile)

    # preserve records from alternate OSes in lockfile
    alt <- renv_snapshot_preserve(old, new)

    # check if there are any changes in the lockfile
    diff <- renv_lockfile_diff(old, alt)
    if (empty(diff)) {
      writef("- The lockfile is already up to date.")
      return(renv_snapshot_successful(alt, prompt, project))
    }

  }

  # update new reference
  new <- alt

  # if we're only updating the lockfile, then merge any missing records
  # from 'old' back into 'new'
  if (update)
    for (package in names(old$Packages))
      new$Packages[[package]] <- new$Packages[[package]] %||% old$Packages[[package]]

  # report actions to the user
  actions <- renv_lockfile_diff_packages(old, new)
  if (prompt || renv_verbose())
    renv_snapshot_report_actions(actions, old, new)

  # request user confirmation
  cancel_if(length(actions) && file.exists(lockfile) && prompt && !proceed())

  # write it out
  ensure_parent_directory(lockfile)
  renv_lockfile_write(new, file = lockfile)

  # ensure the lockfile is .Rbuildignore-d
  renv_infrastructure_write_rbuildignore(project)

  # ensure the activate script is up-to-date
  renv_infrastructure_write_activate(project, create = FALSE)

  # return new records
  renv_snapshot_successful(new, prompt, project)
}

renv_snapshot_preserve <- function(old, new) {
  records <- filter(old$Packages, renv_snapshot_preserve_impl)
  if (length(records))
    new$Packages[names(records)] <- records
  new
}

renv_snapshot_preserve_impl <- function(record) {

  ostype <- tolower(record[["OS_type"]] %||% "")
  if (!nzchar(ostype))
    return(FALSE)

  altos <- if (renv_platform_unix()) "windows" else "unix"
  identical(ostype, altos)

}

renv_snapshot_preflight <- function(project, libpaths) {
  lapply(libpaths, renv_snapshot_preflight_impl, project = project)
}

renv_snapshot_preflight_impl <- function(project, library) {
  renv_snapshot_preflight_library_exists(project, library)
}

renv_snapshot_preflight_library_exists <- function(project, library) {

  # check that we have a directory
  type <- renv_file_type(library, symlinks = FALSE)
  if (type == "directory")
    return(TRUE)

  # if the file exists but isn't a directory, fail
  if (nzchar(type)) {
    fmt <- "library '%s' exists but is not a directory"
    stopf(fmt, renv_path_aliased(library))
  }

  # the directory doesn't exist; perhaps the user hasn't called init
  if (identical(library, renv_paths_library(project = project))) {
    fmt <- "project '%s' has no private library -- have you called `renv::init()`?"
    stopf(fmt, renv_path_aliased(project))
  }

  # user tried to snapshot arbitrary but missing path
  fmt <- "library '%s' does not exist; cannot proceed"
  stopf(fmt, renv_path_aliased(library))

}

renv_snapshot_validate <- function(project, lockfile, libpaths) {

  # allow user to disable snapshot validation, just in case
  enabled <- config$snapshot.validate()
  if (!enabled)
    return(TRUE)

  methods <- list(
    renv_snapshot_validate_bioconductor,
    renv_snapshot_validate_dependencies_available,
    renv_snapshot_validate_dependencies_compatible,
    renv_snapshot_validate_sources
  )

  ok <- map_lgl(methods, function(method) {
    tryCatch(
      method(project, lockfile, libpaths),
      error = function(e) { warning(e); FALSE }
    )
  })

  all(ok)

}

renv_snapshot_validate_report <- function(valid, prompt, force) {

  # nothing to do if everything is valid
  if (valid) {
    dlog("snapshot", "passed pre-flight validation checks")
    return(TRUE)
  }

  # if we're forcing snapshot, ignore the failures
  if (force) {
    dlog("snapshot", "ignoring error in pre-flight validation checks as 'force = TRUE'")
    return(TRUE)
  }

  # in interactive sessions, if 'prompt' is set, then ask the user
  # if they would like to proceed
  if (interactive() && !testing() && prompt) {
    cancel_if(!proceed())
    return(TRUE)
  }

  # otherwise, bail on error (need to use 'force = TRUE')
  stop("aborting snapshot due to pre-flight validation failure")

}

# nocov start
renv_snapshot_validate_bioconductor <- function(project, lockfile, libpaths) {

  ok <- TRUE

  # check whether any packages are installed from Bioconductor
  records <- renv_lockfile_records(lockfile)
  sources <- extract_chr(records, "Source")
  if (!"Bioconductor" %in% sources)
    return(ok)

  # check for BiocManager or BiocInstaller
  package <- renv_bioconductor_manager()
  if (!package %in% names(records)) {

    text <- c(
      "One or more Bioconductor packages are used in your project,",
      "but the %s package is not available.",
      "",
      "Consider installing %s before snapshot.",
      ""
    )
    caution(text, package)

    ok <- FALSE
  }

  # check that Bioconductor packages are from correct release
  version <-
    lockfile$Bioconductor$Version %||%
    renv_bioconductor_version(project = project)

  biocrepos <- renv_bioconductor_repos(version = version)
  renv_scope_options(repos = biocrepos)

  # collect Bioconductor records
  bioc <- records %>%
    filter(function(record) renv_record_source(record) == "bioconductor") %>%
    map(function(record) record[c("Package", "Version")]) %>%
    bind()

  # collect latest versions of these packages
  bioc$Latest <- vapply(bioc$Package, function(package) {
    entry <- catch(renv_available_packages_latest(package))
    if (inherits(entry, "error"))
      return("<NA>")
    entry$Version
  }, FUN.VALUE = character(1))

  # check for version mismatches (allow mismatch in minor version)
  bioc$Mismatch <- mapply(function(current, latest) {

    if (identical(latest, "<NA>"))
      return(TRUE)

    current <- renv_version_maj_min(current)
    latest <- renv_version_maj_min(latest)
    current != latest

  }, bioc$Version, bioc$Latest)

  bad <- bioc[bioc$Mismatch, ]
  if (nrow(bad)) {

    fmt <- "%s [installed %s != latest %s]"
    msg <- sprintf(fmt, format(bad$Package), format(bad$Version), bad$Latest)
    caution_bullets(
      "The following Bioconductor packages appear to be from a separate Bioconductor release:",
      msg,
      c(
        "renv may be unable to restore these packages.",
        paste("Bioconductor version:", version)
      )
    )

    ok <- FALSE
  }

  ok

}
# nocov end

renv_snapshot_validate_dependencies_available <- function(project, lockfile, libpaths) {

  # use library to collect package dependency versions
  records <- renv_lockfile_records(lockfile)
  packages <- extract_chr(records, "Package")
  locs <- find.package(packages, lib.loc = libpaths, quiet = TRUE)
  deps <- bapply(locs, renv_dependencies_discover_description)
  if (empty(deps))
    return(TRUE)

  splat <- split(deps, deps$Package)

  # exclude base R packages
  splat <- splat[renv_vector_diff(names(splat), renv_packages_base())]

  # check for required packages not currently installed
  requested <- names(splat)
  missing <- renv_vector_diff(requested, packages)
  if (empty(missing))
    return(TRUE)

  # exclude ignored packages
  missing <- renv_vector_diff(missing, settings$ignored.packages(project = project))
  if (empty(missing))
    return(TRUE)

  usedby <- map_chr(missing, function(package) {

    revdeps <- sort(unique(basename(deps$Source)[deps$Package == package]))

    items <- revdeps; limit <- 3L
    if (length(revdeps) > limit) {
      rest <- length(revdeps) - limit
      suffix <- paste("and", length(revdeps) - 3L, plural("other", rest))
      items <- c(revdeps[seq_len(limit)], suffix)
    }

    paste(items, collapse = ", ")

  })

  caution_bullets(
    "The following required packages are not installed:",
    sprintf("%s  [required by %s]", format(missing), usedby),
    "Consider reinstalling these packages before snapshotting the lockfile."
  )

  FALSE

}

renv_snapshot_validate_dependencies_compatible <- function(project, lockfile, libpaths) {

  # use library to collect package dependency versions
  records <- renv_lockfile_records(lockfile)
  packages <- extract_chr(records, "Package")
  locs <- find.package(packages, lib.loc = libpaths, quiet = TRUE)
  deps <- bapply(locs, renv_dependencies_discover_description)
  if (empty(deps))
    return(TRUE)

  splat <- split(deps, deps$Package)

  # exclude base R packages
  splat <- splat[renv_vector_diff(names(splat), renv_packages_base())]

  # collapse requirements for each package
  bad <- enumerate(splat, function(package, requirements) {

    # skip NULL records (should be handled above)
    record <- records[[package]]
    if (is.null(record))
      return(NULL)

    version <- record$Version

    # drop packages without explicit version requirement
    requirements <- requirements[nzchar(requirements$Require), ]
    if (nrow(requirements) == 0)
      return(NULL)

    # add in requested version
    requirements$Requested <- version

    # generate expressions to evaluate
    fmt <- "package_version('%s') %s package_version('%s')"
    code <- with(requirements, sprintf(fmt, Requested, Require, Version))
    parsed <- parse(text = code)
    ok <- map_lgl(parsed, eval, envir = baseenv())

    # return requirements that weren't satisfied
    requirements[!ok, ]

  })

  bad <- bind(bad)
  if (empty(bad))
    return(TRUE)

  package  <- basename(bad$Source)
  requires <- sprintf("%s (%s %s)", bad$Package, bad$Require, bad$Version)
  request  <- bad$Requested

  fmt <- "%s requires %s, but version %s is installed"
  txt <- sprintf(fmt, format(package), format(requires), format(request))
  caution_bullets(
    "The following package(s) have unsatisfied dependencies:",
    txt,
    "Consider updating the required dependencies as appropriate."
  )

  FALSE

}

renv_snapshot_validate_sources <- function(project, lockfile, libpaths) {
  records <- renv_lockfile_records(lockfile)
  renv_check_unknown_source(records, project)
}

# NOTE: if packages are found in multiple libraries,
# then the first package found in the library paths is
# kept and others are discarded
renv_snapshot_libpaths <- function(libpaths = NULL,
                                   project  = NULL)
{
  dynamic(
    key   = list(libpaths = libpaths, project = project),
    value = renv_snapshot_libpaths_impl(libpaths, project)
  )
}

renv_snapshot_libpaths_impl <- function(libpaths = NULL,
                                        project  = NULL)
{
  records <- uapply(
    libpaths,
    renv_snapshot_library,
    project = project
  )

  dupes <- duplicated(names(records))
  records[!dupes]
}

renv_snapshot_library <- function(library = NULL,
                                  records = TRUE,
                                  project = NULL)
{
  # list packages in the library
  library <- renv_path_normalize(library %||% renv_libpaths_active())
  paths <- list.files(library, full.names = TRUE)

  # remove 'base' packages
  paths <- paths[!basename(paths) %in% renv_packages_base()]

  # remove ignored packages
  ignored <- renv_project_ignored_packages(project = project)
  paths <- paths[!basename(paths) %in% ignored]

  # remove paths that are not valid package names
  pattern <- sprintf("^%s$", .standard_regexps()$valid_package_name)
  paths <- paths[grep(pattern, basename(paths))]

  # validate the remaining set of packages
  valid <- renv_snapshot_library_diagnose(library, paths)

  # remove duplicates (so only first package entry discovered in library wins)
  duplicated <- duplicated(basename(valid))
  packages <- valid[!duplicated]

  # early exit if we're just collecting the list of packages
  if (!records)
    return(basename(packages))

  # snapshot description files
  descriptions <- file.path(packages, "DESCRIPTION")
  records <- lapply(descriptions, compose(catch, renv_snapshot_description))
  names(records) <- basename(packages)

  # report any snapshot failures
  broken <- filter(records, inherits, what = "error")
  if (length(broken)) {

    messages <- map_chr(broken, conditionMessage)
    text <- sprintf("'%s': %s", names(broken), messages)
    caution_bullets(
      "renv was unable to snapshot the following packages:",
      text,
      "These packages will likely need to be repaired and / or reinstalled."
    )

    stopf("snapshot of library %s failed", renv_path_pretty(library))

  }

  # name results and return
  names(records) <- map_chr(records, `[[`, "Package")
  records

}

renv_snapshot_library_diagnose <- function(library, 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_library_diagnose_broken_link <- function(library, paths) {

  broken <- !file.exists(paths)
  if (!any(broken))
    return(paths)

  caution_bullets(
    "The following package(s) have broken symlinks into the cache:",
    basename(paths)[broken],
    "Use `renv::repair()` to try and reinstall these packages."
  )

  paths[!broken]

}

renv_snapshot_library_diagnose_tempfile <- function(library, paths) {

  names <- basename(paths)
  missing <- grepl("^file(?:\\w){12}", names)
  if (!any(missing))
    return(paths)

  caution_bullets(
    "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."
  )

  paths[!missing]

}

renv_snapshot_library_diagnose_missing_description <- function(library, paths) {

  desc <- file.path(paths, "DESCRIPTION")
  missing <- !file.exists(desc)
  if (!any(missing))
    return(paths)

  caution_bullets(
    "The following package(s) are missing their DESCRIPTION files:",
    sprintf("%s [%s]", format(basename(paths[missing])), paths[missing]),
    c(
      "These may be left over from a prior, failed installation attempt.",
      "Consider removing or reinstalling these packages."
    )
  )

  paths[!missing]

}

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)
  }

  # read and snapshot DESCRIPTION file
  dcf <- renv_description_read(path, package)
  renv_snapshot_description_impl(dcf, path)

}

renv_snapshot_description_impl <- function(dcf, path = NULL) {

  # 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 %||% "<unknown>")
  }

  # 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)
  }

  # generate a Requirements field -- primarily for use by 'pak'
  fields <- c("Depends", "Imports", "LinkingTo")
  deps <- bind(map(dcf[fields], renv_description_parse_field))
  all <- unique(csort(unlist(deps$Package)))
  dcf[["Requirements"]] <- all

  # get remotes fields
  git <- grep("^git", names(dcf), value = TRUE)
  remotes <- grep("^Remote", names(dcf), value = TRUE)

  is_repo <-
    is.null(dcf[["RemoteType"]]) ||
    identical(dcf[["RemoteType"]], "standard")

  # only keep relevant fields
  extra <- c("Repository", "OS_type")
  all <- c(
    required, extra,
    if (!is_repo) c(remotes, git),
    "Requirements", "Hash"
  )
  keep <- renv_vector_intersect(all, names(dcf))

  # return as list
  as.list(dcf[keep])

}

renv_snapshot_description_source <- function(dcf) {

  # 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"]]
  repository <- dcf[["Repository"]]
  if (identical(type, "standard") && !is.null(repository))
    return(list(Source = "Repository", Repository = repository))
  else if (!is.null(type))
    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"]]))
    return(list(Source = "Bioconductor"))

  # check for a declared repository
  if (!is.null(repository))
    return(list(Source = "Repository", Repository = repository))

  # check for a valid package name
  package <- dcf[["Package"]]
  if (is.null(package))
    return(list(Source = "unknown"))

  # if this is running as part of the synchronization check, skip CRAN queries
  # https://github.com/rstudio/renv/issues/812
  if (the$project_synchronized_check_running)
    return(list(Source = "unknown"))

  # 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
  # repository. however, this is often what users intend, especially if
  # they haven't configured their repository to tag the packages it makes
  # available with the 'Repository:' field in the DESCRIPTION file.
  #
  # still, this has the awkward side-effect of a package's source potentially
  # depending on what repositories happen to be active at the time of snapshot,
  # so it'd be nice to tighten up the logic here if possible
  #
  # NOTE: local sources are also searched here as part of finding the 'latest'
  # available package, so we need to handle local packages discovered here
  tryCatch(
    renv_snapshot_description_source_hack(package, dcf),
    error = function(e) list(Source = "unknown")
  )

}

renv_snapshot_description_source_hack <- function(package, dcf) {

  # check cellar
  for (type in renv_package_pkgtypes()) {
    cellar <- renv_available_packages_cellar(type)
    if (package %in% cellar$Package)
      return(list(Source = "Cellar"))
  }

  # check available packages
  latest <- catch(renv_available_packages_latest(package))
  if (is.null(latest) || inherits(latest, "error"))
    return(list(Source = "unknown"))

  # check version; use unknown if it's too new
  if (renv_version_gt(dcf[["Version"]], latest[["Version"]]))
    return(list(Source = "unknown"))

  # ok, this package appears to be from a package repository
  list(Source = "Repository", Repository = latest[["Repository"]])

}


# nocov start
renv_snapshot_report_actions <- function(actions, old, new) {

  if (!renv_verbose())
    return(invisible())

  if (length(actions)) {
    lhs <- renv_lockfile_records(old)
    rhs <- renv_lockfile_records(new)
    renv_pretty_print_records_pair(
      "The following package(s) will be updated in the lockfile:",
      lhs[names(lhs) %in% names(actions)],
      rhs[names(rhs) %in% names(actions)]
    )
  }

  oldr <- old$R$Version
  newr <- new$R$Version
  rdiff <- renv_version_compare(oldr %||% "0", newr %||% "0")

  if (rdiff != 0L) {
    n <- max(nchar(names(actions)), 0)
    fmt <- paste("-", format("R", width = n), " ", "[%s -> %s]")
    msg <- sprintf(fmt, oldr %||% "*", newr %||% "*")
    writef(
      c("The version of R recorded in the lockfile will be updated:", msg, "")
    )
  }

}
# nocov end

# compute the package dependencies inferred for a project,
# respecting the snapshot type selected (or currently configured)
# for the associated project
renv_snapshot_dependencies <- function(project, type = NULL, dev = FALSE) {

  type <- type %||% settings$snapshot.type(project = project)

  packages <- dynamic(
    list(project = project, type = type, dev = dev),
    renv_snapshot_dependencies_impl(project, type, dev)
  )

  if (!renv_tests_running())
    packages <- unique(c(packages, "renv"))

  packages

}

renv_snapshot_dependencies_impl <- function(project, type = NULL, dev = FALSE) {

  if (type %in% "all") {
    packages <- installed_packages(field = "Package")
    return(setdiff(packages, renv_packages_base()))
  }

  if (type %in% "custom") {
    filter <- renv_snapshot_filter_custom_resolve()
    return(filter(project))
  }

  path <- case(
    type %in% c("packrat", "implicit") ~ project,
    type %in% "explicit" ~ file.path(project, "DESCRIPTION"),
    ~ {
      fmt <- "internal error: unhandled snapshot type '%s' in %s"
      stopf(fmt, type, stringify(sys.call()))
    }
  )

  # 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()

  packages <- withCallingHandlers(

    renv_dependencies_impl(
      path = path,
      root = project,
      field = "Package",
      errors = config$dependency.errors(),
      dev = dev
    ),

    # require user confirmation to proceed if there's a reported error
    renv.dependencies.problems = function(cnd) {

      if (identical(config$dependency.errors(), "ignored"))
        return()

      if (interactive() && !proceed())
        cancel()

    },

    # collect information about folders containing lots of files
    renv.dependencies.count = function(cnd) {
      count[[cnd$data$path]] <<- cnd$data$count
    },

    # notify the user if we took a long time to discover dependencies
    renv.dependencies.elapsed_time = function(cnd) {

      # only relevant for implicit-type snapshots
      if (!type %in% c("packrat", "implicit"))
        return()

      # check for timeout
      elapsed <- cnd$data
      limit <- getOption("renv.dependencies.elapsed_time_threshold", default = 10L)
      if (elapsed < limit)
        return()

      # tally up directories with lots of files
      count <- count[order(count)]
      count <- count[count >= 200]

      # report to user
      lines <- c(
        "",
        "NOTE: Dependency discovery took %s during snapshot.",
        "Consider using .renvignore to ignore files, or switching to explicit snapshots.",
        "See `?renv::dependencies` for more information.",
        if (length(count)) c(
          "",
          sprintf("- %s: %s", format(names(count)), nplural("file", count))
        ),
        ""
      )

      # force output in this scope
      renv_scope_caution(TRUE)
      caution(lines, renv_difftime_format(elapsed))

    }

  )

  unique(packages)

}

# compute package records from the provided library paths,
# normally to be included as part of an renv lockfile
renv_snapshot_packages <- function(packages, libpaths, project) {

  ignored <- c(
    renv_packages_base(),
    renv_project_ignored_packages(project = project),
    if (renv_tests_running()) "renv"
  )

  callback <- function(package, location, project) {
    if (nzchar(location) && !package %in% ignored)
      return(location)
  }

  # expand package dependency tree
  paths <- renv_package_dependencies(
    packages = packages,
    libpaths = libpaths,
    callback = callback,
    project = project
  )

  # keep only packages with known locations
  paths <- convert(filter(paths, is.character), "character")

  # diagnose issues with the scanned packages
  paths <- uapply(libpaths, function(library) {
    renv_snapshot_library_diagnose(
      library = library,
      paths   = filter(paths, startswith, prefix = library))
  })

  # now, snapshot the remaining packages
  records <- map(paths, renv_snapshot_description)

}

renv_snapshot_report_missing <- function(missing, type) {

  missing <- setdiff(missing, "renv")
  if (empty(missing))
    return(invisible())

  preamble <- "The following required packages are not installed:"

  postamble <- c(
    "Packages must first be installed before renv can snapshot them.",
    if (type %in% "explicit")
      "If these packages are no longer required, consider removing them from your DESCRIPTION file."
    else
      "Use `renv::dependencies()` to see where this package is used in your project."
  )

  caution_bullets(
    preamble = preamble,
    values = sort(unique(missing)),
    postamble = postamble
  )

  # only prompt the user to install if a restart is available
  restart <- findRestart("renv_recompute_records")
  if (is.null(restart))
    return(invisible())

  choices <- c(
    snapshot = "Snapshot, just using the currently installed packages.",
    install  = "Install the packages, then snapshot.",
    cancel   = "Cancel, and resolve the situation on your own."
  )

  choice <- menu(choices, title = "What do you want to do?")

  if (choice == "snapshot") {
    # do nothing
  } else if (choice == "install") {
    install(missing, prompt = FALSE)
    invokeRestart(restart)
  } else {
    cancel()
  }

  invisible()

}

renv_snapshot_filter_custom_resolve <- function() {

  # check for custom filter
  filter <- getOption("renv.snapshot.filter", default = NULL)
  if (is.null(filter)) {
    fmt <- "snapshot of type '%s' requested, but '%s' is not registered"
    stopf(fmt, "custom", "renv.snapshot.filter")
  }

  # allow for filter naming a function to use
  if (is.character(filter))
    filter <- eval(parse(text = filter), envir = baseenv())

  # check we got a function
  if (!is.function(filter)) {
    fmt <- "snapshot of type '%s' requested, but '%s' is not a function"
    stopf(fmt, "custom", "renv.snapshot.filter")
  }

  # return resolved function
  filter

}

renv_snapshot_fixup <- function(records) {

  records <- renv_snapshot_fixup_renv(records)
  records

}

renv_snapshot_fixup_renv <- function(records) {

  # don't run when testing renv
  if (renv_tests_running())
    return(records)

  # check for an existing valid record
  record <- records$renv
  if (is.null(record))
    return(records)

  source <- renv_record_source(record)
  if (source != "unknown")
    return(records)

  # no valid record available; construct a synthetic one
  remote <- renv_metadata_remote()

  # add it to the set of records
  records$renv <- renv_remotes_resolve(remote)

  # return it
  records

}

renv_snapshot_reprex <- function(lockfile) {

  fmt <- "<sup>Lockfile generated by renv %s.</sup>"
  version <- sprintf(fmt, renv_metadata_version_friendly())

  text <- c(
    "<details style=\"margin-bottom: 10px;\">",
    "<summary>Lockfile</summary>",
    "```",
    renv_lockfile_write(lockfile, file = NULL),
    "```",
    version,
    "</details>"
  )

  output <- paste(text, collapse = "\n")
  class(output) <- "knit_asis"
  attr(output, "knit_cacheable") <- NA

  output

}

renv_snapshot_successful <- function(records, prompt, project) {

  # update snapshot flag
  the$auto_snapshot_failed <- FALSE

  # perform python snapshot on success
  renv_python_snapshot(project, prompt)

  # return generated records
  invisible(records)

}


# socket.R -------------------------------------------------------------------


# avoid R CMD check errors with older R
if (getRversion() < "4.0") {
  utils::globalVariables(c("serverSocket", "socketAccept"))
}

renv_socket_server <- function(min = 49152, max = 65535) {

  # create the socket server
  port <- socket <- NULL
  for (i in 1:2000) catch({
    port <- sample(min:max, size = 1L)
    socket <- serverSocket(port)
    break
  })

  # if we still don't have a socket here, we failed
  if (is.null(socket))
    stop("error creating socket server: couldn't find open port")

  # return information about the server
  list(
    socket = socket,
    port = port,
    pid = Sys.getpid()
  )
}

renv_socket_connect <- function(port, open, timeout = getOption("timeout")) {
  socketConnection(
    host = "127.0.0.1",
    port = port,
    open = open,
    blocking = TRUE,
    encoding = "native.enc",
    timeout = timeout
  )
}

renv_socket_accept <- function(socket, open, timeout = getOption("timeout")) {
  socketAccept(
    socket = socket,
    open = open,
    blocking = TRUE,
    encoding = "native.enc",
    timeout = timeout
  )
}


# stack.R --------------------------------------------------------------------


stack <- function(mode = "list") {

  .data <- list()
  storage.mode(.data) <- mode

  list(

    push = function(...) {
      dots <- list(...)
      for (data in dots) {
        if (is.null(data))
          .data[length(.data) + 1] <<- list(NULL)
        else
          .data[[length(.data) + 1]] <<- data
      }
    },

    pop = function() {
      item <- .data[[length(.data)]]
      length(.data) <<- length(.data) - 1
      item
    },

    peek = function() {
      .data[[length(.data)]]
    },

    contains = function(data) {
      data %in% .data
    },

    empty = function() {
      length(.data) == 0
    },

    get = function(index) {
      if (index <= length(.data)) .data[[index]]
    },

    set = function(index, value) {
      .data[[index]] <<- value
    },

    clear = function() {
      .data <<- list()
    },

    data = function() {
      .data
    }

  )

}


# status.R -------------------------------------------------------------------


the$status_running <- FALSE

#' Report inconsistencies between lockfile, library, and dependencies
#'
#' @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
#' successfully `restore()`ing the project in the future or on another machine.
#'
#' `renv::load()` will report if any issues are detected when starting an
#' renv project; we recommend resolving these issues before doing any
#' further work on your project.
#'
#' See the headings below for specific advice on resolving any issues
#' revealed by `status()`.
#'
#' # Missing packages
#'
#' `status()` first checks that all packages used by the project are installed.
#' This must be done first because if any packages are missing we can't tell for
#' sure that a package isn't used; it might be a dependency that we don't know
#' about. Once you have resolve any installation issues, you'll need to run
#' `status()` again to reveal the next set of potential problems.
#'
#' There are four possibilities for an uninstalled package:
#'
#' * If it's used and recorded, call `renv::restore()` to install the version
#'   specified in the lockfile.
#' * If it's used and not recorded, call `renv::install()` to install it
#'   from CRAN or elsewhere.
#' * If it's not used and recorded, call `renv::snapshot()` to
#'   remove it from the lockfile.
#' * If it's not used and not recorded, there's nothing to do. This the most
#'   common state because you only use a small fraction of all available
#'   packages in any one project.
#'
#' If you have multiple packages in an inconsistent state, we recommend
#' `renv::restore()`, then `renv::install()`, then `renv::snapshot()`, but
#' that also suggests you should be running status more frequently.
#'
#' # Lockfile vs `dependencies()`
#'
#' Next we need to ensure that packages are recorded in the lockfile if and
#' only if they are used by the project. Fixing issues of this nature only
#' requires calling  `snapshot()` because there are four possibilities for
#' a package:
#'
#' * If it's used and recorded, it's ok.
#' * If it's used and not recorded, call `renv::snapshot()` to add it to the
#'   lockfile.
#' * If it's not used but is recorded, call `renv::snapshot()` to remove
#'   it from the lockfile.
#' * If it's not used and not recorded, it's also ok, as it may be a
#'   development dependency.
#'
#' # Out-of-sync sources
#'
#' The final issue to resolve is any inconsistencies between the version of
#' the package recorded in the lockfile and the version installed in your
#' library. To fix these issues you'll need to either call `renv::restore()`
#' or `renv::snapshot()`:
#'
#' * Call `renv::snapshot()` if your project code is working. This implies that
#'   the library is correct and you need to update your lockfile.
#' * Call `renv::restore()` if your project code isn't working. This probably
#'   implies that you have the wrong package versions installed and you need
#'   to restore from known good state in the lockfile.
#'
#' If you're not sure which case applies, it's generally safer to call
#' `renv::snapshot()`. If you want to rollback to an earlier known good
#' status, see [renv::history()] and [renv::revert()].
#'
#' @inherit renv-params
#'
#' @param library The library paths. By default, the library paths associated
#'   with the requested project are used.
#'
#' @param sources Boolean; check that each of the recorded packages have a
#'   known installation source? If a package has an unknown source, renv
#'   may be unable to restore it.
#'
#' @param cache Boolean; perform diagnostics on the global package cache?
#'   When `TRUE`, renv will validate that the packages installed into the
#'   cache are installed at the expected + proper locations, and validate the
#'   hashes used for those storage locations.
#'
#' @inheritParams dependencies
#'
#' @return This function is normally called for its side effects, but
#'   it invisibly returns a list containing the following components:
#'
#'   * `library`: packages in your library.
#'   * `lockfile`: packages in the lockfile.
#'   * `synchronized`: are the library and lockfile in sync?
#'
#' @export
#'
#' @example examples/examples-init.R
status <- function(project = NULL,
                   ...,
                   library = NULL,
                   lockfile = NULL,
                   sources = TRUE,
                   cache = FALSE,
                   dev = FALSE)
{
  renv_scope_error_handler()
  renv_dots_check(...)

  renv_snapshot_auto_suppress_next()
  renv_scope_options(renv.prompt.enabled = FALSE)

  the$status_running <- TRUE
  defer(the$status_running <- FALSE)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  # check to see if we've initialized this project
  if (!renv_status_check_initialized(project, library, lockfile)) {
    result <- list(
      library = list(Packages = named(list())),
      lockfile = list(Packages = named(list())),
      synchronized = FALSE
    )
    return(invisible(result))
  }

  libpaths <- library %||% renv_libpaths_resolve()
  lockpath <- lockfile %||% renv_paths_lockfile(project = project)

  # get all dependencies, including transitive
  dependencies <- renv_snapshot_dependencies(project, dev = dev)
  packages <- sort(union(dependencies, "renv"))
  paths <- renv_package_dependencies(packages, libpaths = libpaths, project = project)
  packages <- as.character(names(paths))

  # read project lockfile
  lockfile <- if (file.exists(lockpath))
    renv_lockfile_read(lockpath)
  else
    renv_lockfile_init(project = project)

  # get lockfile capturing current library state
  library <- renv_lockfile_create(
    libpaths = libpaths,
    type     = "all",
    prompt   = FALSE,
    project  = project
  )

  # remove ignored packages
  ignored <- c(
    renv_project_ignored_packages(project),
    renv_packages_base(),
    if (renv_tests_running()) "renv"
  )

  packages <- setdiff(packages, ignored)
  renv_lockfile_records(lockfile) <- exclude(renv_lockfile_records(lockfile), ignored)
  renv_lockfile_records(library) <- exclude(renv_lockfile_records(library), ignored)

  synchronized <-
    renv_status_check_consistent(lockfile, library, packages) &&
    renv_status_check_synchronized(lockfile, library)

  if (sources) {
    synchronized <- synchronized &&
      renv_status_check_unknown_sources(project, lockfile)
  }

  if (cache)
    renv_status_check_cache(project)

  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."))

  result <- list(
    library      = library,
    lockfile     = lockfile,
    synchronized = synchronized
  )

  invisible(result)

}

renv_status_check_unknown_sources <- function(project, lockfile) {
  renv_check_unknown_source(renv_lockfile_records(lockfile), project)
}

renv_status_check_consistent <- function(lockfile, library, used) {

  lockfile <- renv_lockfile_records(lockfile)
  library <- renv_lockfile_records(library)

  packages <- sort(unique(c(names(library), names(lockfile), used)))

  status <- data.frame(
    package = packages,
    installed = packages %in% names(library),
    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)
  }

  FALSE

}

renv_status_check_initialized <- function(project, library = NULL, lockfile = NULL) {

  # 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))
    return(TRUE)

  # resolve paths to lockfile, primary library path
  library  <- library  %||% renv_paths_library(project = project)
  lockfile <- lockfile %||% renv_paths_lockfile(project = project)

  # check whether the lockfile + library exist
  haslib  <- all(file.exists(library))
  haslock <- file.exists(lockfile)
  if (haslib && haslock)
    return(TRUE)

  # TODO: what about the case where the library exists but no packages are installed?
  # TODO: should this check for an 'renv/activate.R' script?
  # TODO: what if a different project is loaded?
  if (haslib && !haslock) {
    writef(c(
      "This project does not contain a lockfile.",
      "Use `renv::snapshot()` to create a lockfile."
    ))
  } else if (!haslib && haslock) {
    writef(c(
      "There are no packages installed in the project library.",
      "Use `renv::restore()` to install the packages defined in lockfile."
    ))
  } else {
    writef(c(
      "This project does not appear to be using renv.",
      "Use `renv::init()` to initialize the project."
    ))
  }

  FALSE

}

renv_status_check_synchronized <- function(lockfile, library) {

  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)) {
    return(TRUE)
  }

  pkgs <- names(actions[actions %in% rest])
  renv_pretty_print_records_pair(
    preamble = "The following package(s) are out of sync [lockfile -> library]:",
    lockfile[pkgs],
    library[pkgs],
  )

  FALSE

}

renv_status_check_cache <- function(project) {

  if (renv_cache_config_enabled(project = project))
    renv_cache_diagnose()

}



# system.R -------------------------------------------------------------------


renv_system_exec <- function(command,
                             args    = NULL,
                             action  = "executing command",
                             success = 0L,
                             stream  = FALSE,
                             quiet   = NULL)
{
  # be quiet when running tests by default
  quiet <- quiet %||% renv_tests_running()

  # handle 'stream' specially
  if (stream) {

    # form stdout, stderr
    stdout <- stderr <- if (quiet) FALSE else ""

    # execute command
    status <- suppressWarnings(
      if (is.null(args))
        system(command, ignore.stdout = quiet, ignore.stderr = quiet)
      else
        system2(command, args, stdout = stdout, stderr = stderr)
    )

    # check for error
    status <- status %||% 0L
    if (!is.null(success) && !status %in% success) {
      fmt <- "error %s [error code %i]"
      stopf(fmt, action, status)
    }

    # return status code
    return(status)

  }

  # suppress warnings as some successful commands may return a non-zero exit
  # code, whereas R will always warn on such error codes
  output <- suppressWarnings(
    if (is.null(args))
      system(command, intern = TRUE)
    else
      system2(command, args, stdout = TRUE, stderr = TRUE)
  )

  # extract status code from result
  status <- attr(output, "status") %||% 0L

  # if this status matches an expected 'success' code, return output
  if (is.null(success) || status %in% success)
    return(output)

  # otherwise, notify the user that things went wrong
  abort(
    sprintf("error %s [error code %i]", action, status),
    body = renv_system_exec_details(command, args, output)
  )

}

renv_system_exec_details <- function(command, args, output) {

  # get header, giving the command that was run
  cmdline <- paste(command, paste(args, collapse = " "))
  underline <- paste(rep.int("=", min(80L, nchar(cmdline))), collapse = "")
  header <- c(cmdline, underline)

  # truncate output (avoid overwhelming console)
  body <- if (length(output) > 200L)
    c(head(output, n = 100L), "< ... >", tail(output, n = 100L))
  else
    output

  c(header, "", body)

}


# tar.R ----------------------------------------------------------------------


renv_tar_exe <- function() {

  # allow override
  tar <- getOption("renv.tar.exe")
  if (!is.null(tar))
    return(tar)

  # on unix, just use default
  if (renv_platform_unix())
    return(Sys.which("tar"))

  # on Windows, use system tar.exe if available
  root <- Sys.getenv("SystemRoot", unset = NA)
  if (is.na(root))
    root <- "C:/Windows"

  # use tar if it exists
  tarpath <- file.path(root, "System32/tar.exe")
  if (file.exists(tarpath))
    return(tarpath)

  # otherwise, give up (don't trust the arbitrary tar on PATH)
  ""

}

renv_tar_decompress <- function(tar, archive, files = NULL, exdir = ".", ...) {

  # build argument list
  args <- c(
    "xf", renv_shell_path(archive),
    if (!identical(exdir, "."))
      c("-C", renv_shell_path(exdir)),
    if (length(files))
      renv_shell_path(files)
  )

  # make sure exdir exists
  ensure_directory(exdir)

  # perform decompress
  return(renv_system_exec(tar, args, action = "decompressing archive"))

}


# task.R ---------------------------------------------------------------------


renv_task_create <- function(callback, name = NULL) {

  # create name for task callback
  name <- name %||% as.character(substitute(callback))
  name <- paste("renv", name, sep = ":::")

  # remove an already-existing task of the same name
  removeTaskCallback(name)

  # otherwise, add our new task
  addTaskCallback(
    renv_task_callback(callback, name),
    name = name
  )

}

renv_task_callback <- function(callback, name) {

  force(callback)
  force(name)

  function(...) {

    status <- tryCatch(callback(), error = identity)
    if (inherits(status, "error")) {
      caution("Error in background task '%s': %s", name, conditionMessage(status))
      caution("Background task '%s' will be stopped.", name)
      return(FALSE)
    }

    TRUE

  }

}

renv_task_unload <- function() {
  callbacks <- getTaskCallbackNames()
  for (callback in callbacks)
    for (prefix in c("renv_", "renv:::"))
      if (startswith(callback, prefix))
        removeTaskCallback(callback)
}


# template.R -----------------------------------------------------------------


renv_template_create <- function(template) {
  gsub("^\\n+|\\n+$", "", template)
}

renv_template_replace <- function(text, replacements, format = "${%s}") {

  enumerate(replacements, function(key, value) {
    key <- sprintf(format, key)
    text <<- gsub(key, value, text, fixed = TRUE)
  })

  text

}


# tests.R --------------------------------------------------------------------


the$tests_root <- NULL

# NOTE: Prefer using 'testing()' to 'renv_tests_running()' for behavior
# that should apply regardless of the package currently being tested.
#
# renv_tests_running() is appropriate when running renv's own tests.
renv_tests_running <- function() {
  getOption("renv.tests.running", default = FALSE)
}

renv_test_code <- function(code, data = list(), fileext = ".R", scope = parent.frame()) {
  code <- do.call(substitute, list(substitute(code), data))
  file <- renv_scope_tempfile("renv-code-", fileext = fileext, scope = scope)

  writeLines(deparse(code), con = file)
  file
}

renv_test_retrieve <- function(record) {

  renv_scope_error_handler()

  # avoid using cache
  cache <- renv_scope_tempfile()
  renv_scope_envvars(RENV_PATHS_CACHE = cache)

  # construct records
  package <- record$Package
  records <- list(record)
  names(records) <- package

  # prepare dummy library
  templib <- renv_scope_tempfile("renv-library-")
  ensure_directory(templib)
  renv_scope_libpaths(c(templib, .libPaths()))

  # attempt a restore into that library
  renv_scope_restore(
    project = getwd(),
    library = templib,
    records = records,
    packages = package,
    recursive = TRUE
  )

  records <- retrieve(record$Package)
  renv_install_impl(records)

  descpath <- file.path(templib, package)
  if (!file.exists(descpath))
    stopf("failed to retrieve package '%s'", package)

  desc <- renv_description_read(descpath)
  fields <- grep("^Remote", names(record), value = TRUE)

  testthat::expect_identical(
    as.list(desc[fields]),
    as.list(record[fields])
  )

}

renv_tests_diagnostics <- function() {

  # print library paths
  caution_bullets(
    "The following R libraries are set:",
    paste("-", .libPaths())
  )

  # print repositories
  repos <- getOption("repos")
  caution_bullets(
    "The following repositories are set:",
    paste(names(repos), repos, sep = ": ")
  )

  # print renv root
  caution_bullets(
    "The following renv root directory is being used:",
    paste("-", paths$root())
  )

  # print cache root
  caution_bullets(
    "The following renv cache directory is being used:",
    paste("-", paths$cache())
  )

  writeLines("The following packages are available in the test repositories:")

  dbs <-
    available_packages(type = "source", quiet = TRUE) %>%
    map(function(db) {
      rownames(db) <- NULL
      db[c("Package", "Version", "File")]
    })

  print(dbs)

  path <- Sys.getenv("PATH")
  splat <- strsplit(path, .Platform$path.sep, fixed = TRUE)[[1]]

  caution_bullets(
    "The following PATH is set:",
    paste("-", splat)
  )

  envvars <- c(
    grep("^_R_", names(Sys.getenv()), value = TRUE),
    "HOME",
    "R_ARCH", "R_HOME",
    "R_LIBS", "R_LIBS_SITE", "R_LIBS_USER", "R_USER",
    "R_ZIPCMD",
    "TAR", "TEMP", "TMP", "TMPDIR"
  )

  keys <- format(envvars)
  vals <- Sys.getenv(envvars, unset = "<NA>")
  vals[vals != "<NA>"] <- renv_json_quote(vals[vals != "<NA>"])

  caution_bullets(
    "The following environment variables of interest are set:",
    paste(keys, vals, sep = " : ")
  )

}

renv_tests_root <- function() {
  the$tests_root <- the$tests_root %||% {
    renv_path_normalize(testthat::test_path("."))
  }
}

renv_tests_path <- function(path = NULL) {

  # special case for NULL path
  if (is.null(path))
    return(renv_tests_root())

  # otherwise, form path from root
  file.path(renv_tests_root(), path)

}

renv_tests_supported <- function() {

  # supported when running locally + on CI
  for (envvar in c("NOT_CRAN", "CI"))
    if (renv_envvar_exists(envvar))
      return(TRUE)

  # disabled on older macOS releases (credentials fails to load)
  if (renv_platform_macos() && getRversion() < "4.0.0")
    return(FALSE)

  # disabled on Windows
  if (renv_platform_windows())
    return(FALSE)

  # true otherwise
  TRUE

}


# testthat-helpers.R ---------------------------------------------------------


expect_same_elements <- function(lhs, rhs) {

  if (!requireNamespace("testthat", quietly = TRUE))
    stop("testthat not available for testing")

  if (is.list(lhs) && is.list(rhs)) {
    lhs <- lhs[order(names(lhs))]
    rhs <- rhs[order(names(rhs))]
    return(testthat::expect_equal(!!lhs, !!rhs))
  }

  if (packageVersion("testthat") > "2.2.0")
    testthat::expect_setequal(!!lhs, !!rhs)
  else
    testthat::expect_setequal(lhs, rhs)

}


# truthy.R -------------------------------------------------------------------


truthy <- function(value, default = FALSE) {

  # https://github.com/rstudio/renv/issues/1558
  if (is.call(value)) {
    value <- tryCatch(renv_dependencies_eval(value), error = identity)
    if (inherits(value, "error"))
      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")
  else if (is.na(value))
    default
  else
    as.logical(value)
}


# type.R ---------------------------------------------------------------------


renv_type_check <- function(value, type) {

  # quietly convert NAs to requested type
  if (is.null(value) || is.na(value))
    return(convert(value, type))

  # if the value already matches the expected type, return success
  if (inherits(value, type))
    return(value)

  # create error object
  fmt <- "parameter '%s' is not of expected type '%s'"
  msg <- sprintf(fmt, deparse(substitute(value)), type)
  error <- simpleError(msg, sys.call(sys.parent()))

  # report error
  stop(error)

}

renv_type_unexpected <- function(value) {
  fmt <- "parameter '%s' has unexpected type '%s'"
  msg <- sprintf(fmt, deparse(substitute(value)), typeof(value))
  error <- simpleError(msg, sys.call(sys.parent()))
  stop(error)
}


# unload.R -------------------------------------------------------------------


unload <- function(project = NULL, quiet = FALSE) {

  project <- renv_project_resolve(project)
  renv_scope_error_handler()

  if (renv_tests_running())
    return()

  if (quiet)
    renv_scope_options(renv.verbose = FALSE)

  renv_envvars_restore()

  renv_unload_shims(project)
  renv_unload_project(project)
  renv_unload_profile(project)
  renv_unload_envvars(project)
  renv_unload_sandbox(project)
  renv_unload_libpaths(project)

}

renv_unload_shims <- function(project) {
  renv_shims_deactivate()
}

renv_unload_project <- function(project) {
  renv_project_clear()
}

renv_unload_profile <- function(project) {
  Sys.unsetenv("RENV_PROFILE")
}

renv_unload_envvars <- function(project) {
  renv_envvars_restore()
}

renv_unload_sandbox <- function(project) {
  renv_sandbox_deactivate()
}

renv_unload_libpaths <- function(project) {
  renv_libpaths_restore()
}

renv_unload_finalizer <- function(libpath) {
  libpath <- dirname(renv_namespace_path(.packageName))
  .onUnload(libpath)
}


# update.R -------------------------------------------------------------------


the$update_errors <- new.env(parent = emptyenv())

renv_update_find_repos <- function(records) {

  results <- lapply(records, function(record) {
    catch(renv_update_find_repos_impl(record))
  })

  failed <- map_lgl(results, inherits, "error")
  if (any(failed))
    renv_update_errors_set("repos", results[failed])

  results[!failed]

}

renv_update_find_repos_impl <- function(record) {

  # retrieve latest-available package
  package <- record$Package
  latest <- catch(renv_available_packages_latest(package))
  if (inherits(latest, "error"))
    return(NULL)

  # validate our versions
  if (empty(latest$Version) || empty(record$Version))
    return(NULL)

  # compare the versions; return NULL if the 'latest' version
  # is older
  compare <- renv_version_compare(latest$Version, record$Version)
  if (compare != 1L)
    return(NULL)

  latest

}

renv_update_find_git <- function(records) {
  renv_parallel_exec(records, renv_update_find_git_impl)
}

renv_update_find_git_impl <- function(record) {

  sha <- renv_remotes_resolve_git_sha_ref(record)

  # if sha is empty:
  # `git remote-ls origin ref` expects ref to be a reference, not a sha
  # it is empty if ref isn't a reference on the repo
  # this may be due to record$RemoteRef actually being a sha
  # or it may be because record$RemoteRef is not a real ref
  # but we can't check, so we will try to fetch the ref & see what we get
  oldsha <- record$RemoteSha %||% ""
  if (nzchar(oldsha) && identical(sha, oldsha))
    return(NULL)

  current <- record
  current$RemoteSha <- sha

  desc <- renv_remotes_resolve_git_description(current)

  current$Version <- desc$Version
  current$Package <- desc$Package

  updated <- renv_version_ge(current$Version, record$Version)
  if (updated)
    return(current)

}

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))
  })

  failed <- map_lgl(results, inherits, "error")
  if (any(failed))
    renv_update_errors_set("github", results[failed])

  results[!failed]

}

renv_update_find_github_impl <- function(record) {

  # construct and parse record entry
  host   <- record$RemoteHost %||% config$github.host()
  user   <- record$RemoteUsername
  repo   <- record$RemoteRepo
  subdir <- record$RemoteSubdir
  ref    <- record$RemoteRef

  # check for changed sha
  sha <- renv_remotes_resolve_github_sha_ref(host, user, repo, ref)
  if (sha == record$RemoteSha)
    return(NULL)

  # get updated record
  desc <- renv_remotes_resolve_github_description(host, user, repo, subdir, sha)
  current <- list(
    Package        = desc$Package,
    Version        = desc$Version,
    Source         = "GitHub",
    RemoteUsername = user,
    RemoteRepo     = repo,
    RemoteSubdir   = subdir,
    RemoteRef      = ref,
    RemoteSha      = sha,
    RemoteHost     = host
  )

  # check that the version has actually updated
  updated <-
    current$RemoteSha != record$RemoteSha &&
    numeric_version(current$Version) >= numeric_version(record$Version)

  if (updated)
    return(current)

}


renv_update_find_remote <- function(records, type) {

  update <- switch(type,
    "gitlab" = renv_remotes_resolve_gitlab,
    "bitbucket" = renv_remotes_resolve_bitbucket,
    stopf("Unsupported type %s", type)
  )

  names(records) <- map_chr(records, `[[`, "Package")
  results <- renv_parallel_exec(records, function(record) {
    catch(renv_update_find_remote_impl(record, update))
  })

  failed <- map_lgl(results, inherits, "error")
  if (any(failed))
    renv_update_errors_set(type, results[failed])

  results[!failed]

}

renv_update_find_remote_impl <- function(record, update) {

  remote <- list(
    host = record$RemoteHost,
    user = record$RemoteUsername,
    repo = record$RemoteRepo,
    ref = record$RemoteRef
  )
  current <- update(remote)

  # check that the version has actually updated
  updated <-
    current$RemoteSha != record$RemoteSha &&
    numeric_version(current$Version) >= numeric_version(record$Version)

  if (updated)
    return(current)

}


renv_update_find <- function(records) {

  sources <- extract_chr(records, "Source")
  grouped <- split(records, sources)

  # retrieve updates
  results <- enumerate(grouped, function(source, records) {
    case(
      source == "Bioconductor" ~ renv_update_find_repos(records),
      source == "Repository"   ~ renv_update_find_repos(records),
      source == "GitHub"       ~ renv_update_find_github(records),
      source == "Git"          ~ renv_update_find_git(records),
      source == "GitLab"       ~ renv_update_find_remote(records, "gitlab"),
      source == "Bitbucket"    ~ renv_update_find_remote(records, "bitbucket")
    )
  })

  # remove groupings
  ungrouped <- unlist(results, recursive = FALSE, use.names = FALSE)
  if (empty(ungrouped))
    return(list())

  # keep non-null results
  updates <- Filter(Negate(is.null), ungrouped)
  if (empty(updates))
    return(list())

  names(updates) <- extract_chr(updates, "Package")
  renv_records_sort(updates)

}



#' Update packages
#'
#' @description
#' Update packages which are currently out-of-date. Currently supports CRAN,
#' Bioconductor, other CRAN-like repositories, GitHub, GitLab, Git, and
#' BitBucket.
#'
#' Updates will only be checked from the same source -- for example,
#' if a package was installed from GitHub, but a newer version is
#' available on CRAN, that updated version will not be seen.
#'
#' @inherit renv-params
#'
#' @param packages A character vector of \R packages to update. When `NULL`
#'   (the default), all packages (apart from any listed in the `ignored.packages`
#'   project setting) will be updated.
#'
#' @param check Boolean; check for package updates without actually
#'   installing available updates? This is useful when you'd like to determine
#'   what updates are available, without actually installing those updates.
#'
#' @param exclude A set of packages to explicitly exclude from updating.
#'   Use `renv::update(exclude = <...>)` to update all packages except for
#'   a specific set of excluded packages.
#'
#' @return A named list of package records which were installed by renv.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # update the 'dplyr' package
#' renv::update("dplyr")
#'
#' }
update <- function(packages = NULL,
                   ...,
                   exclude = NULL,
                   library = NULL,
                   rebuild = FALSE,
                   check   = FALSE,
                   prompt  = interactive(),
                   project = NULL)
{
  renv_consent_check()
  renv_scope_error_handler()
  renv_dots_check(...)

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)
  renv_scope_verbose_if(prompt)

  # resolve library path
  libpaths <- renv_libpaths_resolve(library)
  library <- nth(libpaths, 1L)
  renv_scope_libpaths(libpaths)

  # resolve exclusions
  exclude <- c(exclude, settings$ignored.packages(project = project))

  # if users have requested the use of pak, delegate there
  if (config$pak.enabled() && !recursing()) {
    packages <- setdiff(packages, exclude)
    renv_pak_init()
    return(renv_pak_install(packages, libpaths, project))
  }

  # get package records
  renv_scope_binding(the, "snapshot_hash", FALSE)
  records <- renv_snapshot_libpaths(libpaths = libpaths, project = project)
  packages <- packages %||% names(records)

  # apply exclusions
  packages <- setdiff(packages, exclude)

  # check if the user has requested update for packages not installed
  missing <- renv_vector_diff(packages, names(records))
  if (!empty(missing)) {

    if (prompt || renv_verbose()) {
      caution_bullets(
        "The following package(s) are not currently installed:",
        missing,
        "The latest available versions of these packages will be installed instead."
      )
    }

    cancel_if(prompt && !proceed())

  }

  # select records
  selected <- c(
    records[renv_vector_intersect(packages, names(records))],
    named(lapply(missing, renv_available_packages_latest), missing)
  )

  # check for usage of cran, bioc
  repo <- FALSE
  bioc <- FALSE

  for (record in selected) {

    source <- renv_record_source(record, normalize = TRUE)

    if (source %in% c("repository")) {
      repo <- TRUE
      next
    }

    if (source %in% c("bioconductor")) {
      repo <- bioc <- TRUE
      next
    }

  }

  # activate bioc repositories if needed
  if (bioc)
    renv_scope_bioconductor(project = project)

  # ensure database of available packages is current
  if (repo) {
    for (type in renv_package_pkgtypes()) {
      available_packages(type = type)
    }
  }

  printf("- Checking for updated packages ... ")

  # remove records that appear to be from an R package repository,
  # but are not actually available in the current repositories
  selected <- filter(selected, function(record) {

    source <- renv_record_source(record, normalize = TRUE)
    if (!source %in% c("bioconductor", "cran", "repository"))
      return(TRUE)

    # check for available package
    package <- record$Package
    entry <- catch(renv_available_packages_latest(package))
    !inherits(entry, "error")

  })

  updates <- renv_update_find(selected)
  writef("Done!")

  renv_update_errors_emit()

  if (empty(updates)) {
    writef("- All packages appear to be up-to-date.")
    return(invisible(TRUE))
  }

  # perform a diff (for reporting to user)
  old <- selected[names(updates)]
  new <- updates
  diff <- renv_lockfile_diff_packages(old, new)

  # if we're only checking for updates, just report and exit
  if (check) {

    fmt <- case(
      length(diff) == 1 ~ "- %i package has updates available.",
      length(diff) != 1 ~ "- %i packages have updates available."
    )

    preamble <- sprintf(fmt, length(diff))
    renv_updates_report(preamble, diff, old, new)
    return(invisible(renv_updates_create(diff, old, new)))

  }

  if (prompt || renv_verbose()) {
    renv_restore_report_actions(diff, old, new)
    cancel_if(prompt && !proceed())
  }

  # perform the install
  install(
    packages = updates,
    library  = libpaths,
    rebuild  = rebuild,
    prompt   = prompt,
    project  = project
  )

}

renv_update_errors_set <- function(key, errors) {
  assign(key, errors, envir = the$update_errors)
}

renv_update_errors_clear <- function() {
  rm(
    list = ls(envir = the$update_errors, all.names = TRUE),
    envir = the$update_errors
  )
}

renv_update_errors_emit <- function() {

  # clear errors when we're done
  defer(renv_update_errors_clear())

  # if we have any errors, start by emitting a single newline
  all <- ls(envir = the$update_errors, all.names = TRUE)
  if (!empty(all))
    writef()

  # then emit errors for each class
  renv_update_errors_emit_repos()
  renv_update_errors_emit_remote("github", "GitHub")
  renv_update_errors_emit_remote("gitlab", "GitLab")
  renv_update_errors_emit_remote("bitbucket", "BitBucket")

}

renv_update_errors_emit_impl <- function(key, preamble, postamble) {

  errors <- the$update_errors[[key]]
  if (empty(errors))
    return()

  messages <- enumerate(errors, function(package, error) {
    errmsg <- paste(conditionMessage(error), collapse = "; ")
    sprintf("%s: %s", format(package), errmsg)
  })

  caution_bullets(
    preamble = preamble,
    values = messages,
    postamble = postamble
  )

}

renv_update_errors_emit_repos <- function() {

  renv_update_errors_emit_impl(
    key       = "repos",
    preamble  = "One or more errors occurred while finding updates for the following packages:",
    postamble = "Ensure that these packages are available from your active package repositories."
  )

}

renv_update_errors_emit_remote <- function(key, label) {

  renv_update_errors_emit_impl(
    key       = key,
    preamble  = sprintf("One or more errors occurred while finding updates for the following %s packages:", label),
    postamble = sprintf("Ensure that these packages were installed from an accessible %s remote.", label)
  )

}



# updates.R ------------------------------------------------------------------


renv_updates_create <- function(diff, old, new) {
  structure(
    list(diff = diff, old = old, new = new),
    class = "renv_updates"
  )
}

renv_updates_report <- function(preamble, diff, old, new) {

  lhs <- renv_lockfile_records(old)
  rhs <- renv_lockfile_records(new)
  renv_pretty_print_records_pair(
    preamble,
    lhs[names(lhs) %in% names(diff)],
    rhs[names(rhs) %in% names(diff)]
  )

}


# upgrade.R ------------------------------------------------------------------


#' Upgrade renv
#'
#' @description
#' Upgrade the version of renv associated with a project, including using
#' a development version from GitHub. Automatically snapshots the update
#' 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()].
#'
#' @inherit renv-params
#'
#' @param version The version of renv to be installed.
#'
#'   When `NULL` (the default), the latest version of renv will be installed as
#'   available from CRAN (or whatever active package repositories are active)
#'   Alternatively, you can install the latest development version with
#'  `"main"`, or a specific commit with a SHA, e.g. `"5049cef8a"`.
#'
#' @param prompt Boolean; prompt upgrade before proceeding?
#'
#' @param reload Boolean; reload renv after install? When `NULL` (the
#'   default), renv will be re-loaded only if updating renv for the
#'   active project. Since it's not possible to guarantee a clean reload
#'   in the current session, this will attempt to restart your R session.
#'
#' @return A boolean value, indicating whether the requested version of
#'   renv was successfully installed. Note that this function is normally
#'   called for its side effects.
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # upgrade to the latest version of renv
#' renv::upgrade()
#'
#' # upgrade to the latest version of renv on GitHub (development version)
#' renv::upgrade(version = "main")
#'
#' }
upgrade <- function(project = NULL,
                    version = NULL,
                    reload  = NULL,
                    prompt = interactive())
{
  renv_scope_error_handler()
  renv_scope_verbose_if(prompt)
  invisible(renv_upgrade_impl(project, version, reload, prompt))
}

renv_upgrade_impl <- function(project, version, reload, prompt) {

  project <- renv_project_resolve(project)
  renv_project_lock(project = project)

  reload <- reload %||% renv_project_loaded(project)

  lockfile <- renv_lockfile_load(project)
  old <- lockfile$Packages$renv
  new <- renv_upgrade_find_record(version)

  # check for some form of change
  if (renv_records_equal(old, new)) {
    fmt <- "- renv [%s] is already installed and active for this project."
    writef(fmt, renv_metadata_version_friendly())
    return(FALSE)
  }

  if (prompt || renv_verbose()) {
    renv_pretty_print_records_pair(
      "A new version of the renv package will be installed:",
      list(renv = old),
      list(renv = new),
      "This project will use the newly-installed version of renv."
    )
  }

  cancel_if(prompt && !proceed())

  renv_scope_restore(
    project   = project,
    library   = renv_libpaths_active(),
    records   = list(renv = new),
    packages  = "renv",
    recursive = FALSE
  )

  # retrieve and install renv
  records <- retrieve("renv")
  renv_install_impl(records)

  # update the lockfile
  lockfile <- renv_lockfile_load(project = project)
  records <- renv_lockfile_records(lockfile) %||% list()
  records$renv <- new
  renv_lockfile_records(lockfile) <- records
  renv_lockfile_save(lockfile, project = project)

  # now update the infrastructure to use this version of renv.
  # do this in a separate process to avoid issues that could arise
  # if the old version of renv is still loaded
  #
  # https://github.com/rstudio/renv/issues/1546
  writef("- Updating activate script")
  code <- substitute({
    renv <- asNamespace("renv"); renv$summon()
    version <- renv_metadata_version_create(record)
    renv_infrastructure_write(project, version = version)
  }, list(project = project, record = records[["renv"]]))

  script <- renv_scope_tempfile("renv-activate-", fileext = ".R")
  writeLines(deparse(code), con = script)

  args <- c("--vanilla", "-s", "-f", renv_shell_path(script))
  r(args, stdout = FALSE, stderr = FALSE)

  if (reload) {
    renv_restart_request(project)
  }

  invisible(TRUE)

}

renv_upgrade_find_record <- function(version) {

  if (is.null(version))
    renv_upgrade_find_record_default()
  else
    renv_upgrade_find_record_dev(version)

}

renv_upgrade_find_record_default <- function() {

  # check if the package is available on R repositories.
  # if not, prefer GitHub
  record <- catch(renv_available_packages_latest("renv"))
  if (inherits(record, "error"))
    return(renv_upgrade_find_record_dev())

  # check the version reported by R repositories.
  # if it's older than current renv, then prefer GitHub
  version <- record$Version
  if (package_version(version) < renv_package_version("renv"))
    return(renv_upgrade_find_record_dev())

  # ok -- install from repository
  record

}

renv_upgrade_find_record_dev <- function(version = NULL) {
  version <- version %||% renv_upgrade_find_record_dev_latest()
  entry <- paste("rstudio/renv", version, sep = "@")
  renv_remotes_resolve(entry)
}


renv_upgrade_find_record_dev_latest <- function() {

  # download tags
  url <- "https://api.github.com/repos/rstudio/renv/tags"
  destfile <- tempfile("renv-tags-", fileext = ".json")
  download(url, destfile = destfile, quiet = TRUE)
  json <- renv_json_read(destfile)

  # find latest version
  names <- extract_chr(json, "name")
  versions <- numeric_version(names, strict = FALSE)
  latest <- sort(versions, decreasing = TRUE)[[1]]
  names[versions %in% latest][[1L]]

}

renv_upgrade_reload <- function() {

  # we need to remove the task callbacks here, as otherwise
  # we'll run into trouble trying to remove task callbacks
  # within a task callback
  renv_task_unload()

  # now define and add a callback to reload renv; use the base namespace
  # to avoid carrying along any bits of the current renv environment
  callback <- function(...) {
    unloadNamespace("renv")
    loadNamespace("renv")
    invisible(FALSE)
  }

  environment(callback) <- baseenv()

  # add the task callback; don't name it so that the renv infrastructure
  # doesn't try to remove this callback (it'll resolve and remove itself)
  addTaskCallback(callback)

  invisible(TRUE)

}


# url.R ----------------------------------------------------------------------


renv_url_parse <- function(url) {

  pattern <- paste0(
    "^",
    "([^:]+://)?",        # protocol
    "([^/?#]+)",          # domain
    "(?:(/[^?#]*))?",     # path
    "(?:[?]([^#]+))?",    # parameters
    "(?:#(.*))?",         # fragment
    ""
  )

  matches <- regmatches(url, regexec(pattern, url, perl = TRUE))[[1L]]
  if (length(matches) != 6L)
    stopf("couldn't parse url '%s'", url)

  matches <- as.list(matches)
  names(matches) <- c("url", "protocol", "domain", "path", "parameters", "fragment")

  # parse parameters into named list
  matches$parameters <- renv_properties_read(
    text = chartr("&", "\n", matches$parameters),
    delimiter = "=",
    dequote = FALSE,
    trim = FALSE
  )

  # return parsed URL
  matches

}



# use-python.R ---------------------------------------------------------------


#' Use python
#'
#' Associate a version of Python with your project.
#'
#' When Python integration is active, renv will:
#'
#' - Save metadata about the requested version of Python in `renv.lock` -- in
#'   particular, the Python version, and the Python type ("virtualenv", "conda",
#'   "system"),
#'
#' - Capture the set of installed Python packages during `renv::snapshot()`,
#'
#' - Re-install the set of recorded Python packages during `renv::restore()`.
#'
#' In addition, when the project is loaded, the following actions will be taken:
#'
#' - The `RENV_PYTHON` environment variable will be set, indicating the version
#'   of Python currently active for this sessions,
#'
#' - The `RETICULATE_PYTHON` environment variable will be set, so that the
#'   reticulate package can automatically use the requested copy of Python
#'   as appropriate,
#'
#' - The requested version of Python will be placed on the `PATH`, so that
#'   attempts to invoke Python will resolve to the expected version of Python.
#'
#' You can override the version of Python used in a particular project by
#' setting the `RENV_PYTHON` environment variable; e.g. as part of the
#' project's `.Renviron` file. This can be useful if you find that renv
#' is unable to automatically discover a compatible version of Python to
#' be used in the project.
#'
#' @inherit renv-params
#'
#' @param ... Optional arguments; currently unused.
#'
#' @param python
#'   The path to the version of Python to be used with this project. See
#'   **Finding Python** for more details.
#'
#' @param type
#'   The type of Python environment to use. When `"auto"` (the default),
#'   virtual environments will be used.
#'
#' @param name
#'   The name or path that should be used for the associated Python environment.
#'   If `NULL` and `python` points to a Python executable living within a
#'   pre-existing virtual environment, that environment will be used. Otherwise,
#'   a project-local environment will be created instead, using a name
#'   generated from the associated version of Python.
#'
#' @details
#' # Finding Python
#'
#' In interactive sessions, when `python = NULL`, renv will prompt for an
#' appropriate version of Python. renv will search a pre-defined set of
#' locations when attempting to find Python installations on the system:
#'
#' - `getOption("renv.python.root")`,
#' - `/opt/python`,
#' - `/opt/local/python`,
#' - `~/opt/python`,
#' - `/usr/local/opt` (for macOS Homebrew-installed copies of Python),
#' - `/opt/homebrew/opt` (for M1 macOS Homebrew-installed copies of Python),
#' - `~/.pyenv/versions`,
#' - Python instances available on the `PATH`.
#'
#' In non-interactive sessions, renv will first check the `RETICULATE_PYTHON`
#' environment variable; if that is unset, renv will look for Python on the
#' `PATH`. It is recommended that the version of Python to be used is explicitly
#' supplied for non-interactive usages of `use_python()`.
#'
#'
#' # Warning
#'
#' We strongly recommend using Python virtual environments, for a few reasons:
#'
#' 1. If something goes wrong with a local virtual environment, you can safely
#'    delete that virtual environment, and then re-initialize it later, without
#'    worry that doing so might impact other software on your system.
#'
#' 2. If you choose to use a "system" installation of Python, then any packages
#'    you install or upgrade will be visible to any other application that
#'    wants to use that same Python installation. Using a virtual environment
#'    ensures that any changes made are isolated to that environment only.
#'
#' 3. Choosing to use Anaconda will likely invite extra frustration in the
#'    future, as you may be required to upgrade and manage your Anaconda
#'    installation as new versions of Anaconda are released. In addition,
#'    Anaconda installations tend to work poorly with software not specifically
#'    installed as part of that same Anaconda installation.
#'
#' In other words, we recommend selecting "system" or "conda" only if you are an
#' expert Python user who is already accustomed to managing Python / Anaconda
#' installations on your own.
#'
#'
#' @return
#'   `TRUE`, indicating that the requested version of Python has been
#'   successfully activated. Note that this function is normally called for its
#'   side effects.
#'
#'
#' @export
#'
#' @examples
#' \dontrun{
#'
#' # use python with a project
#' renv::use_python()
#'
#' # use python with a project; create the environment
#' # within the project directory in the '.venv' folder
#' renv::use_python(name = ".venv")
#'
#' # use python with a pre-existing virtual environment located elsewhere
#' renv::use_python(name = "~/.virtualenvs/env")
#'
#' # use virtualenv python with a project
#' renv::use_python(type = "virtualenv")
#'
#' # use conda python with a project
#' renv::use_python(type = "conda")
#'
#' }
use_python <- function(python = NULL,
                       ...,
                       type = c("auto", "virtualenv", "conda", "system"),
                       name    = NULL,
                       project = NULL)
{
  renv_scope_error_handler()
  renv_dots_check(...)
  project <- renv_project_resolve(project)

  # deactivate python integration when FALSE
  if (identical(python, FALSE))
    return(renv_python_deactivate(project))

  # handle 'auto' type
  type <- match.arg(type)
  if (identical(type, "auto"))
    type <- "virtualenv"

  case(
    type == "system"     ~ renv_use_python_system(python, name, project),
    type == "virtualenv" ~ renv_use_python_virtualenv(python, name, project),
    type == "conda"      ~ renv_use_python_condaenv(python, name, project)
  )
}

renv_use_python_system <- function(python,
                                   name,
                                   project)
{
  # retrieve python information
  python <- renv_python_resolve(python)
  version <- renv_python_version(python)
  info <- renv_python_info(python)

  # if the user ended up selecting a virtualenv or conda python, then
  # just activate those and ignore the 'system' request
  if (identical(info$type, "virtualenv"))
    return(renv_use_python_virtualenv(info$python, name, project))
  if (identical(info$type, "conda"))
    return(renv_use_python_condaenv(info$python, name, project))

  # for 'system' python usages, we just use the path to python
  # (note that this may not be portable or useful for other machines)
  renv_use_python_fini(info, python, version, project)
}

renv_use_python_virtualenv <- function(python,
                                       name,
                                       project)
{
  # if name has been set, check and see if it refers to an already-existing
  # virtual environment; if that exists, use it
  if (is.null(python) && !is.null(name)) {
    path <- renv_python_virtualenv_path(name)
    if (file.exists(path))
      python <- renv_python_exe(name)
  }

  python  <- renv_python_resolve(python)
  version <- renv_python_version(python)
  info    <- renv_python_info(python)

  # if name is unset, and 'python' doesn't already refer to an existing
  # virtual environment, then we'll use a local virtual environment
  local <- is.null(name) && identical(info$type, "virtualenv")
  if (local) {
    name <- renv_path_aliased(info$root)
    if (renv_path_same(dirname(name), renv_python_virtualenv_home()))
      name <- basename(name)
  } else {
    name <- name %||% renv_python_envpath(project, "virtualenv", version)
    if (grepl("/", name, fixed = TRUE))
      name <- renv_path_canonicalize(name)
  }

  # now, check to see if the python environment exists;
  # if it does not exist, we'll create it now
  vpython <- renv_use_python_virtualenv_impl(project, name, version, python)
  vinfo <- renv_python_info(vpython)

  # finish up now
  renv_use_python_fini(vinfo, name, version, project)

}

renv_use_python_condaenv <- function(python,
                                     name,
                                     project)
{
  # if python is set, see if it's already the path to a python interpreter
  # living within a conda environment
  while (!is.null(python)) {

    if (!is.null(name)) {
      fmt <- "ignoring value of name %s as python was already set"
      warningf(fmt, renv_path_pretty(name))
    }

    # validate that this is a conda python
    info <- renv_python_info(python)
    if (!identical(info$type, "conda")) {
      fmt <- "%s does not appear to refer to a Conda instance of Python; ignoring"
      warningf(fmt, renv_path_pretty(python))
      break
    }

    # use this edition of python without further adieu
    version <- renv_python_version(python)
    return(renv_use_python_fini(info, name, version, project))

  }

  # TODO: how do we select which version of python we want to use?
  name <- name %||% renv_python_envpath(project, "conda")
  python <- renv_use_python_condaenv_impl(project, name)
  info <- renv_python_info(python)
  version <- renv_python_version(python)

  renv_use_python_fini(info, name, version, project)

}

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))

  if (!is.null(name) && 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
  fields <- as.list(c(Version = version, Type = info$type, Name = name))

  # update the lockfile
  lockfile <- renv_lockfile_load(project)
  if (!identical(fields, lockfile$Python)) {
    lockfile$Python <- fields
    renv_lockfile_save(lockfile, project)
  }

  # re-initialize with these settings
  renv_load_python(project, fields)

  # notify user
  if (!renv_tests_running()) {
    if (is.null(info$type)) {
      fmt <- "- Activated Python %s (%s)."
      writef(fmt, version, renv_path_aliased(info$python))
    } else {
      fmt <- "- Activated Python %s [%s; %s]"
      writef(fmt, version, info$type, renv_path_aliased(name))
    }
  }

  # report to user
  setwd(project)
  activate(project = project)

  invisible(info$python)

}

# return the path to an existing python binary associated with the virtual
# environment having name 'name' and version 'version', or "" if no such
# python instance exists
renv_use_python_virtualenv_impl_existing <- function(project,
                                                     name = NULL,
                                                     version = NULL)
{
  # resolve environment path from name
  name <- name %||% renv_python_envpath(project, "virtualenv", version)
  path <- renv_python_virtualenv_path(name)
  if (!file.exists(path))
    return("")

  # check that this appears to have a valid python executable
  info <- catch(renv_python_info(path))
  if (inherits(info, "error")) {
    warning(info)
    return("")
  }

  # validate version and return
  renv_python_virtualenv_validate(path, version)
}

# Internal helper for activating a Python virtual environment
#
# @param project
#   The project directory.
#
# @param name
#   The environment name, if any. If unset, it should be constructed
#   based on the Python executable used (note: _not_ the version parameter)
#
# @param version
#   The _requested_ version of Python (which may not be the actual version!)
#   This version should be used as a hint for finding an appropriate version
#   of Python, if the environment needs to be re-created.
#
# @param python
#   The copy of Python to be used. When unset, an appropriate version of Python
#   should be discovered based on the `version` parameter.
#
# @return
#   The path to the Python binary in the associated virtual environment.
#
renv_use_python_virtualenv_impl <- function(project,
                                            name = NULL,
                                            version = NULL,
                                            python = NULL)
{
  # first, look for an already-existing python installation
  # associated with the requested version of python
  exe <- renv_use_python_virtualenv_impl_existing(project, name, version)
  if (file.exists(exe))
    return(exe)

  # couldn't resolve environment from requested version; try to find
  # a compatible version of python and re-create that environment
  python <- python %||% renv_python_find(version)
  pyversion <- renv_python_version(python)
  name <- name %||% renv_python_envpath(project, "virtualenv", pyversion)
  path <- renv_python_virtualenv_path(name)

  # if the environment already exists, but is associated with a different
  # version of Python, prompt the user to re-create that environment
  if (file.exists(path)) {
    exe <- renv_python_virtualenv_validate(path, version)
    if (file.exists(exe))
      return(exe)
  }

  printf("- Creating virtual environment '%s' ... ", basename(name))
  vpython <- renv_python_virtualenv_create(python, path)
  writef("Done!")

  printf("- Updating Python packages ... ")
  renv_python_virtualenv_update(vpython)
  writef("Done!")

  renv_python_virtualenv_validate(path, version)

}

renv_use_python_condaenv_impl <- function(project,
                                          name = NULL,
                                          version = NULL,
                                          python = NULL)
{
  # if we can't load reticulate, try installing if there is a version
  # recorded in the lockfile
  if (!requireNamespace("reticulate", quietly = TRUE)) {

    # retrieve reticulate record
    lockfile <- renv_lockfile_load(project = project)
    records <- renv_lockfile_records(lockfile)
    reticulate <- records[["reticulate"]]

    # if we have a reticulate record, then attempt to restore
    if (!is.null(reticulate)) {
      restore(packages = "reticulate",
              prompt = FALSE,
              project = project)
    } else {
      install(packages = "reticulate",
              prompt = FALSE,
              project = project)
    }

  }

  # try once more to load reticulate
  if (!requireNamespace("reticulate", quietly = TRUE))
    stopf("use of conda environments requires the 'reticulate' package")

  # TODO: how to handle things like a requested Python version here?
  name <- name %||% renv_python_envpath(project, "conda", version)
  renv_python_conda_select(name, version)
}

renv_python_deactivate <- function(project) {

  file <- renv_lockfile_path(project)
  if (!file.exists(file))
    return(TRUE)

  lockfile <- renv_lockfile_read(file)
  if (is.null(lockfile$Python))
    return(TRUE)

  lockfile$Python <- NULL
  renv_lockfile_write(lockfile, file = file)
  writef("- Deactived Python -- the lockfile has been updated.")
  TRUE

}


# use.R ----------------------------------------------------------------------


the$use_libpath <- NULL

#' @rdname embed
#'
#' @param ...
#'   The \R packages to be used with this script. Ignored if `lockfile` is
#'   non-`NULL`.
#'
#' @param lockfile
#'   The lockfile to use. When supplied, renv will use the packages as
#'   declared in the lockfile.
#'
#' @param library
#'   The library path into which the requested packages should be installed.
#'   When `NULL` (the default), a library path within the \R temporary
#'   directory will be generated and used. Note that this same library path
#'   will be re-used on future calls to `renv::use()`, allowing `renv::use()`
#'   to be used multiple times within a single script.
#'
#' @param isolate
#'   Boolean; should the active library paths be included in the set of library
#'   paths activated for this script? Set this to `TRUE` if you only want the
#'   packages provided to `renv::use()` to be visible on the library paths.
#'
#' @param sandbox
#'   Should the system library be sandboxed? See the sandbox documentation in
#'   [renv::config] for more details. You can also provide an explicit sandbox
#'   path if you want to configure where `renv::use()` generates its sandbox.
#'   By default, the sandbox is generated within the \R temporary directory.
#'
#' @param attach
#'   Boolean; should the set of requested packages be automatically attached?
#'   If `TRUE`, packages will be loaded and attached via a call
#'   to [library()] after install. Ignored if `lockfile` is non-`NULL`.
#'
#' @param verbose
#'   Boolean; be verbose while installing packages?
#'
#' @return
#'   This function is normally called for its side effects.
#'
#' @export
use <- function(...,
                lockfile = NULL,
                library  = NULL,
                isolate  = sandbox,
                sandbox  = TRUE,
                attach   = FALSE,
                verbose  = TRUE)
{

  # allow use of the cache in this context
  renv_scope_options(renv.cache.linkable = TRUE)

  # set up sandbox if requested
  renv_use_sandbox(sandbox)

  # prepare library and activate library
  library <- library %||% renv_use_libpath()
  ensure_directory(library)

  # set library paths
  libpaths <- c(library, if (!isolate) .libPaths())
  renv_libpaths_set(libpaths)

  # if we were supplied a lockfile, use it
  if (!is.null(lockfile)) {
    renv_scope_options(renv.verbose = verbose)
    records <- restore(lockfile = lockfile, clean = FALSE, prompt = FALSE)
    return(invisible(records))
  }

  dots <- list(...)
  if (empty(dots))
    return(invisible())

  # resolve the provided remotes
  remotes <- lapply(dots, renv_remotes_resolve)
  names(remotes) <- map_chr(remotes, `[[`, "Package")

  # install packages
  records <- local({
    renv_scope_options(renv.verbose = verbose)
    install(packages = remotes, library = library, prompt = FALSE)
  })

  # automatically load the requested remotes
  if (attach) {
    enumerate(remotes, function(package, remote) {
      library(package, character.only = TRUE)
    })
  }

  # return set of installed packages
  invisible(records)

}

renv_use_libpath <- function() {
  (the$use_libpath <- the$use_libpath %||% tempfile("renv-use-libpath-"))
}

renv_use_sandbox <- function(sandbox) {

  if (identical(sandbox, FALSE))
    return(FALSE)

  if (renv_sandbox_activated())
    return(TRUE)

  sandbox <- if (is.character(sandbox))
    sandbox
  else
    file.path(tempdir(), "renv-sandbox")

  renv_scope_options(renv.config.sandbox.enabled = TRUE)
  renv_sandbox_activate_impl(sandbox = sandbox)

}


# utils-connections.R --------------------------------------------------------


textfile <- function(description, open = "wt") {
  file(description, open = open, encoding = "native.enc")
}


# utils-format.R -------------------------------------------------------------


stopf <- function(fmt = "", ..., call. = FALSE) {
  stop(sprintf(fmt, ...), call. = call.)
}

warningf <- function(fmt = "", ..., call. = FALSE, immediate. = FALSE) {
  warning(sprintf(fmt, ...), call. = call., immediate. = immediate.)
}

printf <- function(fmt = "", ..., file = stdout(), sep = "") {
  if (!is.null(fmt) && renv_verbose())
    cat(sprintf(fmt, ...), file = file, sep = sep)
}

writef <- function(fmt = "", ..., con = stdout()) {
  if (!is.null(fmt) && renv_verbose())
    writeLines(sprintf(fmt, ...), con = con)
}

info_bullet <- function() {
  if (l10n_info()$`UTF-8`) "\u2139" else "i"
}


# utils-map.R ----------------------------------------------------------------


bapply <- function(x, f, ..., index = "Index") {
  result <- lapply(x, f, ...)
  bind(result, index = index)
}

enumerate <- function(x, f, ..., FUN.VALUE = NULL) {

  n <- names(x)
  idx <- named(seq_along(x), n)
  callback <- function(i) f(n[[i]], x[[i]], ...)

  if (is.environment(x))
    x <- as.list(x, all.names = TRUE)

  if (is.null(FUN.VALUE))
    lapply(idx, callback)
  else
    vapply(idx, callback, FUN.VALUE = FUN.VALUE)

}

enum_chr <- function(x, f, ...) {
  enumerate(x, f, ..., FUN.VALUE = character(1))
}

enum_int <- function(x, f, ...) {
  enumerate(x, f, ..., FUN.VALUE = integer(1))
}

enum_dbl <- function(x, f, ...) {
  enumerate(x, f, ..., FUN.VALUE = double(1))
}

enum_lgl <- function(x, f, ...) {
  enumerate(x, f, ..., FUN.VALUE = logical(1))
}


uapply <- function(x, f, ...) {
  f <- match.fun(f)
  unlist(lapply(x, f, ...), recursive = FALSE)
}

filter <- function(x, f, ...) {
  f <- match.fun(f)
  x[map_lgl(x, f, ...)]
}

reject <- function(x, f, ...) {
  f <- match.fun(f)
  x[!map_lgl(x, f, ...)]
}

map <- function(x, f, ...) {
  f <- match.fun(f)
  lapply(x, f, ...)
}

map_chr <- function(x, f, ...) {
  f <- match.fun(f)
  vapply(x, f, ..., FUN.VALUE = character(1))
}

map_dbl <- function(x, f, ...) {
  f <- match.fun(f)
  vapply(x, f, ..., FUN.VALUE = numeric(1))
}

map_int <- function(x, f, ...) {
  f <- match.fun(f)
  vapply(x, f, ..., FUN.VALUE = integer(1))
}

map_lgl <- function(x, f, ...) {
  f <- match.fun(f)
  vapply(x, f, ..., FUN.VALUE = logical(1))
}


extract <- function(x, ...) {
  lapply(x, `[[`, ...)
}

extract_chr <- function(x, ...) {
  vapply(x, `[[`, ..., FUN.VALUE = character(1))
}

extract_dbl <- function(x, ...) {
  vapply(x, `[[`, ..., FUN.VALUE = numeric(1))
}

extract_int <- function(x, ...) {
  vapply(x, `[[`, ..., FUN.VALUE = integer(1))
}

extract_lgl <- function(x, ...) {
  vapply(x, `[[`, ..., FUN.VALUE = logical(1))
}


# utils.R --------------------------------------------------------------------


`%>%` <- function(...) {

  dots <- eval(substitute(alist(...)))
  if (length(dots) != 2L)
    stopf("`%>%` called with invalid number of arguments")

  lhs <- dots[[1L]]; rhs <- dots[[2L]]
  if (!is.call(rhs))
    stopf("right-hand side of rhs is not a call")

  data <- c(rhs[[1L]], lhs, as.list(rhs[-1L]))
  call <- as.call(data)

  nm <- names(rhs)
  if (length(nm))
    names(call) <- c("", "", nm[-1L])

  eval(call, envir = parent.frame())

}

`%NA%` <- function(x, y) {
  if (length(x) && is.na(x)) y else x
}

`%&&%` <- function(x, y) {
  if (length(x)) y
}

lines <- function(...) {
  paste(..., sep = "\n")
}

is_named <- function(x) {
  nm <- names(x)
  !is.null(nm) && all(nzchar(nm))
}

named <- function(object, names = object) {
  names(object) <- names
  object
}

empty <- function(x) {
  length(x) == 0L
}

zlength <- function(x) {
  length(x) != 0L
}

trim <- function(x) {
  gsub("^\\s+|\\s+$", "", x, perl = TRUE)
}

trimws <- function(x) {
  gsub("^\\s+|\\s+$", "", x, perl = TRUE)
}

case <- function(...) {

  dots <- eval(substitute(alist(...)))
  for (i in seq_along(dots)) {

    if (identical(dots[[i]], quote(expr = )))
      next

    dot <- eval(dots[[i]], envir = parent.frame())
    if (!inherits(dot, "formula"))
      return(dot)

    # Silence R CMD check note
    expr <- NULL
    cond <- NULL

    # use delayed assignments below so we can allow return statements to
    # be handled in the lexical scope where they were defined
    if (length(dot) == 2L) {
      do.call(delayedAssign, list("expr", dot[[2L]], eval.env = environment(dot)))
      return(expr)
    }

    do.call(delayedAssign, list("cond", dot[[2L]], eval.env = environment(dot)))
    do.call(delayedAssign, list("expr", dot[[3L]], eval.env = environment(dot)))
    if (cond) return(expr)

  }

}

compose <- function(wrapper, callback) {
  function(...) wrapper(callback(...))
}

catch <- function(expr) {
  tryCatch(
    withCallingHandlers(expr, error = renv_error_capture),
    error = renv_error_tag
  )
}

catchall <- function(expr) {
  tryCatch(
    withCallingHandlers(expr, condition = renv_error_capture),
    condition = renv_error_tag
  )
}

# nocov start

ask <- function(question, default = FALSE) {

  if (renv_tests_running())
    return(TRUE)

  enabled <- getOption("renv.prompt.enabled", default = TRUE)
  if (!enabled)
    return(default)

  if (!interactive())
    return(default)

  # be verbose in this scope, as we're asking the user for input
  renv_scope_options(renv.verbose = TRUE)

  repeat {

    # solicit user's answer
    selection <- if (default) "[Y/n]" else "[y/N]"
    prompt <- sprintf("%s %s: ", question, selection)
    response <- tryCatch(
      tolower(trimws(readline(prompt))),
      interrupt = identity
    )

    # check for interrupts; treat as abort request
    cancel_if(inherits(response, "interrupt"))

    # use default when no response
    if (!nzchar(response))
      return(default)

    # check for 'yes' responses
    if (response %in% c("y", "yes")) {
      writef("")
      return(TRUE)
    }

    # check for 'no' responses
    if (response %in% c("n", "no")) {
      writef("")
      return(FALSE)
    }

    # ask the user again
    writef("- Unrecognized response: please enter 'y' or 'n', or type Ctrl + C to cancel.")

  }

}

proceed <- function(default = TRUE) {
  ask("Do you want to proceed?", default = default)
}

menu <- function(choices, title, default = 1L) {

  testing <- getOption("renv.menu.choice", integer())
  if (length(testing)) {
    selected <- testing[[1]]
    options(renv.menu.choice = testing[-1])
  } else if (testing()) {
    selected <- default
  } else {
    selected <- NULL
  }

  if (!is.null(selected)) {
    title <- paste(title, collapse = "\n")
    body <- paste(sprintf("%i: %s", seq_along(choices), choices), collapse = "\n")
    footer <- sprintf("Selection: %s\n", selected)
    writef(paste(c(title, body, footer), collapse = "\n\n"))
    return(names(choices)[selected])
  }

  if (!interactive()) {
    value <- if (is.numeric(default)) names(choices)[default] else default
    return(value)
  }

  idx <- tryCatch(
    utils::menu(choices, paste(title, collapse = "\n"), graphics = FALSE),
    interrupt = function(cnd) 0L
  )

  if (idx == 0L)
    return("cancel")

  names(choices)[idx]

}

# nocov end

inject <- function(contents,
                   pattern,
                   replacement,
                   anchor = NULL,
                   fixed  = FALSE)
{
  # first, check to see if the pattern matches a line
  index <- grep(pattern, contents, perl = !fixed, fixed = fixed)
  if (length(index)) {
    contents[index] <- replacement
    return(contents)
  }

  # otherwise, check for the anchor, and insert after
  index <- if (!is.null(anchor))
    grep(anchor, contents, perl = !fixed, fixed = fixed)

  if (!length(index))
    return(c(contents, replacement))

  c(
    head(contents, n = index),
    replacement,
    tail(contents, n = -index)
  )
}

deparsed <- function(value, width = 60L) {
  paste(deparse(value, width.cutoff = width), collapse = "\n")
}

read <- function(file) {
  renv_scope_options(warn = -1L)
  contents <- readLines(file, warn = FALSE)
  paste(contents, collapse = "\n")
}

plural <- function(word, n) {
  if (n == 1) word else paste(word, "s", sep = "")
}

nplural <- function(word, n) {
  paste(n, plural(word, n))
}

trunc <- function(text, n = 78) {
  long <- nchar(text) > n
  text[long] <- sprintf("%s <...>", substring(text[long], 1, n - 6))
  text
}

endswith <- function(string, suffix) {
  substring(string, nchar(string) - nchar(suffix) + 1) == suffix
}

# like tools::file_ext, but includes leading '.', and preserves
# '.tar.gz', '.tar.bz' and so on
fileext <- function(path, default = "") {
  indices <- regexpr("[.]((?:tar[.])?[[:alnum:]]+)$", path, perl = TRUE)
  ifelse(indices > -1L, substring(path, indices), default)
}

visited <- function(name, envir) {
  value <- envir[[name]] %||% FALSE
  envir[[name]] <- TRUE
  value
}

rowapply <- function(X, FUN, ...) {
  lapply(seq_len(NROW(X)), function(I) {
    FUN(X[I, , drop = FALSE], ...)
  })
}

comspec <- function() {
  Sys.getenv("COMSPEC", unset = Sys.which("cmd.exe"))
}

nullfile <- function() {
  if (renv_platform_windows()) "NUL" else "/dev/null"
}

quietly <- function(expr, sink = TRUE) {

  if (sink) {
    sink(file = nullfile())
    defer(sink(NULL))
  }

  withCallingHandlers(
    expr,
    warning               = function(c) invokeRestart("muffleWarning"),
    message               = function(c) invokeRestart("muffleMessage"),
    packageStartupMessage = function(c) invokeRestart("muffleMessage")
  )

}

# NOTE: This function can be used in preference to `as.*()` if you'd like
# to preserve attributes on the incoming object 'x'.
convert <- function(x, type) {
  storage.mode(x) <- type
  x
}

remap <- function(x, map) {

  # TODO: use match?
  remapped <- x
  enumerate(map, function(key, val) {
    remapped[remapped == key] <<- val
  })
  remapped

}

keep <- function(x, keys) {
  x[intersect(keys, names(x))]
}

exclude <- function(x, keys) {
  x[setdiff(names(x), keys)]
}

invoke <- function(callback, ...) {
  callback(...)
}

dequote <- function(strings) {

  for (quote in c("'", '"')) {

    # find strings matching pattern
    pattern <- paste0(quote, "(.*)", quote)
    matches <- grep(pattern, strings, perl = TRUE)
    if (empty(matches))
      next

    # remove outer quotes
    strings[matches] <- gsub(pattern, "\\1", strings[matches], perl = TRUE)

    # un-escape inner quotes
    pattern <- paste0("\\", quote)
    strings[matches] <- gsub(pattern, quote, strings[matches], fixed = TRUE)
  }

  strings

}

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]], ...)))
      return(value)
}

recursing <- function() {

  nf <- sys.nframe()
  if (nf < 2L)
    return(FALSE)

  np <- sys.parent()
  fn <- sys.function(np)
  for (i in seq_len(np - 1L))
    if (identical(fn, sys.function(i)))
      return(TRUE)

  FALSE

}

csort <- function(x, decreasing = FALSE, ...) {
  renv_scope_locale("LC_COLLATE", "C")
  sort(x, decreasing, ...)
}

fsub <- function(pattern, replacement, x, ignore.case = FALSE, useBytes = FALSE) {
  sub(pattern, replacement, x, ignore.case = ignore.case, useBytes = useBytes, fixed = TRUE)
}

rows <- function(data, indices) {

  # convert logical values
  if (is.logical(indices)) {
    if (length(indices) < nrow(data))
      indices <- rep(indices, length.out = nrow(data))
    indices <- which(indices, useNames = FALSE)
  }

  # build output list
  output <- vector("list", length(data))
  for (i in seq_along(data))
    output[[i]] <- .subset2(data, i)[indices]

  # copy relevant attributes
  attrs <- attributes(data)
  attrs[["row.names"]] <- .set_row_names(length(indices))
  attributes(output) <- attrs

  # return new data.frame
  output

}

cols <- function(data, indices) {

  # perform subset
  output <- .subset(data, indices)

  # copy relevant attributes
  attrs <- attributes(data)
  attrs[["names"]] <- attr(output, "names", exact = TRUE)
  attributes(output) <- attrs

  # return output
  output

}

stringify <- function(object, collapse = " ") {

  if (is.symbol(object))
    return(as.character(object))

  paste(
    deparse(object, width.cutoff = 500L),
    collapse = collapse
  )

}

env <- function(...) {
  list2env(list(...), envir = new.env(parent = emptyenv()))
}

env2list <- function(env) {
  as.list.environment(env, all.names = TRUE)
}

chop <- function(x, split = "\n", fixed = TRUE, perl = FALSE, useBytes = FALSE) {
  strsplit(x, split, !perl, perl, useBytes)[[1L]]
}

prof <- function(expr, ...) {

  profile <- tempfile("renv-profile-", fileext = ".Rprof")

  Rprof(profile, ...)
  result <- expr
  Rprof(NULL)
  print(summaryRprof(profile))

  invisible(result)

}

recycle <- function(data) {

  # compute number of columns
  n <- lengths(data, use.names = FALSE)
  nrow <- max(n)

  # start recycling
  for (i in seq_along(data)) {
    if (n[[i]] == 0L) {
      length(data[[i]]) <- nrow
    } else if (n[[i]] != nrow) {
      data[[i]] <- rep.int(data[[i]], nrow / n[[i]])
    }
  }

  data

}

take <- function(data, index = NULL) {
  if (is.null(index)) data else .subset2(data, index)
}

cancel <- function() {

  renv_snapshot_auto_suppress_next()
  if (testing())
    stop("Operation canceled", call. = FALSE)

  message("- Operation canceled.")
  invokeRestart("abort")

}

cancel_if <- function(cnd) {
  if (cnd) cancel()
}

rep_named <- function(names, x) {
  values <- rep_len(x, length(names))
  names(values) <- names
  values
}

wait_until <- function(callback, ...) {
  repeat if (callback(...)) return(TRUE)
}

timer <- function(units = "secs") {

  .time <- Sys.time()
  .units <- units

  list(

    now = function() {
      Sys.time()
    },

    elapsed = function() {
      difftime(Sys.time(), .time, units = .units)
    }
  )

}

summon <- function() {
  envir <- do.call(attach, list(what = NULL, name = "renv"))
  renv <- renv_envir_self()
  list2env(as.list(renv), envir = envir)
}

assert <- function(...) stopifnot(...)

overlay <- function(lhs, rhs) {
  modifyList(as.list(lhs), as.list(rhs))
}

# the 'top' renv function in the call stack
topfun <- function() {

  self <- renv_envir_self()
  frames <- sys.frames()

  for (i in seq_along(frames))
    if (identical(self, parent.env(frames[[i]])))
      return(sys.function(i))

}

warnify <- function(cnd) {
  class(cnd) <- c("warning", "condition")
  warning(cnd)
}


# vector.R -------------------------------------------------------------------


# these functions are like the base R equivalents, but preserve names
renv_vector_diff <- function(x, y) {
  x[match(x, y, 0L) == 0L]
}

renv_vector_intersect <- function(x, y) {
  y[match(x, y, 0L)]
}

renv_vector_unique <- function(x) {
  x[!duplicated(x)]
}


# vendor.R -------------------------------------------------------------------


#' Vendor renv in an R package
#'
#' @description
#' Calling `renv:::vendor()` will:
#'
#' - Compile a vendored copy of renv to `inst/vendor/renv.R`,
#' - Generate an renv auto-loader at `R/renv.R`.
#'
#' Using this, projects can take a dependency on renv, and use renv
#' internals, in a CRAN-compliant way. After vendoring renv, you can
#' use renv APIs in your package via the embedded renv environment;
#' for example, you could call the [renv::dependencies()] function with:
#'
#' ```
#' renv$dependencies()
#' ```
#'
#' Be aware that renv internals might change in future releases, so if you
#' need to rely on renv internal functions, we strongly recommend testing
#' your usages of these functions to avoid potential breakage.
#'
#' @param version The version of renv to vendor. `renv` sources will be pulled
#'   from GitHub, and so `version` should refer to either a commit hash or a
#'   branch name.
#'
#' @param project The project in which renv should be vendored.
#'
#' @keywords internal
#'
vendor <- function(version = "main", project = getwd()) {
  renv_scope_error_handler()

  # validate project is a package
  descpath <- file.path(project, "DESCRIPTION")
  if (!file.exists(descpath)) {
    fmt <- "%s does not contain a DESCRIPTION file; cannot proceed"
    stopf(fmt, renv_path_pretty(project))
  }

  # retrieve package sources
  sources <- renv_vendor_sources(version)

  # compute package remote
  spec <- sprintf("rstudio/renv@%s", version)
  remote <- renv_remotes_resolve(spec)

  # build script header
  header <- renv_vendor_header(remote)

  # create the renv script itself
  embed <- renv_vendor_create(
    project    = project,
    sources    = sources,
    header     = header
  )

  # create the loader
  loader <- renv_vendor_loader(project, remote, header)

  # let the user know what just happened
  template <- heredoc("
    #
    # 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.
    #
  ")

  writef(template, renv_path_pretty(embed), renv_path_pretty(loader))

  invisible(TRUE)
}

renv_vendor_create <- function(project, sources, header) {

  # find all the renv R source scripts
  scripts <- list.files(file.path(sources, "R"), full.names = TRUE)

  # read into a single file
  contents <- map_chr(scripts, function(script) {
    header <- header(basename(script), n = 78L)
    contents <- readLines(script)
    parts <- c(header, "", contents, "", "")
    paste(parts, collapse = "\n")
  })

  # paste into single script
  bundle <- paste(contents, collapse = "\n")
  all <- c(header, "", bundle)

  # write to file
  target <- file.path(project, "inst/vendor/renv.R")
  ensure_parent_directory(target)
  writeLines(all, con = target)

  # return generated bundle
  invisible(target)

}

renv_vendor_loader <- function(project, remote, header) {

  source <- system.file("resources/vendor/renv.R", package = "renv")
  template <- readLines(source, warn = FALSE)

  # replace '..imports..' with the imports we use
  imports <- renv_vendor_imports()

  # create metadata for the embedded version
  version <- renv_metadata_version_create(remote)
  metadata <- renv_metadata_create(embedded = TRUE, version = version)

  # format metadata for template insertion
  lines <- enum_chr(metadata, function(key, value) {
    sprintf("    %s = %s", key, deparse(value))
  })

  inner <- paste(lines, collapse = ",\n")

  replacements <- list(
    imports  = imports,
    metadata = paste(c("list(", inner, "  )"), collapse = "\n")
  )
  contents <- renv_template_replace(template, replacements, format = "..%s..")

  all <- c("", header, "", contents)
  target <- file.path(project, "R/renv.R")
  ensure_parent_directory(target)
  writeLines(all, con = target)

  invisible(target)

}

renv_vendor_imports <- function() {

  imports <- getNamespaceImports("renv")

  # collect into sane format
  packages <- setdiff(unique(names(imports)), c("base", ""))
  names(packages) <- packages
  table <- map(packages, function(package) {
    unlist(imports[names(imports) == package], use.names = FALSE)
  })

  # format nicely
  entries <- enum_chr(table, function(package, functions) {
    lines <- sprintf("      \"%s\"", functions)
    body <- paste(lines, collapse = ",\n")
    parts <- c(sprintf("    %s = c(", package), body, "    )")
    paste(parts, collapse = "\n")
  })

  paste(c("list(", paste(entries, collapse = ",\n"), "  )"), collapse = "\n")

}

renv_vendor_sources <- function(version) {

  # retrieve renv
  tarball <- renv_bootstrap_download_github(version = version)

  # extract downloaded sources
  untarred <- tempfile("renv-vendor-")
  untar(tarball, exdir = untarred)

  # the package itself will exist as a folder within 'exdir'
  list.files(untarred, full.names = TRUE)[[1L]]

}

renv_vendor_header <- function(remote) {

  template <- heredoc("
    #
    # renv %s [rstudio/renv#%s]: A dependency management toolkit for R.
    # Generated using `renv:::vendor()` at %s.
    #
  ")

  version <- remote$Version
  hash <- substring(remote$RemoteSha, 1L, 7L)
  sprintf(template, version, hash, Sys.time())

}


# verbose.R ------------------------------------------------------------------


renv_verbose <- function() {

  verbose <- getOption("renv.verbose")
  if (!is.null(verbose))
    return(as.logical(verbose))

  verbose <- Sys.getenv("RENV_VERBOSE", unset = NA)
  if (!is.na(verbose))
    return(as.logical(verbose))

  if (testing())
    return(FALSE)

  interactive() || !renv_tests_running()

}


# version.R ------------------------------------------------------------------


renv_version_compare <- function(lhs, rhs, n = NULL) {

  # retrieve versions as integer vector
  lhs <- unlist(unclass(numeric_version(lhs)))
  rhs <- unlist(unclass(numeric_version(rhs)))

  # compute number of components to compare
  n <- n %||% max(length(lhs), length(rhs))

  # pad each vector with zeroes up to the requested length
  lhs <- c(lhs, rep.int(0L, max(0L, n - length(lhs))))
  rhs <- c(rhs, rep.int(0L, max(0L, n - length(rhs))))

  # iterate through each component and compare
  for (i in seq_len(n)) {
    if (lhs[[i]] < rhs[[i]])
      return(-1L)
    else if (lhs[[i]] > rhs[[i]])
      return(+1L)
  }

  # if we got here, then all components compared equal
  0L

}

renv_version_le <- function(lhs, rhs, n = NULL) {
  renv_version_compare(lhs, rhs, n) <= 0L
}

renv_version_lt <- function(lhs, rhs, n = NULL) {
  renv_version_compare(lhs, rhs, n) <  0L
}

renv_version_eq <- function(lhs, rhs, n = NULL) {
  renv_version_compare(lhs, rhs, n) == 0L
}

renv_version_gt <- function(lhs, rhs, n = NULL) {
  renv_version_compare(lhs, rhs, n) >  0L
}

renv_version_ge <- function(lhs, rhs, n = NULL) {
  renv_version_compare(lhs, rhs, n) >= 0L
}

renv_version_match <- function(versions, request) {

  nrequest <- unclass(numeric_version(request))[[1L]]
  for (i in rev(seq_along(nrequest))) {

    matches <- which(map_lgl(versions, function(version) {
      renv_version_eq(version, request, n = i)
    }))

    if (!length(matches))
      next

    # TODO: should '3.1' match the closest match (e.g. '3.2') or
    # highest match (e.g. '3.6')?
    sorted <- matches[sort(names(matches), decreasing = TRUE)]
    return(names(sorted)[[1L]])

  }

  versions[[1L]]

}

renv_version_parts <- function(version, n) {

  # split version into parts
  parts <- unclass(as.numeric_version(version))[[1L]]

  # extend parts to size of n
  diff <- max(n) - length(parts)
  if (diff > 0)
    parts <- c(parts, rep.int(0L, diff))

  # retrieve possibly-extended parts
  parts[1:n]

}

renv_version_maj_min <- function(version) {
  parts <- renv_version_parts(version, 2L)
  paste(parts, collapse = ".")
}

renv_version_length <- function(version) {
  nv <- as.numeric_version(version)
  length(unclass(nv)[[1L]])
}


# virtualization.R -----------------------------------------------------------


the$virtualization_type <- NULL

renv_virtualization_init <- function() {

  type <- tryCatch(
    renv_virtualization_type_impl(),
    error = function(e) "unknown"
  )

  the$virtualization_type <- type

}

renv_virtualization_type <- function() {
  the$virtualization_type
}

renv_virtualization_type_impl <- function() {

  # only done on linux for now
  if (!renv_platform_linux())
    return("native")

  # check for cgroup
  if (file.exists("/proc/1/cgroup")) {
    contents <- readLines("/proc/1/cgroup")
    if (any(grepl("/docker/", contents)))
      return("docker")
  }

  # assume native otherwise
  "native"

}


# warnings.R -----------------------------------------------------------------


renv_warnings_unknown_sources <- function(records) {

  if (empty(records))
    return(FALSE)

  # TODO: Should this be documented?
  enabled <- renv_config_get(
    name    = "unknown.sources",
    scope   = "warnings",
    type    = "logical[1]",
    default = TRUE
  )

  if (!enabled)
    return(FALSE)

  renv_scope_options(renv.verbose = TRUE)
  renv_pretty_print_records(
    "The following package(s) were installed from an unknown source:",
    records,
    c(
      "renv may be unable to restore these packages in the future.",
      "Consider reinstalling these packages from a known source (e.g. CRAN)."
    )
  )

  return(TRUE)

}


# watchdog-server.R ----------------------------------------------------------


renv_watchdog_server_start <- function(client) {

  # initialize logging
  renv_log_init()

  # create socket server
  server <- renv_socket_server()
  dlog("watchdog-server", "Listening on port %i.", server$port)

  # communicate information back to client
  dlog("watchdog-server", "Waiting for client...")
  metadata <- list(port = server$port, pid = server$pid)
  conn <- renv_socket_connect(port = client$port, open = "wb")
  serialize(metadata, connection = conn)
  close(conn)
  dlog("watchdog-server", "Synchronized with client.")

  # initialize locks
  lockenv <- new.env(parent = emptyenv())

  # start listening for connections
  repeat tryCatch(
    renv_watchdog_server_run(server, client, lockenv),
    error = function(e) {
      dlog("watchdog-server", "Error: %s", conditionMessage(e))
    }
  )

}

renv_watchdog_server_run <- function(server, client, lockenv) {

  # check for parent exit
  if (!renv_process_exists(client$pid)) {
    dlog("watchdog-server", "Client process has exited; shutting down.")
    renv_watchdog_server_exit(server, client, lockenv)
  }

  # set file time on owned locks, so we can see they're not orphaned
  dlog("watchdog-server", "Refreshing lock times.")
  locks <- ls(envir = lockenv, all.names = TRUE)
  renv_lock_refresh(locks)

  # wait for connection
  dlog("watchdog-server", "Waiting for connection...")
  conn <- renv_socket_accept(server$socket, open = "rb", timeout = 1)
  defer(close(conn))

  # read the request
  dlog("watchdog-server", "Received connection; reading data.")
  request <- unserialize(conn)

  dlog("watchdog-server", "Received request.")
  str(request)

  # handle the request
  switch(

    request$method %||% "<missing>",

    ListLocks = {
      dlog("watchdog-server", "Executing 'ListLocks' request.")
      conn <- renv_socket_connect(port = request$port, open = "watchdog-server", "b")
      defer(close(conn))
      locks <- ls(envir = lockenv, all.names = TRUE)
      serialize(locks, connection = conn)
    },

    LockAcquired = {
      dlog("watchdog-server", "Acquired lock on path '%s'.", request$data$path)
      assign(request$data$path, TRUE, envir = lockenv)
    },

    LockReleased = {
      dlog("watchdog-server", "Released lock on path '%s'.", request$data$path)
      rm(list = request$data$path, envir = lockenv)
    },

    Shutdown = {
      dlog("watchdog-server", "Received shutdown request; shutting down.")
      renv_watchdog_server_exit(server, client, lockenv)
    },

    "<missing>" = {
      dlog("watchdog-server", "Received request with no method field available.")
    },

    {
      dlog("watchdog-server", "Unknown method '%s'", request$method)
    }

  )

}

renv_watchdog_server_exit <- function(server, client, lockenv) {

  # remove any existing locks
  locks <- ls(envir = lockenv, all.names = TRUE)
  unlink(locks, recursive = TRUE, force = TRUE)

  # shut down the socket server
  close(server$socket)

  # quit
  quit(status = 0)

}


# watchdog.R -----------------------------------------------------------------


# whether or not the user has enabled the renv watchdog in this session
the$watchdog_enabled <- FALSE

# metadata related to the running watchdog process, if any
the$watchdog_process <- NULL

renv_watchdog_init <- function() {
  the$watchdog_enabled <- renv_watchdog_enabled_impl()
}

renv_watchdog_enabled <- function() {
  the$watchdog_enabled
}

renv_watchdog_check <- function() {

  if (!renv_watchdog_enabled())
    return(FALSE)

  if (renv_watchdog_running())
    return(TRUE)

  renv_watchdog_start()

}

renv_watchdog_enabled_impl <- function() {

  # skip in older versions of R; we require newer APIs
  if (getRversion() < "4.0.0")
    return(FALSE)

  # skip if explicitly disabled via envvar
  enabled <- Sys.getenv("RENV_WATCHDOG_ENABLED", unset = NA)
  if (!is.na(enabled))
    return(truthy(enabled))

  # disable on Windows; need to understand CI test failures
  # https://github.com/rstudio/renv/actions/runs/5273668333/jobs/9537353788#step:6:242
  if (renv_platform_windows())
    return(FALSE)

  # skip during R CMD check (but not when running tests)
  checking <- renv_envvar_exists("_R_CHECK_PACKAGE_NAME_")
  if (checking && !testing())
    return(FALSE)

  # skip during R CMD build or R CMD INSTALL
  # ... unless we are running tests on CI
  building <-
    renv_envvar_exists("R_PACKAGE_NAME") ||
    renv_envvar_exists("R_PACKAGE_DIR")

  if (building) {
    ci <- Sys.getenv("CI", unset = "FALSE")
    if (!truthy(ci))
      return(FALSE)
  }

  # ok, we're enabled
  TRUE

}

renv_watchdog_start <- function() {

  the$watchdog_enabled <- tryCatch(
    renv_watchdog_start_impl(),
    error = function(e) {
      warning(conditionMessage(e))
      FALSE
    }
  )

}

renv_watchdog_start_impl <- function() {

  # create a socket server -- this is used so the watchdog process
  # 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
  defer(close(socket))

  # generate script to invoke watchdog
  script <- renv_scope_tempfile("renv-watchdog-", fileext = ".R")

  # figure out library path -- need to dodge devtools::load_all()
  nspath <- renv_namespace_path(.packageName)
  library <- if (file.exists(file.path(nspath, "Meta/package.rds")))
    dirname(nspath)
  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)
    renv <- if (!is.null(host$renv)) host$renv else host
    renv$renv_watchdog_server_start(client)
  })

  writeLines(deparse(code), con = script)

  # debug logging
  debugging <- Sys.getenv("RENV_WATCHDOG_DEBUG", unset = "FALSE")
  stdout <- stderr <- if (truthy(debugging)) "" else FALSE

  # launch the watchdog
  local({
    renv_scope_envvars(RENV_PROCESS_TYPE = "watchdog-server")
    system2(
      command = R(),
      args = c("--vanilla", "-s", "-f", renv_shell_path(script)),
      stdout = stdout,
      stderr = stderr,
      wait = FALSE
    )
  })

  # wait for connection from watchdog server
  dlog("watchdog", "watchdog process launched; waiting for message")
  conn <- catch(renv_socket_accept(socket, open = "rb", timeout = 10L))
  if (inherits(conn, "error")) {
    dlog("watchdog", paste("error connecting to watchdog:", conditionMessage(conn)))
    return(FALSE)
  }

  # store information about the running process
  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)
  TRUE

}

renv_watchdog_notify <- function(method, data = list()) {

  tryCatch(
    renv_watchdog_notify_impl(method, data),
    error = warnify
  )

}

renv_watchdog_notify_impl <- function(method, data = list()) {

  # make sure the watchdog is running
  if (!renv_watchdog_check())
    return(FALSE)

  # connect to the running server
  port <- renv_watchdog_port()
  conn <- renv_socket_connect(port, open = "wb")

  # close the connection on exit
  defer(close(conn))

  # write message
  message <- list(method = method, data = data)
  serialize(message, connection = conn)

  # TRUE indicates message was written
  TRUE

}

renv_watchdog_request <- function(method, data = list()) {
  tryCatch(
    renv_watchdog_request_impl(method, data),
    error = warnify
  )
}

renv_watchdog_request_impl <- function(method, data = list()) {

  # make sure the watchdog is running
  if (!renv_watchdog_check())
    return(FALSE)

  # connect to the running server
  port <- renv_watchdog_port()
  outgoing <- renv_socket_connect(port, open = "wb")
  defer(close(outgoing))

  # create our own socket server
  server <- renv_socket_server()
  defer(close(server$socket))

  # write message
  message <- list(method = method, data = data, port = server$port)
  serialize(message, connection = outgoing)

  # now, open a new connection to get the response
  incoming <- renv_socket_accept(server$socket, open = "rb")
  defer(close(incoming))

  # read the response
  unserialize(connection = incoming)

}

renv_watchdog_pid <- function() {
  the$watchdog_process$pid
}

renv_watchdog_port <- function() {
  the$watchdog_process$port
}

renv_watchdog_running <- function() {
  pid <- renv_watchdog_pid()
  !is.null(pid) && renv_process_exists(pid)
}

renv_watchdog_unload <- function() {
  renv_watchdog_shutdown()
}

renv_watchdog_terminate <- function() {
  pid <- renv_watchdog_pid()
  renv_process_kill(pid)
}

renv_watchdog_shutdown <- function() {

  # nothing to do if watchdog isn't running
  if (!renv_watchdog_running())
    return(TRUE)

  # tell watchdog to shutdown
  renv_watchdog_notify("Shutdown")

  # wait for process to exit (avoid RStudio bomb)
  clock <- timer()
  wait_until(function() {
    !renv_watchdog_running() || clock$elapsed() > 1
  })

  if (!renv_watchdog_running())
    return(TRUE)

  # if it's still running, explicitly terminate it
  renv_watchdog_terminate()

  # wait for process to exit (avoid RStudio bomb)
  clock <- timer()
  wait_until(function() {
    !renv_watchdog_running() || clock$elapsed() > 1
  })

}


# xcode.R --------------------------------------------------------------------


renv_xcode_available <- function() {

  # allow bypass if required
  check <- getOption("renv.xcode.available", default = NULL)
  if (!is.null(check))
    return(check)

  # otherwise, check via xcode-select
  status <- suppressWarnings(
    system2("/usr/bin/xcode-select", "-p", stdout = FALSE, stderr = FALSE)
  )

  identical(status, 0L)

}

renv_xcode_check <- function() {

  # allow bypass of xcode check if required
  check <- getOption("renv.xcode.check", default = TRUE)
  if (identical(check, FALSE))
    return()

  # only run on macOS
  if (!renv_platform_macos())
    return()

  # only run check once per session
  if (once())
    return()

  cmd <- "/usr/bin/xcrun --find --show-sdk-path"
  status <- system(cmd, ignore.stdout = TRUE, ignore.stderr = TRUE)
  if (identical(status, 0L))
    return()

  if (identical(status, 69L)) {

    msg <- "
macOS is reporting that you have not yet agreed to the Xcode license.
You must accept the Xcode license before R packages can be installed from source.
Please run:

    sudo xcodebuild -license accept

in the Terminal to accept the Xcode license.
Set options(renv.xcode.check = FALSE) to disable this warning.
"
    warning(msg)

  }

  fmt <- "%s returned exit code %i"
  warningf(fmt, cmd, status)

}


# yaml.R ---------------------------------------------------------------------


renv_yaml_load <- function(text) {

  yaml::yaml.load(
    string = text,
    eval.expr = FALSE,
    handlers = list(
      r = function(yaml) {
        attr(yaml, "type") <- "r"
        yaml
      }
    )
  )

}


# zzz.R ----------------------------------------------------------------------


.onLoad <- function(libname, pkgname) {
  renv_zzz_load()
}

.onAttach <- function(libname, pkgname) {
  renv_zzz_attach()
}

.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 <- system.file(package = "renv", "help/renv.rdb")
  .Internal <- .Internal
  lazyLoadDBflush <- function(...) {}

  tryCatch(
    .Internal(lazyLoadDBflush(helpdb)),
    error = function(e) NULL
  )

}

# 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() {

  # NOTE: needs to be visible to embedded instances of renv as well
  the$envir_self <<- renv_envir_self()

  # make sure renv (and packages using renv!!!) use tempdir for storage
  # when running tests, or R CMD check
  if (checking() || testing()) {

    # set root directory
    root <- Sys.getenv("RENV_PATHS_ROOT", unset = tempfile("renv-root-"))
    Sys.setenv(RENV_PATHS_ROOT = root)

    # set up sandbox -- only done on non-Windows due to strange intermittent
    # test failures that seemed to occur there?
    if (renv_platform_unix()) {
      sandbox <- Sys.getenv("RENV_PATHS_SANDBOX", unset = tempfile("renv-sandbox-"))
      Sys.setenv(RENV_PATHS_SANDBOX = sandbox)
    }

    # don't lock sandbox while testing / checking
    options(renv.sandbox.locking_enabled = FALSE)

  }

  renv_metadata_init()
  renv_platform_init()
  renv_virtualization_init()
  renv_envvars_init()
  renv_log_init()
  renv_methods_init()
  renv_libpaths_init()
  renv_patch_init()
  renv_sandbox_init()
  renv_sdkroot_init()
  renv_watchdog_init()

  if (!renv_metadata_embedded()) {

    # TODO: It's not clear if these callbacks are safe to use when renv is
    # embedded, but it's unlikely that clients would want them anyhow.
    renv_task_create(renv_sandbox_task)
    renv_task_create(renv_snapshot_task)
  }

  # 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
  if (renv_rstudio_available()) {
    project <- getOption("renv.project.path")
    if (!is.null(project))
      renv_sandbox_activate(project = project)
  }

  # make sure renv is unloaded on exit, so locks etc. are released
  # we previously tried to orchestrate this via unloadNamespace(),
  # but this fails when a package importing renv is already loaded
  # https://github.com/rstudio/renv/issues/1621
  reg.finalizer(renv_envir_self(), renv_unload_finalizer, onexit = TRUE)

}

renv_zzz_attach <- function() {
  renv_rstudio_fixup()
}

renv_zzz_run <- function() {

  # check if we're in pkgload::load_all()
  # if so, then create some files
  if (renv_envvar_exists("DEVTOOLS_LOAD")) {
    renv_zzz_bootstrap_activate()
    renv_zzz_bootstrap_config()
  }

  # check if we're running as part of R CMD build
  # if so, build our local repository with a copy of ourselves
  if (building())
    renv_zzz_repos()

}

renv_zzz_bootstrap_activate <- function() {

  source <- "templates/template-activate.R"
  target <- "inst/resources/activate.R"
  scripts <- c("R/bootstrap.R", "R/json-read.R")

  # Do we need an update
  source_mtime <- max(renv_file_info(c(source, scripts))$mtime)
  target_mtime <- renv_file_info(target)$mtime

  if (!is.na(target_mtime) && target_mtime > source_mtime)
    return()

  # read the necessary bootstrap scripts
  contents <- map(scripts, readLines)
  bootstrap <- unlist(contents)

  # format nicely for insertion
  bootstrap <- paste(" ", bootstrap)
  bootstrap <- paste(bootstrap, collapse = "\n")

  # replace template with bootstrap code
  template <- renv_file_read(source)
  replaced <- renv_template_replace(template, list(BOOTSTRAP = bootstrap))

  # write to resources
  printf("- Generating 'inst/resources/activate.R' ... ")
  writeLines(replaced, con = target)
  writef("Done!")

}

renv_zzz_bootstrap_config <- function() {

  source <- "inst/config.yml"
  target <- "R/config-defaults.R"

  source_mtime <- renv_file_info(source)$mtime
  target_mtime <- renv_file_info(target)$mtime

  if (target_mtime > source_mtime)
    return()

  template <- renv_template_create(heredoc(leave = 2, '
    ${NAME} = function(..., default = ${DEFAULT}) {
      renv_config_get(
        name    = "${NAME}",
        type    = "${TYPE}",
        default = default,
        args    = list(...)
      )
    }
  '))

  template <- gsub("^\\n+|\\n+$", "", template)

  generate <- function(entry) {

    name    <- entry$name
    type    <- entry$type
    default <- entry$default
    code    <- entry$code

    default <- if (length(code)) trimws(code) else deparse(default)

    replacements <- list(
      NAME     = name,
      TYPE     = type,
      DEFAULT  = default
    )

    renv_template_replace(template, replacements)

  }

  config <- yaml::read_yaml("inst/config.yml")
  code <- map_chr(config, generate)
  all <- c(
    "",
    "# Auto-generated by renv_zzz_bootstrap_config()",
    "",
    "#' @rdname config",
    "#' @export",
    "#' @format NULL",
    "config <- list(",
    "",
    paste(code, collapse = ",\n\n"),
    "",
    ")"
  )

  printf("- Generating 'R/config-defaults.R' ... ")
  writeLines(all, con = target)
  writef("Done!")

}

renv_zzz_repos <- function() {

  # don't run if we're running tests
  if (checking())
    return()

  # prevent recursion
  installing <- Sys.getenv("RENV_INSTALLING_REPOS", unset = NA)
  if (!is.na(installing))
    return()

  renv_scope_envvars(RENV_INSTALLING_REPOS = "TRUE")
  writeLines("** installing renv to package-local repository")

  # get package directory
  pkgdir <- getwd()

  # move to build directory
  tdir <- tempfile("renv-build-")
  ensure_directory(tdir)
  renv_scope_wd(tdir)

  # build renv again
  r_cmd_build("renv", path = pkgdir, "--no-build-vignettes")

  # copy built tarball to inst folder
  src <- list.files(tdir, full.names = TRUE)
  tgt <- file.path(pkgdir, "inst/repos/src/contrib")

  ensure_directory(tgt)
  file.copy(src, tgt)

  # write PACKAGES
  renv_scope_envvars(R_DEFAULT_SERIALIZE_VERSION = "2")
  write_PACKAGES(tgt, type = "source")

}

if (identical(.packageName, "renv")) {
  renv_zzz_run()
}


