(# Autogenerated from contents in the package's R directory, do not edit! # Run make to update. function(...) { message( "The install-github.me service is deprecated, please stop using it." ) ## This is the code of the package, put in here by brew # Contents of R/bioc-standalone.R #' Tools for Bioconductor versions and repositories #' #' \section{API:} #' #' ``` #' get_yaml_config(forget = FALSE) #' set_yaml_config(text) #' #' get_release_version(forget = FALSE) #' get_devel_version(forget = FALSE) #' #' get_version_map(forget = FALSE) #' get_matching_bioc_version(r_version = getRversion(), forget = FALSE) #' get_bioc_version(r_version = getRversion(), forget = FALSE) #' #' get_repos(bioc_version = "auto", forget = FALSE) #' ``` #' #' * `forget`: Whether to forget the cached version of the Bioconductor #' config YAML file and download it again. #' * `text`: character vector (linewise) or scalar, the contents of the #' `config.yaml` file, if obtained externally, to be used as a cached #' version in the future. #' * `r_version`: R version string, or `package_version` object. #' * `bioc_version`: Bioc version string or `package_version` object, #' or the string `"auto"` to use the one matching the current R version. #' #' `get_yaml_config()` returns the raw contents of the `config.yaml` file, #' linewise. It is typically not needed, except if one needs information #' that cannot be surfaces via the other API functions. #' #' `set_yaml_config()` can be used to _set_ the contents of the #' `config.yaml` file. This is useful, if one has already obtained it #' externally, but wants to use the obtained file with the rest of the #' bioc standalone code. #' #' `get_release_version()` returns the version of the current Bioconductor #' release. #' #' `get_devel_version()` returns the version of the current development #' version of Bioconductor. #' #' `get_version_map()` return the mapping between R versions and #' Bioconductor versions. Note that this is not a one to one mapping. #' E.g. currently R `3.6.x` maps to both Bioc `3.9` (Bioc release) and #' `3.10` (Bioc devel); and also Bioc `3.10` maps to both R `3.6.x` and #' R `3.7.x` (current R-devel). It returns a data frame with three columns: #' `bioc_version`, `r_version` and `bioc_status`. The first two columns #' contain `package_vesion` objects, the third is a factor with levels: #' `out-of-date`, `release`, `devel`, `future`. #' #' `get_matching_bioc_version()` returns the matching Bioc version for an #' R version. If the R version matches to both a released and a devel #' version, then the released version is chosen. #' #' `get_bioc_version()` returns the matching Bioc version for the #' specified R version. It does observe the `R_BIOC_VERSION` environment #' variable, which can be used to force a Bioconductor version. If this is #' not set, it just calls `get_matching_bioc_version()`. #' #' `get_repos()` returns the Bioc repositories of the specified Bioc #' version. It defaults to the Bioc version that matches the calling R #' version. It returns a named character vector. #' #' \section{NEWS:} #' * 2019-05-30 First version in remotes. #' * 2020-03-22 get_matching_bioc_version() is now correct if the current #' R version is not in the builtin mapping. #' * 2020-11-21 Update internal map for 3.12. #' * 2023-05-08 Add 'books' repo. #' #' @name bioconductor #' @keywords internal #' @noRd NULL bioconductor <- local({ # ------------------------------------------------------------------- # Configuration that does not change often config_url <- function() { Sys.getenv( "R_BIOC_CONFIG_URL", "https://bioconductor.org/config.yaml" ) } builtin_map <- list( "2.1" = package_version("1.6"), "2.2" = package_version("1.7"), "2.3" = package_version("1.8"), "2.4" = package_version("1.9"), "2.5" = package_version("2.0"), "2.6" = package_version("2.1"), "2.7" = package_version("2.2"), "2.8" = package_version("2.3"), "2.9" = package_version("2.4"), "2.10" = package_version("2.5"), "2.11" = package_version("2.6"), "2.12" = package_version("2.7"), "2.13" = package_version("2.8"), "2.14" = package_version("2.9"), "2.15" = package_version("2.11"), "3.0" = package_version("2.13"), "3.1" = package_version("3.0"), "3.2" = package_version("3.2"), "3.3" = package_version("3.4"), "3.4" = package_version("3.6"), "3.5" = package_version("3.8"), "3.6" = package_version("3.10"), "4.0" = package_version("3.12"), "4.1" = package_version("3.14"), "4.2" = package_version("3.16"), "4.3" = package_version("3.18") # Do not include R 4.4 <-> Bioc 3.19, because R 4.4 will use # Bioc 3.20 eventually. ) # ------------------------------------------------------------------- # Cache devel_version <- NULL release_version <- NULL version_map <- NULL yaml_config <- NULL clear_cache <- function() { devel_version <<- NULL release_version <<- NULL version_map <<- NULL yaml_config <<- NULL } # ------------------------------------------------------------------- # API get_yaml_config <- function(forget = FALSE) { if (forget || is.null(yaml_config)) { new <- tryCatch(read_url(config_url()), error = function(x) x) if (inherits(new, "error")) { http_url <- sub("^https", "http", config_url()) new <- tryCatch(read_url(http_url), error = function(x) x) } if (inherits(new, "error")) stop(new) yaml_config <<- new } yaml_config } set_yaml_config <- function(text) { if (length(text) == 1) text <- strsplit(text, "\n", fixed = TRUE)[[1]] yaml_config <<- text } get_release_version <- function(forget = FALSE) { if (forget || is.null(release_version)) { yaml <- get_yaml_config(forget) pattern <- "^release_version: \"(.*)\"" release_version <<- package_version( sub(pattern, "\\1", grep(pattern, yaml, value=TRUE)) ) } release_version } get_devel_version <- function(forget = FALSE) { if (forget || is.null(devel_version)) { yaml <- get_yaml_config(forget) pattern <- "^devel_version: \"(.*)\"" devel_version <<- package_version( sub(pattern, "\\1", grep(pattern, yaml, value=TRUE)) ) } devel_version } get_version_map <- function(forget = FALSE) { if (forget || is.null(version_map)) { txt <- get_yaml_config(forget) grps <- grep("^[^[:blank:]]", txt) start <- match(grep("r_ver_for_bioc_ver", txt), grps) map <- txt[seq(grps[start] + 1, grps[start + 1] - 1)] map <- trimws(gsub("\"", "", sub(" #.*", "", map))) pattern <- "(.*): (.*)" bioc <- package_version(sub(pattern, "\\1", map)) r <- package_version(sub(pattern, "\\2", map)) status <- rep("out-of-date", length(bioc)) release <- get_release_version() devel <- get_devel_version() status[bioc == release] <- "release" status[bioc == devel] <- "devel" # append final version for 'devel' R bioc <- c( bioc, max(bioc) ) r <- c(r, package_version(paste(unlist(max(r)) + 0:1, collapse = "."))) status <- c(status, "future") version_map <<- rbind( .VERSION_MAP_SENTINEL, data.frame( bioc_version = bioc, r_version = r, bioc_status = factor( status, levels = c("out-of-date", "release", "devel", "future") ) ) ) } version_map } get_matching_bioc_version <- function(r_version = getRversion(), forget = FALSE) { minor <- as.character(get_minor_r_version(r_version)) if (minor %in% names(builtin_map)) return(builtin_map[[minor]]) # If we are not in the map, then we need to look this up in # YAML data. It is possible that the current R version matches multiple # Bioc versions. Then we choose the latest released version. If none # of them were released (e.g. they are 'devel' and 'future'), then # we'll use the 'devel' version. map <- get_version_map(forget = forget) mine <- which(package_version(minor) == map$r_version) if (length(mine) == 0) { mine <- NA } else if (length(mine) > 1) { if ("release" %in% map$bioc_status[mine]) { mine <- mine["release" == map$bioc_status[mine]] } else if ("devel" %in% map$bioc_status[mine]) { mine <- mine["devel" == map$bioc_status[mine]] } else { mine <- rev(mine)[1] } } if (!is.na(mine)) return(map$bioc_version[mine]) # If it is not even in the YAML, then it must be some very old # or very new version. If old, we fail. If new, we assume bioc-devel. if (package_version(minor) < "2.1") { stop("R version too old, cannot run Bioconductor") } get_devel_version() } get_bioc_version <- function(r_version = getRversion(), forget = FALSE) { if (nzchar(v <- Sys.getenv("R_BIOC_VERSION", ""))) { return(package_version(v)) } get_matching_bioc_version(r_version, forget = forget) } get_repos <- function(bioc_version = "auto", forget = FALSE) { if (identical(bioc_version, "auto")) { bioc_version <- get_bioc_version(getRversion(), forget) } else { bioc_version <- package_version(bioc_version) } mirror <- Sys.getenv("R_BIOC_MIRROR", "https://bioconductor.org") mirror <- getOption("BioC_mirror", mirror) repos <- c( BioCsoft = "{mirror}/packages/{bv}/bioc", BioCann = "{mirror}/packages/{bv}/data/annotation", BioCexp = "{mirror}/packages/{bv}/data/experiment", BioCworkflows = if (bioc_version >= "3.7") "{mirror}/packages/{bv}/workflows", BioCextra = if (bioc_version <= "3.5") "{mirror}/packages/{bv}/extra", BioCbooks = if (bioc_version >= "3.12") "{mirror}/packages/{bv}/books" ) ## It seems that if a repo is not available yet for bioc-devel, ## they redirect to the bioc-release version, so we do not need to ## parse devel_repos from the config.yaml file sub("{mirror}", mirror, fixed = TRUE, sub("{bv}", bioc_version, repos, fixed = TRUE)) } # ------------------------------------------------------------------- # Internals read_url <- function(url) { tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) suppressWarnings(download.file(url, tmp, quiet = TRUE)) if (!file.exists(tmp) || file.info(tmp)$size == 0) { stop("Failed to download `", url, "`") } readLines(tmp, warn = FALSE) } .VERSION_SENTINEL <- local({ version <- package_version(character()) class(version) <- c("unknown_version", class(version)) version }) .VERSION_MAP_SENTINEL <- data.frame( bioc_version = .VERSION_SENTINEL, r_version = .VERSION_SENTINEL, bioc_status = factor( factor(), levels = c("out-of-date", "release", "devel", "future") ) ) get_minor_r_version <- function (x) { package_version(x)[,1:2] } # ------------------------------------------------------------------- structure( list( .internal = environment(), get_yaml_config = get_yaml_config, set_yaml_config = set_yaml_config, get_release_version = get_release_version, get_devel_version = get_devel_version, get_version_map = get_version_map, get_matching_bioc_version = get_matching_bioc_version, get_bioc_version = get_bioc_version, get_repos = get_repos ), class = c("standalone_bioc", "standalone")) }) # Contents of R/bioc.R #' @export #' @rdname bioc_install_repos #' @keywords internal #' @examples #' bioc_version() #' bioc_version("3.4") bioc_version <- function(r_ver = getRversion()) { bioconductor$get_bioc_version(r_ver) } #' Tools for Bioconductor repositories #' #' `bioc_version()` returns the Bioconductor version for the current or the #' specified R version. #' #' `bioc_install_repos()` deduces the URLs of the Bioconductor repositories. #' #' @details #' Both functions observe the `R_BIOC_VERSION` environment variable, which #' can be set to force a Bioconductor version. If this is set, then the #' `r_ver` and `bioc_ver` arguments are ignored. #' #' `bioc_install_repos()` observes the `R_BIOC_MIRROR` environment variable #' and also the `BioC_mirror` option, which can be set to the desired #' Bioconductor mirror. The option takes precedence if both are set. Its #' default value is `https://bioconductor.org`. #' #' @return #' `bioc_version()` returns a Bioconductor version, a `package_version` #' object. #' #' `bioc_install_repos()` returns a named character vector of the URLs of #' the Bioconductor repositories, appropriate for the current or the #' specified R version. #' #' @param r_ver R version to use. For `bioc_install_repos()` it is #' ignored if `bioc_ver` is specified. #' @param bioc_ver Bioconductor version to use. Defaults to the default one #' corresponding to `r_ver`. #' #' @export #' @keywords internal #' @examples #' bioc_install_repos() bioc_install_repos <- function(r_ver = getRversion(), bioc_ver = bioc_version(r_ver)) { bioconductor$get_repos(bioc_ver) } # Contents of R/circular.R ## A environment to hold which packages are being installed so packages ## with circular dependencies can be skipped the second time. installing <- new.env(parent = emptyenv()) is_root_install <- function() is.null(installing$packages) exit_from_root_install <- function() installing$packages <- NULL check_for_circular_dependencies <- function(pkgdir, quiet) { pkgdir <- normalizePath(pkgdir) pkg <- get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package") if (pkg %in% installing$packages) { if (!quiet) message("Skipping ", pkg, ", it is already being installed") TRUE } else { installing$packages <- c(installing$packages, pkg) FALSE } } # Contents of R/cran.R cache <- new.env(parent = emptyenv()) #' @rdname available_packages #' @export available_packages_set <- function(repos, type, db) { signature <- rawToChar(serialize(list(repos, type), NULL, ascii = TRUE)) if (is.null(cache[[signature]])) { cache[[signature]] <- db } cache[[signature]] } #' @rdname available_packages #' @export available_packages_reset <- function() { rm(list = ls(envir = cache), envir = cache) } #' Simpler available.packages #' #' This is mostly equivalent to [utils::available.packages()] however it also #' caches the full result. Additionally the cache can be assigned explicitly with #' [available_packages_set()] and reset (cleared) with [available_packages_reset()]. #' #' @inheritParams utils::available.packages #' @keywords internal #' @seealso [utils::available.packages()] for full documentation on the output format. #' @export available_packages <- function(repos = getOption("repos"), type = getOption("pkgType")) { available_packages_set( repos, type, suppressWarnings(utils::available.packages(utils::contrib.url(repos, type), type = type)) ) } # Contents of R/dcf.R read_dcf <- function(path) { fields <- colnames(read.dcf(path)) as.list(read.dcf(path, keep.white = fields)[1, ]) } write_dcf <- function(path, desc) { write.dcf( rbind(unlist(desc)), file = path, keep.white = names(desc), indent = 0 ) } get_desc_field <- function(path, field) { dcf <- read_dcf(path) dcf[[field]] } # Contents of R/decompress.R # Decompress pkg, if needed source_pkg <- function(path, subdir = NULL) { if (!dir.exists(path)) { bundle <- path outdir <- tempfile(pattern = "remotes") dir.create(outdir) path <- decompress(path, outdir) } else { bundle <- NULL } pkg_path <- if (is.null(subdir)) path else file.path(path, subdir) # Check it's an R package if (!file.exists(file.path(pkg_path, "DESCRIPTION"))) { stop("Does not appear to be an R package (no DESCRIPTION)", call. = FALSE) } # Check configure is executable if present config_path <- file.path(pkg_path, "configure") if (file.exists(config_path)) { Sys.chmod(config_path, "777") } pkg_path } decompress <- function(src, target) { stopifnot(file.exists(src)) if (grepl("\\.zip$", src)) { my_unzip(src, target) outdir <- getrootdir(as.vector(utils::unzip(src, list = TRUE)$Name)) } else if (grepl("\\.(tar|tar\\.gz|tar\\.bz2|tgz|tbz)$", src)) { untar(src, exdir = target) outdir <- getrootdir(untar(src, list = TRUE)) } else { ext <- gsub("^[^.]*\\.", "", src) stop("Don't know how to decompress files with extension ", ext, call. = FALSE) } file.path(target, outdir) } # Returns everything before the last slash in a filename # getdir("path/to/file") returns "path/to" # getdir("path/to/dir/") returns "path/to/dir" getdir <- function(path) sub("/[^/]*$", "", path) # Given a list of files, returns the root (the topmost folder) # getrootdir(c("path/to/file", "path/to/other/thing")) returns "path/to" # It does not check that all paths have a common prefix. It fails for # empty input vector. It assumes that directories end with '/'. getrootdir <- function(file_list) { stopifnot(length(file_list) > 0) slashes <- nchar(gsub("[^/]", "", file_list)) if (min(slashes) == 0) return(".") getdir(file_list[which.min(slashes)]) } my_unzip <- function(src, target, unzip = getOption("unzip", "internal")) { if (unzip %in% c("internal", "")) { return(utils::unzip(src, exdir = target)) } args <- paste( "-oq", shQuote(src), "-d", shQuote(target) ) system_check(unzip, args) } # Contents of R/deps.R #' Find all dependencies of a CRAN or dev package. #' #' Find all the dependencies of a package and determine whether they are ahead #' or behind CRAN. A `print()` method identifies mismatches (if any) #' between local and CRAN versions of each dependent package; an #' `update()` method installs outdated or missing packages from CRAN. #' #' @param packages A character vector of package names. #' @param pkgdir Path to a package directory, or to a package tarball. #' @param dependencies Which dependencies do you want to check? #' Can be a character vector (selecting from "Depends", "Imports", #' "LinkingTo", "Suggests", or "Enhances"), or a logical vector. #' #' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and #' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo" #' and is the default. `FALSE` is shorthand for no dependencies (i.e. #' just check this package, not its dependencies). #' #' The value "soft" means the same as `TRUE`, "hard" means the same as `NA`. #' #' You can also specify dependencies from one or more additional fields, #' common ones include: #' - Config/Needs/website - for dependencies used in building the pkgdown site. #' - Config/Needs/coverage for dependencies used in calculating test coverage. #' @param quiet If `TRUE`, suppress output. #' @param upgrade Should package dependencies be upgraded? One of "default", "ask", "always", or "never". "default" #' respects the value of the `R_REMOTES_UPGRADE` environment variable if set, #' and falls back to "ask" if unset. "ask" prompts the user for which out of #' date packages to upgrade. For non-interactive sessions "ask" is equivalent #' to "always". `TRUE` and `FALSE` are also accepted and correspond to #' "always" and "never" respectively. #' @param repos A character vector giving repositories to use. #' @param type Type of package to `update`. #' @param remote_precedence A logical flag specifying whether remote sources should take precedence over #' CRAN when both were found. #' @param additional_repositories A logical flag specifying whether `Additional_repositories` should #' be extracted from the DESCRIPTION and appended to `repos`. #' @param object A `package_deps` object. #' @param ... Additional arguments passed to `install_packages`. #' @inheritParams install_github #' #' @return #' #' A `data.frame` with columns: #' #' \tabular{ll}{ #' `package` \tab The dependent package's name,\cr #' `installed` \tab The currently installed version,\cr #' `available` \tab The version available on CRAN,\cr #' `diff` \tab An integer denoting whether the locally installed version #' of the package is newer (1), the same (0) or older (-1) than the version #' currently available on CRAN.\cr #' } #' #' @export #' @examples #' \dontrun{ #' package_deps("devtools") #' # Use update to update any out-of-date dependencies #' update(package_deps("devtools")) #' } package_deps <- function(packages, dependencies = NA, repos = getOption("repos"), type = getOption("pkgType")) { repos <- fix_repositories(repos) cran <- available_packages(repos, type) deps <- find_deps(packages, available = cran, top_dep = dependencies) # Remove base packages inst <- utils::installed.packages() base <- unname(inst[inst[, "Priority"] %in% c("base", "recommended"), "Package"]) deps <- setdiff(deps, base) # get remote types remote <- structure(lapply(deps, package2remote, repos = repos, type = type), class = "remotes") inst_ver <- vapply(deps, local_sha, character(1)) cran_ver <- vapply(remote, function(x) remote_sha(x), character(1)) is_cran_remote <- vapply(remote, inherits, logical(1), "cran_remote") diff <- compare_versions(inst_ver, cran_ver, is_cran_remote) res <- structure( data.frame( package = deps, installed = inst_ver, available = cran_ver, diff = diff, is_cran = is_cran_remote, stringsAsFactors = FALSE ), class = c("package_deps", "data.frame") ) res$remote <- remote res } #' `local_package_deps` extracts dependencies from a #' local DESCRIPTION file. #' #' @export #' @rdname package_deps local_package_deps <- function(pkgdir = ".", dependencies = NA) { pkg <- load_pkg_description(pkgdir) dependencies <- tolower(standardise_dep(dependencies)) dependencies <- intersect(dependencies, names(pkg)) parsed <- lapply(pkg[tolower(dependencies)], parse_deps) unlist(lapply(parsed, `[[`, "name"), use.names = FALSE) } #' `dev_package_deps` lists the status of the dependencies #' of a local package. #' #' @export #' @rdname package_deps dev_package_deps <- function(pkgdir = ".", dependencies = NA, repos = getOption("repos"), type = getOption("pkgType"), remote_precedence = TRUE, additional_repositories = TRUE) { pkg <- load_pkg_description(pkgdir) repos <- c(repos, if (additional_repositories) parse_additional_repositories(pkg)) deps <- local_package_deps(pkgdir = pkgdir, dependencies = dependencies) if (is_bioconductor(pkg)) { bioc_repos <- bioc_install_repos() missing_repos <- setdiff(names(bioc_repos), names(repos)) if (length(missing_repos) > 0) repos[missing_repos] <- bioc_repos[missing_repos] } cran_deps <- package_deps(deps, repos = repos, type = type) res <- combine_remote_deps(cran_deps, extra_deps(pkg, "remotes"), remote_precedence) res <- do.call(rbind, c(list(res), lapply(get_extra_deps(pkg, dependencies), extra_deps, pkg = pkg), stringsAsFactors = FALSE)) res[is.na(res$package) | !duplicated(res$package, fromLast = TRUE), ] } combine_remote_deps <- function(cran_deps, remote_deps, remote_precedence) { # If there are no dependencies there will be no remote dependencies either, # so just return them (and don't force the remote_deps promise) if (nrow(cran_deps) == 0) { return(cran_deps) } # Only keep the remotes that are specified in the cran_deps or are NA remote_deps <- remote_deps[is.na(remote_deps$package) | remote_deps$package %in% cran_deps$package, ] # If there are remote deps remove the equivalent CRAN deps if (remote_precedence) { cran_deps <- cran_deps[!(cran_deps$package %in% remote_deps$package), ] # Otherwise remove remotes already covered by CRAN } else { remote_deps <- remote_deps[!(remote_deps$package %in% cran_deps$package), ] } rbind(remote_deps, cran_deps) } ## -2 = not installed, but available on CRAN ## -1 = installed, but out of date ## 0 = installed, most recent version ## 1 = installed, version ahead of CRAN ## 2 = package not on CRAN compare_versions <- function(inst, remote, is_cran) { stopifnot(length(inst) == length(remote) && length(inst) == length(is_cran)) compare_var <- function(i, c, cran) { if (!cran) { if (identical(i, c)) { return(CURRENT) } else { return(BEHIND) } } if (is.na(c)) return(UNAVAILABLE) # not on CRAN if (is.na(i)) return(UNINSTALLED) # not installed, but on CRAN i <- package_version(i) c <- package_version(c) if (i < c) { BEHIND # out of date } else if (i > c) { AHEAD # ahead of CRAN } else { CURRENT # most recent CRAN version } } vapply(seq_along(inst), function(i) compare_var(inst[[i]], remote[[i]], is_cran[[i]]), integer(1)) } has_extra_deps <- function(pkg, dependencies) { any(dependencies %in% names(pkg)) } get_extra_deps <- function(pkg, dependencies) { dependencies <- tolower(dependencies) dependencies <- intersect(dependencies, names(pkg)) #remove standard dependencies setdiff(dependencies, tolower(standardise_dep(c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances")))) } #' @export print.package_deps <- function(x, show_ok = FALSE, ...) { class(x) <- "data.frame" x$remote <-lapply(x$remote, format) ahead <- x$diff > 0L behind <- x$diff < 0L same_ver <- x$diff == 0L x$diff <- NULL x[] <- lapply(x, format_str, width = 12) if (any(behind)) { cat("Needs update -----------------------------\n") print(x[behind, , drop = FALSE], row.names = FALSE, right = FALSE) } if (any(ahead)) { cat("Not on CRAN ----------------------------\n") print(x[ahead, , drop = FALSE], row.names = FALSE, right = FALSE) } if (show_ok && any(same_ver)) { cat("OK ---------------------------------------\n") print(x[same_ver, , drop = FALSE], row.names = FALSE, right = FALSE) } } ## -2 = not installed, but available on CRAN ## -1 = installed, but out of date ## 0 = installed, most recent version ## 1 = installed, version ahead of CRAN ## 2 = package not on CRAN UNINSTALLED <- -2L BEHIND <- -1L CURRENT <- 0L AHEAD <- 1L UNAVAILABLE <- 2L #' @export #' @rdname package_deps #' @importFrom stats update update.package_deps <- function(object, dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { dependencies <- standardise_dep(dependencies) object <- upgradable_packages(object, upgrade, quiet) unavailable_on_cran <- object$diff == UNAVAILABLE & object$is_cran unknown_remotes <- (object$diff == UNAVAILABLE | object$diff == UNINSTALLED) & !object$is_cran if (any(unavailable_on_cran) && !quiet) { message("Skipping ", sum(unavailable_on_cran), " packages not available: ", paste(object$package[unavailable_on_cran], collapse = ", ")) } if (any(unknown_remotes)) { install_remotes(object$remote[unknown_remotes], dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } ahead_of_cran <- object$diff == AHEAD & object$is_cran if (any(ahead_of_cran) && !quiet) { message("Skipping ", sum(ahead_of_cran), " packages ahead of CRAN: ", paste(object$package[ahead_of_cran], collapse = ", ")) } ahead_remotes <- object$diff == AHEAD & !object$is_cran if (any(ahead_remotes)) { install_remotes(object$remote[ahead_remotes], dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } behind <- is.na(object$installed) | object$diff < CURRENT if (any(object$is_cran & !unavailable_on_cran & behind)) { # get the first cran-like remote and use its repos and pkg_type r <- object$remote[object$is_cran & behind][[1]] install_packages(object$package[object$is_cran & behind], repos = r$repos, type = r$pkg_type, dependencies = dependencies, quiet = quiet, ...) } install_remotes(object$remote[!object$is_cran & behind], dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) invisible() } install_packages <- function(packages, repos = getOption("repos"), type = getOption("pkgType"), ..., dependencies = FALSE, quiet = NULL) { # We want to pass only args that exist in the downstream functions args_to_keep <- unique( names( c( formals(utils::install.packages), formals(utils::download.file) ) ) ) args <- list(...) args <- args[names(args) %in% args_to_keep] if (is.null(quiet)) quiet <- !identical(type, "source") message("Installing ", length(packages), " packages: ", paste(packages, collapse = ", ")) do.call( safe_install_packages, c(list( packages, repos = repos, type = type, dependencies = dependencies, quiet = quiet ), args ) ) } find_deps <- function(packages, available = available_packages(), top_dep = TRUE, rec_dep = NA, include_pkgs = TRUE) { if (length(packages) == 0 || identical(top_dep, FALSE)) return(character()) top_dep <- standardise_dep(top_dep) rec_dep <- standardise_dep(rec_dep) top <- tools::package_dependencies(packages, db = available, which = top_dep) top_flat <- unlist(top, use.names = FALSE) if (length(rec_dep) != 0 && length(top_flat) > 0) { rec <- tools::package_dependencies(top_flat, db = available, which = rec_dep, recursive = TRUE) rec_flat <- unlist(rec, use.names = FALSE) } else { rec_flat <- character() } # We need to return these in reverse order, so that the packages furthest # down in the tree are installed first. unique(rev(c(if (include_pkgs) packages, top_flat, rec_flat))) } #' Standardise dependencies using the same logical as [install.packages] #' #' @param x The dependencies to standardise. #' A character vector (selecting from "Depends", "Imports", #' "LinkingTo", "Suggests", or "Enhances"), or a logical vector. #' #' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and #' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo" #' and is the default. `FALSE` is shorthand for no dependencies. #' #' The value "soft" means the same as `TRUE`, "hard" means the same as `NA`. #' #' Any additional values that don't match one of the standard dependency #' types are filtered out. #' #' @seealso for #' additional information on what each dependency type means. #' @keywords internal #' @export standardise_dep <- function(x) { if (identical(x, NA)) { c("Depends", "Imports", "LinkingTo") } else if (isTRUE(x)) { c("Depends", "Imports", "LinkingTo", "Suggests") } else if (identical(x, FALSE)) { character(0) } else if (is.character(x)) { if (any(x == "hard")) { c("Depends", "Imports", "LinkingTo") } else if (any(x == "soft")) { c("Depends", "Imports", "LinkingTo", "Suggests") } else { intersect(x, c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances")) } } else { stop("Dependencies must be a boolean or a character vector", call. = FALSE) } } #' Update packages that are missing or out-of-date. #' #' Works similarly to [utils::install.packages()] but doesn't install packages #' that are already installed, and also upgrades out dated dependencies. #' #' @param packages Character vector of packages to update. #' @param force Deprecated, this argument has no effect. #' @inheritParams install_github #' @seealso [package_deps()] to see which packages are out of date/ #' missing. #' @export #' @examples #' \dontrun{ #' update_packages("ggplot2") #' update_packages(c("plyr", "ggplot2")) #' } update_packages <- function(packages = TRUE, dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { if (isTRUE(force)) { .Deprecated(msg = "`update_packages(force = TRUE)` is deprecated and has no effect.") } if (isTRUE(packages)) { packages <- utils::installed.packages()[, "Package"] } pkgs <- package_deps(packages, repos = repos, type = type) update(pkgs, dependencies = dependencies, upgrade = upgrade, force = FALSE, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } has_additional_repositories <- function(pkg) { "additional_repositories" %in% names(pkg) } parse_additional_repositories <- function(pkg) { if (has_additional_repositories(pkg)) { strsplit(trim_ws(pkg[["additional_repositories"]]), "[,[:space:]]+")[[1]] } } fix_repositories <- function(repos) { if (length(repos) == 0) repos <- character() # Override any existing default values with the cloud mirror # Reason: A "@CRAN@" value would open a GUI for choosing a mirror repos[repos == "@CRAN@"] <- download_url("cloud.r-project.org") repos } parse_one_extra <- function(x, ...) { pieces <- strsplit(x, "::", fixed = TRUE)[[1]] if (length(pieces) == 1) { if (!grepl("/", pieces)) { type <- "cran" } else { type <- "github" } repo <- pieces } else if (length(pieces) == 2) { type <- pieces[1] repo <- pieces[2] } else { stop("Malformed remote specification '", x, "'", call. = FALSE) } type = sub("^[.a-zA-Z0-9]+=", "", type) if (grepl("@", type)) { # Custom host tah <- strsplit(type, "@", fixed = TRUE)[[1]] type <- tah[1] host <- tah[2] } else { host <- NULL } tryCatch({ # We need to use `environment(sys.function())` instead of # `asNamespace("remotes")` because when used as a script in # install-github.R there is no remotes namespace. fun <- get(paste0(tolower(type), "_remote"), mode = "function", inherits = TRUE) if (!is.null(host)) { res <- fun(repo, host = host, ...) } else { res <- fun(repo, ...) } }, error = function(e) stop("Unknown remote type: ", type, "\n ", conditionMessage(e), call. = FALSE) ) res } split_extra_deps <- function(x, name = "Remotes") { pkgs <- trim_ws(unlist(strsplit(x, ",[[:space:]]*"))) if (any((res <- grep("[[:space:]]+", pkgs)) != -1)) { stop("Missing commas separating ", name, ": '", pkgs[res], "'", call. = FALSE) } pkgs } package_deps_new <- function(package = character(), installed = character(), available = character(), diff = logical(), is_cran = logical(), remote = list()) { res <- structure( data.frame(package = package, installed = installed, available = available, diff = diff, is_cran = is_cran, stringsAsFactors = FALSE), class = c("package_deps", "data.frame") ) res$remote = structure(remote, class = "remotes") res } extra_deps <- function(pkg, field) { if (!has_extra_deps(pkg, field)) { return(package_deps_new()) } dev_packages <- split_extra_deps(pkg[[field]]) extra <- lapply(dev_packages, parse_one_extra) package <- vapply(extra, function(x) remote_package_name(x), character(1), USE.NAMES = FALSE) installed <- vapply(package, function(x) local_sha(x), character(1), USE.NAMES = FALSE) available <- vapply(extra, function(x) remote_sha(x), character(1), USE.NAMES = FALSE) diff <- installed == available diff <- ifelse(!is.na(diff) & diff, CURRENT, BEHIND) diff[is.na(installed)] <- UNINSTALLED is_cran_remote <- vapply(extra, inherits, logical(1), "cran_remote") package_deps_new(package, installed, available, diff, is_cran = is_cran_remote, extra) } # interactive is an argument to make testing easier. resolve_upgrade <- function(upgrade, is_interactive = interactive()) { if (isTRUE(upgrade)) { upgrade <- "always" } else if (identical(upgrade, FALSE)) { upgrade <- "never" } upgrade <- match.arg(upgrade[[1]], c("default", "ask", "always", "never")) if (identical(upgrade, "default")) upgrade <- Sys.getenv("R_REMOTES_UPGRADE", unset = "ask") if (!is_interactive && identical(upgrade, "ask")) { upgrade <- "always" } upgrade } upgradable_packages <- function(x, upgrade, quiet, is_interactive = interactive()) { uninstalled <- x$diff == UNINSTALLED behind <- x$diff == BEHIND switch(resolve_upgrade(upgrade, is_interactive = is_interactive), always = { return(msg_upgrades(x, quiet)) }, never = return(x[uninstalled, ]), ask = { if (!any(behind)) { return(x) } pkgs <- format_upgrades(x[behind, ]) choices <- pkgs if (length(choices) > 0) { choices <- c("All", "CRAN packages only", "None", choices) } res <- select_menu(choices, title = "These packages have more recent versions available.\nIt is recommended to update all of them.\nWhich would you like to update?") if ("None" %in% res || length(res) == 0) { return(x[uninstalled, ]) } if ("All" %in% res) { wch <- seq_len(NROW(x)) } else { if ("CRAN packages only" %in% res) { wch <- uninstalled | (behind & x$is_cran) } else { wch <- sort(c(which(uninstalled), which(behind)[pkgs %in% res])) } } msg_upgrades(x[wch, ], quiet) } ) } select_menu <- function(choices, title = NULL, msg = "Enter one or more numbers, or an empty line to skip updates: ", width = getOption("width")) { if (!is.null(title)) { cat(title, "\n", sep = "") } nc <- length(choices) op <- paste0(format(seq_len(nc)), ": ", choices) fop <- format(op) cat("", fop, "", sep = "\n") repeat { answer <- readline(msg) answer <- strsplit(answer, "[ ,]+")[[1]] if (all(answer %in% seq_along(choices))) { return(choices[as.integer(answer)]) } } } msg_upgrades <- function(x, quiet) { if (isTRUE(quiet) || nrow(x) == 0) { return(invisible(x)) } cat(format_upgrades(x[x$diff <= BEHIND, ]), sep = "\n") invisible(x) } format_upgrades <- function(x) { if (nrow(x) == 0) { return(character(0)) } remote_type <- lapply(x$remote, format) # This call trims widths to 12 characters x[] <- lapply(x, format_str, width = 12) # This call aligns the columns x[] <- lapply(x, format, trim = FALSE, justify = "left") pkgs <- paste0(x$package, " (", x$installed, " -> ", x$available, ") ", "[", remote_type, "]") pkgs } # Contents of R/devel.R ## The checking code looks for the objects in the package namespace, so defining ## dll here removes the following NOTE ## Registration problem: ## Evaluating ‘dll$foo’ during check gives error ## ‘object 'dll' not found’: ## .C(dll$foo, 0L) ## See https://github.com/wch/r-source/blob/d4e8fc9832f35f3c63f2201e7a35fbded5b5e14c/src/library/tools/R/QC.R##L1950-L1980 ## Setting the class is needed to avoid a note about returning the wrong class. ## The local object is found first in the actual call, so current behavior is ## unchanged. dll <- list(foo = structure(list(), class = "NativeSymbolInfo")) has_devel <- function() { tryCatch( has_devel2(), error = function(e) FALSE ) } ## This is similar to devtools:::has_devel(), with some ## very minor differences. has_devel2 <- function() { foo_path <- file.path(tempfile(fileext = ".c")) cat("void foo(int *bar) { *bar=1; }\n", file = foo_path) on.exit(unlink(foo_path)) R(c("CMD", "SHLIB", basename(foo_path)), dirname(foo_path)) dylib <- sub("\\.c$", .Platform$dynlib.ext, foo_path) on.exit(unlink(dylib), add = TRUE) dll <- dyn.load(dylib) on.exit(dyn.unload(dylib), add = TRUE) stopifnot(.C(dll$foo, 0L)[[1]] == 1L) TRUE } missing_devel_warning <- function(pkgdir) { pkgname <- tryCatch( get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package"), error = function(e) NULL ) %||% "" sys <- sys_type() warning( "Package ", pkgname, " has compiled code, but no suitable ", "compiler(s) were found. Installation will likely fail.\n ", if (sys == "windows") { c("Install Rtools (https://cran.r-project.org/bin/windows/Rtools/).", "Then use the pkgbuild package, or make sure that Rtools in the PATH.") }, if (sys == "macos") "Install XCode and make sure it works.", if (sys == "linux") "Install compilers via your Linux package manager." ) } R <- function(args, path = tempdir()) { r <- file.path(R.home("bin"), "R") args <- c( "--no-site-file", "--no-environ", "--no-save", "--no-restore", "--quiet", args ) system_check(r, args, path = path) } # Contents of R/download.R #' Download a file #' #' Uses either the curl package for R versions older than 3.2.0, #' otherwise a wrapper around [download.file()]. #' #' We respect the `download.file.method` setting of the user. If it is #' not set, then see `download_method()` for choosing a method. #' #' Authentication can be supplied three ways: #' * By setting `auth_token`. This will append an HTTP `Authorization` #' header: `Authorization: token {auth_token}`. #' * By setting `basic_auth` to a list with elements `user` and `password`. #' This will append a proper `Authorization: Basic {encoded_password}` #' HTTP header. #' * By specifying the proper `headers` directly. #' #' If both `auth_token` and `basic_auth` are specified, that's an error. #' `auth_token` and `basic_auth` are _appended_ to `headers`, so they #' take precedence over an `Authorization` header that is specified #' directly in `headers`. #' #' @param path Path to download to. `dirname(path)` must exist. #' @param url URL. #' @param auth_token Token for token-based authentication or `NULL`. #' @param basic_auth List with `user` and `password` for basic HTTP #' authentication, or `NULL`. #' @param quiet Passed to [download.file()] or [curl::curl_download()]. #' @param headers Named character vector of HTTP headers to use. #' @return `path`, if the download was successful. #' #' @keywords internal #' @importFrom utils compareVersion download <- function(path, url, auth_token = NULL, basic_auth = NULL, quiet = TRUE, headers = NULL) { if (!is.null(basic_auth) && !is.null(auth_token)) { stop("Cannot use both Basic and Token authentication at the same time") } if (!is.null(basic_auth)) { userpass <- paste0(basic_auth$user, ":", basic_auth$password) auth <- paste("Basic", base64_encode(charToRaw(userpass))) headers <- c(headers, Authorization = auth) } if (!is.null(auth_token)) { headers <- c(headers, Authorization = paste("token", auth_token)) } if (getRversion() < "3.2.0") { curl_download(url, path, quiet, headers) } else { base_download(url, path, quiet, headers) } path } base_download <- function(url, path, quiet, headers) { method <- download_method() status <- if (method == "wget") { base_download_wget(url, path, quiet, headers) } else if (method =="curl") { base_download_curl(url, path, quiet, headers) } else if (getRversion() < "3.6.0") { base_download_noheaders(url, path, quiet, headers, method) } else { base_download_headers(url, path, quiet, headers, method) } if (status != 0) stop("Cannot download file from ", url, call. = FALSE) path } base_download_wget <- function(url, path, quiet, headers) { extra <- getOption("download.file.extra") if (length(headers)) { qh <- shQuote(paste0(names(headers), ": ", headers)) extra <- c(extra, paste0("--header=", qh)) } with_options( list(download.file.extra = extra), suppressWarnings( utils::download.file( url, path, method = "wget", quiet = quiet, mode = "wb", extra = extra ) ) ) } base_download_curl <- function(url, path, quiet, headers) { extra <- getOption("download.file.extra") # always add `-L`, so that curl follows redirects. GitHub in particular uses # 302 redirects extensively, so without -L these requests fail. extra <- c(extra, "--fail", "-L") if (length(headers)) { qh <- shQuote(paste0(names(headers), ": ", headers)) extra <- c(extra, paste("-H", qh)) } with_options( list(download.file.extra = extra), suppressWarnings( utils::download.file( url, path, method = "curl", quiet = quiet, mode = "wb", extra = extra ) ) ) } base_download_noheaders <- function(url, path, quiet, headers, method) { if (length(headers)) { if (method == "wininet" && getRversion() < "3.6.0") { warning(paste( "R (< 3.6.0) cannot send HTTP headers with the `wininet` download method.", "This download will likely fail. Please choose a different download", "method, via the `download.file.method` option. The `libcurl` method is", "best, if available, and the `wget` and `curl` methods work as well,", "if the corresponding external tool is available. See `?download.file`")) } get("unlockBinding", baseenv())("makeUserAgent", asNamespace("utils")) orig <- get("makeUserAgent", envir = asNamespace("utils")) on.exit({ assign("makeUserAgent", orig, envir = asNamespace("utils")) lockBinding("makeUserAgent", asNamespace("utils")) }, add = TRUE) ua <- orig(FALSE) flathead <- paste0(names(headers), ": ", headers, collapse = "\r\n") agent <- paste0(ua, "\r\n", flathead) assign( "makeUserAgent", envir = asNamespace("utils"), function(format = TRUE) { if (format) { paste0("User-Agent: ", agent, "\r\n") } else { agent } }) } suppressWarnings( utils::download.file( url, path, method = method, quiet = quiet, mode = "wb" ) ) } base_download_headers <- function(url, path, quiet, headers, method) { suppressWarnings( utils::download.file( url, path, method = method, quiet = quiet, mode = "wb", headers = headers ) ) } has_curl <- function() isTRUE(unname(capabilities("libcurl"))) download_method <- function() { user_option <- getOption("download.file.method") if (!is.null(user_option)) { ## The user wants what the user wants user_option } else if (has_curl()) { ## If we have libcurl, it is usually the best option "libcurl" } else if (compareVersion(get_r_version(), "3.3") == -1 && os_type() == "windows") { ## Before 3.3 we select wininet on Windows "wininet" } else { ## Otherwise this is probably hopeless, but let R select, and ## try something "auto" } } curl_download <- function(url, path, quiet, headers) { if (!pkg_installed("curl")) { stop("The 'curl' package is required if R is older than 3.2.0") } handle <- curl::new_handle() if (!is.null(headers)) curl::handle_setheaders(handle, .list = headers) curl::curl_download(url, path, quiet = quiet, mode = "wb", handle = handle) } true_download_method <- function(x) { if (identical(x, "auto")) { auto_download_method() } else { x } } auto_download_method <- function() { if (isTRUE(capabilities("libcurl"))) { "libcurl" } else if (isTRUE(capabilities("http/ftp"))) { "internal" } else if (nzchar(Sys.which("wget"))) { "wget" } else if (nzchar(Sys.which("curl"))) { "curl" } else { "" } } download_method_secure <- function() { method <- true_download_method(download_method()) if (method %in% c("wininet", "libcurl", "wget", "curl")) { # known good methods TRUE } else if (identical(method, "internal")) { # only done before R 3.3 if (utils::compareVersion(get_r_version(), "3.3") == -1) { # if internal then see if were using windows internal with inet2 identical(Sys.info()[["sysname"]], "Windows") && utils::setInternet2(NA) } else { FALSE } } else { # method with unknown properties (e.g. "lynx") or unresolved auto FALSE } } # Contents of R/git-auth.R # nocov start gitcreds_get <- NULL gitcreds_set <- NULL gitcreds_delete <- NULL gitcreds_list_helpers <- NULL gitcreds_cache_envvar <- NULL gitcreds_fill <- NULL gitcreds_approve <- NULL gitcreds_reject <- NULL gitcreds_parse_output <- NULL gitcreds <- local({ # ------------------------------------------------------------------------ # Public API # ------------------------------------------------------------------------ gitcreds_get <<- function(url = "https://github.com", use_cache = TRUE, set_cache = TRUE) { stopifnot( is_string(url), has_no_newline(url), is_flag(use_cache), is_flag(set_cache) ) cache_ev <- gitcreds_cache_envvar(url) if (use_cache && !is.null(ans <- gitcreds_get_cache(cache_ev))) { return(ans) } check_for_git() out <- gitcreds_fill(list(url = url), dummy = TRUE) creds <- gitcreds_parse_output(out, url) if (set_cache) { gitcreds_set_cache(cache_ev, creds) } creds } gitcreds_set <<- function(url = "https://github.com") { if (!is_interactive()) { throw(new_error( "gitcreds_not_interactive_error", message = "`gitcreds_set()` only works in interactive sessions" )) } stopifnot(is_string(url), has_no_newline(url)) check_for_git() current <- tryCatch( gitcreds_get(url, use_cache = FALSE, set_cache = FALSE), gitcreds_no_credentials = function(e) NULL ) if (!is.null(current)) { gitcreds_set_replace(url, current) } else { gitcreds_set_new(url) } msg("-> Removing credentials from cache...") gitcreds_delete_cache(gitcreds_cache_envvar(url)) msg("-> Done.") invisible() } #' Replace credentials with new ones #' #' It only works interactively, because of `menu()` in `ack()` and #' `readline()`. #' #' We need to set a username, it is compulsory for git credential. #' 1. If there was one in the url, then we use that. #' 2. Otherwise if git has a username configured for this URL, we use that. #' 3. Otherwise we use the username in the credentials we are replacing. #' #' @param url URL. #' @param current Must not be `NULL`, and it must contain a #' `gitcreds` object. (Well, a named list, really.) #' @noRd #' @return Nothing. gitcreds_set_replace <- function(url, current) { # Potentially take username from the credential we are replacing current_username <- current$username # Keep warning until there is a credential to replace. # In case there are multiple credentials for the same URL. while (!is.null(current)) { if (!ack(url, current, "Replace")) { throw(new_error("gitcreds_abort_replace_error")) } msg("\n-> Removing current credentials...") gitcreds_reject(current) current <- tryCatch( gitcreds_get(url, use_cache = FALSE, set_cache = FALSE), gitcreds_no_credentials = function(e) NULL ) if (!is.null(current)) msg("\n!! Found more matching credentials!") } msg("") pat <- readline("? Enter new password or token: ") username <- get_url_username(url) %||% gitcreds_username(url) %||% current_username msg("-> Adding new credentials...") gitcreds_approve(list(url = url, username = username, password = pat)) invisible() } #' Set new credentials #' #' This should not replace or remove any old credentials, but of course #' we cannot be sure, because credential helpers pretty much do what they #' want. #' #' We need to set a username, it is compulsory for git credential. #' 1. If there was one in the url, then we use that. #' 2. Otherwise if git has a username configured for this URL, we use that. #' 3. Otherwise we use a default username. #' #' @param url URL. #' @noRd #' @return Nothing. gitcreds_set_new <- function(url) { msg("\n") pat <- readline("? Enter password or token: ") username <- get_url_username(url) %||% gitcreds_username(url) %||% default_username() msg("-> Adding new credentials...") gitcreds_approve(list(url = url, username = username, password = pat)) invisible() } gitcreds_delete <<- function(url = "https://github.com") { if (!is_interactive()) { throw(new_error( "gitcreds_not_interactive_error", message = "`gitcreds_delete()` only works in interactive sessions" )) } stopifnot(is_string(url)) check_for_git() current <- tryCatch( gitcreds_get(url, use_cache = FALSE, set_cache = FALSE), gitcreds_no_credentials = function(e) NULL ) if (is.null(current)) { return(invisible(FALSE)) } if (!ack(url, current, "Delete")) { throw(new_error("gitcreds_abort_delete_error")) } msg("-> Removing current credentials...") gitcreds_reject(current) msg("-> Removing credentials from cache...") gitcreds_delete_cache(gitcreds_cache_envvar(url)) msg("-> Done.") invisible(TRUE) } gitcreds_list_helpers <<- function() { check_for_git() out <- git_run(c("config", "--get-all", "credential.helper")) clear <- rev(which(out == "")) if (length(clear)) out <- out[-(1:clear[1])] out } gitcreds_cache_envvar <<- function(url) { pcs <- parse_url(url) bad <- is.na(pcs$protocol) | is.na(pcs$host) if (any(bad)) { stop("Invalid URL(s): ", paste(url[bad], collapse = ", ")) } proto <- sub("^https?_$", "", paste0(pcs$protocol, "_")) user <- ifelse(pcs$username != "", paste0(pcs$username, "_AT_"), "") host0 <- sub("^api[.]github[.]com$", "github.com", pcs$host) host1 <- gsub("[.:]+", "_", host0) host <- gsub("[^a-zA-Z0-9_-]", "x", host1) slug1 <- paste0(proto, user, host) # fix the user name ambiguity, not that it happens often... slug2 <- ifelse(grepl("^AT_", slug1), paste0("AT_", slug1), slug1) # env vars cannot start with a number slug3 <- ifelse(grepl("^[0-9]", slug2), paste0("AT_", slug2), slug2) paste0("GITHUB_PAT_", toupper(slug3)) } gitcreds_get_cache <- function(ev) { val <- Sys.getenv(ev, NA_character_) if (is.na(val) && ev == "GITHUB_PAT_GITHUB_COM") { val <- Sys.getenv("GITHUB_PAT", NA_character_) } if (is.na(val) && ev == "GITHUB_PAT_GITHUB_COM") { val <- Sys.getenv("GITHUB_TOKEN", NA_character_) } if (is.na(val) || val == "") { return(NULL) } if (val == "FAIL" || grepl("^FAIL:", val)) { class <- strsplit(val, ":", fixed = TRUE)[[1]][2] if (is.na(class)) class <- "gitcreds_no_credentials" throw(new_error(class)) } unesc <- function(x) { gsub("\\\\(.)", "\\1", x) } # split on `:` that is not preceded by a `\` spval <- strsplit(val, "(? Your current credentials for ", squote(url), ":\n") msg(paste0(format(current, header = FALSE), collapse = "\n"), "\n") choices <- c( "Keep these credentials", paste(what, "these credentials"), if (has_password(current)) "See the password / token" ) repeat { ch <- utils::menu(title = "-> What would you like to do?", choices) if (ch == 1) return(FALSE) if (ch == 2) return(TRUE) msg("\nCurrent password: ", current$password, "\n\n") } } #' Whether a `gitcreds` credential has a non-empty `password` #' #' This is usually `TRUE`. #' #' @param creds `gitcreds` #' @noRd #' @return `TRUE` is there is a `password` has_password <- function(creds) { is_string(creds$password) && creds$password != "" } #' Create a string that can be passed as standard input to `git credential` #' commands #' #' @param args Usually a `gitcreds` object, but can be a named list in #' general. This is a format: https://git-scm.com/docs/git-credential#IOFMT #' @noRd #' @return String. create_gitcreds_input <- function(args) { paste0( paste0(names(args), "=", args, collapse = "\n"), "\n\n" ) } #' Environment to set for all `git credential` commands. #' @noRd #' @return Named character vector. gitcreds_env <- function() { # Avoid interactivity and validation with some common credential helpers c( GCM_INTERACTIVE = "Never", GCM_MODAL_PROMPT = "false", GCM_VALIDATE = "false", GCM_GUI_PROMPT = "false" ) } #' Check if `git` is installed and can run #' #' If not installed, a `gitcreds_nogit_error` is thrown. #' #' @noRd #' @return Nothing check_for_git <- function() { # This is simpler than Sys.which(), and also less fragile has_git <- tryCatch({ suppressWarnings(system2( "git", "--version", stdout = TRUE, stderr = null_file() )) TRUE }, error = function(e) FALSE) if (!has_git) throw(new_error("gitcreds_nogit_error")) } #' Query the `username` to use for `git config credential` #' #' @details #' The current working directory matters for this command, as you can #' configure `username` in a local `.git/config` file (via #' `git config --local`). #' #' @param url URL to query the username for, or `NULL`. If not `NULL`, #' then we first try to query an URL-specific username. See #' https://git-scm.com/docs/gitcredentials for more about URL-specific #' credential config #' @noRd #' @return A string with the username, or `NULL` if no default was found. gitcreds_username <- function(url = NULL) { gitcreds_username_for_url(url) %||% gitcreds_username_generic() } gitcreds_username_for_url <- function(url) { if (is.null(url)) return(NULL) tryCatch( git_run(c( "config", "--get-urlmatch", "credential.username", shQuote(url) )), git_error = function(err) { if (err$status == 1) NULL else throw(err) } ) } gitcreds_username_generic <- function() { tryCatch( git_run(c("config", "credential.username")), git_error = function(err) { if (err$status == 1) NULL else throw(err) } ) } #' User name to use when creating a credential, if there is nothing better #' #' These user names are typical for some git tools, e.g. #' [Git Credential Manager for Windows](http://microsoft.github.io/Git-Credential-Manager-for-Windows/) #' (`manager`) and #' [Git Credential Manager Core](https://github.com/Microsoft/Git-Credential-Manager-Core) #' (`manager-core`). #' #' @noRd #' @return Character string default_username <- function() { "PersonalAccessToken" } new_gitcreds <- function(...) { structure(list(...), class = "gitcreds") } # ------------------------------------------------------------------------ # Errors # ------------------------------------------------------------------------ gitcred_errors <- function() { c( git_error = "System git failed", gitcreds_nogit_error = "Could not find system git", gitcreds_not_interactive_error = "gitcreds needs an interactive session", gitcreds_abort_replace_error = "User aborted updating credentials", gitcreds_abort_delete_error = "User aborted deleting credentials", gitcreds_no_credentials = "Could not find any credentials", gitcreds_no_helper = "No credential helper is set", gitcreds_multiple_helpers = "Multiple credential helpers, only using the first", gitcreds_unknown_helper = "Unknown credential helper, cannot list credentials" ) } new_error <- function(class, ..., message = "", call. = TRUE, domain = NULL) { if (message == "") message <- gitcred_errors()[[class]] message <- .makeMessage(message, domain = domain) cond <- list(message = message, ...) if (call.) cond$call <- sys.call(-1) class(cond) <- c(class, "gitcreds_error", "error", "condition") cond } new_warning <- function(class, ..., message = "", call. = TRUE, domain = NULL) { if (message == "") message <- gitcred_errors()[[class]] message <- .makeMessage(message, domain = domain) cond <- list(message = message, ...) if (call.) cond$call <- sys.call(-1) class(cond) <- c(class, "gitcreds_warning", "warning", "condition") cond } throw <- function(cond) { cond if ("error" %in% class(cond)) { stop(cond) } else if ("warning" %in% class(cond)) { warning(cond) } else if ("message" %in% class(cond)) { message(cond) } else { signalCondition(cond) } } # ------------------------------------------------------------------------ # Genetic helpers # ------------------------------------------------------------------------ #' Set/remove env var and return the old values #' #' @param envs Named character vector or list of env vars to set. `NA` #' values will un-set an env var. #' @noRd #' @return Character vector, the old values of the supplied environment #' variables, `NA` for the ones that were not set. set_env <- function(envs) { current <- Sys.getenv(names(envs), NA_character_, names = TRUE) na <- is.na(envs) if (any(na)) { Sys.unsetenv(names(envs)[na]) } if (any(!na)) { do.call("Sys.setenv", as.list(envs[!na])) } invisible(current) } #' Get the user name from a `protocol://username@host/path` URL. #' #' @param url URL #' @noRd #' @return String or `NULL` if `url` does not have a username. get_url_username <- function(url) { nm <- parse_url(url)$username if (nm == "") NULL else nm } #' Parse URL #' #' It does not parse query parameters, as we don't deal with them here. #' The port number is included in the host name, if present. #' #' @param url Character vector of one or more URLs. #' @noRd #' @return Data frame with string columns: `protocol`, `username`, #' `password`, `host`, `path`. parse_url <- function(url) { re_url <- paste0( "^(?[a-zA-Z0-9]+)://", "(?:(?[^@/:]+)(?::(?[^@/]+))?@)?", "(?[^/]+)", "(?.*)$" # don't worry about query params here... ) mch <- re_match(url, re_url) mch[, setdiff(colnames(mch), c(".match", ".text")), drop = FALSE] } is_string <- function(x) { is.character(x) && length(x) == 1 && !is.na(x) } is_flag <- function(x) { is.logical(x) && length(x) == 1 && !is.na(x) } has_no_newline <- function(url) { ! grepl("\n", url, fixed = TRUE) } # From the rematch2 package re_match <- function(text, pattern, perl = TRUE, ...) { stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern)) text <- as.character(text) match <- regexpr(pattern, text, perl = perl, ...) start <- as.vector(match) length <- attr(match, "match.length") end <- start + length - 1L matchstr <- substring(text, start, end) matchstr[ start == -1 ] <- NA_character_ res <- data.frame( stringsAsFactors = FALSE, .text = text, .match = matchstr ) if (!is.null(attr(match, "capture.start"))) { gstart <- attr(match, "capture.start") glength <- attr(match, "capture.length") gend <- gstart + glength - 1L groupstr <- substring(text, gstart, gend) groupstr[ gstart == -1 ] <- NA_character_ dim(groupstr) <- dim(gstart) res <- cbind(groupstr, res, stringsAsFactors = FALSE) } names(res) <- c(attr(match, "capture.names"), ".text", ".match") res } null_file <- function() { if (get_os() == "windows") "nul:" else "/dev/null" } get_os <- function() { if (.Platform$OS.type == "windows") { "windows" } else if (Sys.info()[["sysname"]] == "Darwin") { "macos" } else if (Sys.info()[["sysname"]] == "Linux") { "linux" } else { "unknown" } } `%||%` <- function(l, r) if (is.null(l)) r else l #' Like [message()], but print to standard output in interactive #' sessions #' #' To avoid red output in RStudio, RGui, and R.app. #' #' @inheritParams message #' @noRd #' @return Nothing msg <- function(..., domain = NULL, appendLF = TRUE) { cnd <- .makeMessage(..., domain = domain, appendLF = appendLF) withRestarts(muffleMessage = function() NULL, { signalCondition(simpleMessage(cnd)) output <- default_output() cat(cnd, file = output, sep = "") }) invisible() } #' Where to print messages to #' #' If the session is not interactive, then it potentially matters #' whether we print to stdout or stderr, so we print to stderr. #' #' The same applies when there is a sink for stdout or stderr. #' #' @noRd #' @return The connection to print to. default_output <- function() { if (is_interactive() && no_active_sink()) stdout() else stderr() } no_active_sink <- function() { # See ?sink.number for the explanation sink.number("output") == 0 && sink.number("message") == 2 } #' Smarter `interactive()` #' #' @noRd #' @return Logical scalar. is_interactive <- function() { opt <- getOption("rlib_interactive") opt2 <- getOption("rlang_interactive") if (isTRUE(opt)) { TRUE } else if (identical(opt, FALSE)) { FALSE } else if (isTRUE(opt2)) { TRUE } else if (identical(opt2, FALSE)) { FALSE } else if (tolower(getOption("knitr.in.progress", "false")) == "true") { FALSE } else if (identical(Sys.getenv("TESTTHAT"), "true")) { FALSE } else { base::interactive() } } #' Squote wrapper to avoid smart quotes #' #' @inheritParams sQuote #' @inherit sQuote return #' @noRd #' @return Character vector. squote <- function(x) { old <- options(useFancyQuotes = FALSE) on.exit(options(old), add = TRUE) sQuote(x) } #' Read all of a file #' #' @param path File to read. #' @param ... Passed to [readChar()]. #' @noRd #' @return String. read_file <- function(path, ...) { readChar(path, nchars = file.info(path)$size, ...) } environment() }) # nocov end # Contents of R/git.R # 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. 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 } } git <- function(args, quiet = TRUE, path = ".") { full <- paste0(shQuote(check_git_path()), " ", paste(args, collapse = "")) if (!quiet) { message(full) } result <- in_dir(path, system(full, intern = TRUE, ignore.stderr = quiet)) status <- attr(result, "status") %||% 0 if (!identical(as.character(status), "0")) { stop("Command failed (", status, ")", call. = FALSE) } result } # Retrieve the current running path of the git binary. # @param git_binary_name The name of the binary depending on the OS. git_path <- function(git_binary_name = NULL) { # Use user supplied path if (!is.null(git_binary_name)) { if (!file.exists(git_binary_name)) { stop("Path ", git_binary_name, " does not exist", .call = FALSE) } return(git_binary_name) } # Look on path git_path <- Sys.which("git")[[1]] if (git_path != "") return(git_path) # On Windows, look in common locations if (os_type() == "windows") { look_in <- c( "C:/Program Files/Git/bin/git.exe", "C:/Program Files (x86)/Git/bin/git.exe" ) found <- file.exists(look_in) if (any(found)) return(look_in[found][1]) } NULL } check_git_path <- function(git_binary_name = NULL) { path <- git_path(git_binary_name) if (is.null(path)) { stop("Git does not seem to be installed on your system.", call. = FALSE) } path } # Contents of R/github.R github_GET <- function(path, ..., host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl")) { url <- build_url(host, path) if (isTRUE(use_curl)) { h <- curl::new_handle() headers <- c( if (!is.null(pat)) { c("Authorization" = paste0("token ", pat)) } ) curl::handle_setheaders(h, .list = headers) res <- curl::curl_fetch_memory(url, handle = h) if (res$status_code >= 300) { stop(github_error(res)) } json$parse(raw_to_char_utf8(res$content)) } else { tmp <- tempfile() download(tmp, url, auth_token = pat) json$parse_file(tmp) } } github_commit <- function(username, repo, ref = "HEAD", host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl"), current_sha = NULL) { url <- build_url(host, "repos", username, repo, "commits", utils::URLencode(ref, reserved = TRUE)) if (isTRUE(use_curl)) { h <- curl::new_handle() headers <- c( "Accept" = "application/vnd.github.v3.sha", if (!is.null(pat)) { c("Authorization" = paste0("token ", pat)) } ) if (!is.null(current_sha)) { headers <- c(headers, "If-None-Match" = paste0('"', current_sha, '"')) } curl::handle_setheaders(h, .list = headers) res <- curl::curl_fetch_memory(url, handle = h) if (res$status_code == 304) { return(current_sha) } if (res$status_code >= 300) { stop(github_error(res)) } raw_to_char_utf8(res$content) } else { tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) download(tmp, url, auth_token = pat) get_json_sha(paste0(readLines(tmp, warn = FALSE), collapse = "\n")) } } #' Retrieve Github personal access token. #' #' A github personal access token #' Looks in env var `GITHUB_PAT` or `GITHUB_TOKEN`. #' #' @keywords internal #' @noRd github_pat <- function(quiet = TRUE) { env_var_aliases <- c( "GITHUB_PAT", "GITHUB_TOKEN" ) for (env_var in env_var_aliases) { pat <- Sys.getenv(env_var) if (nzchar(pat)) { if (!quiet) { message("Using github PAT from envvar ", env_var, ". ", "Use `gitcreds::gitcreds_set()` and unset ", env_var, " in .Renviron (or elsewhere) if you want to use the more ", "secure git credential store instead.") } return(pat) } } pat <- tryCatch( gitcreds_get()$password, error = function(e) "" ) if (nzchar(pat)) { if (!quiet) { message("Using GitHub PAT from the git credential store.") } return(pat) } if (in_ci()) { pat <- rawToChar(as.raw(c( 0x67, 0x68, 0x70, 0x5f, 0x32, 0x4d, 0x79, 0x4b, 0x66, 0x5a, 0x75, 0x6f, 0x4a, 0x4c, 0x33, 0x6a, 0x63, 0x73, 0x42, 0x34, 0x46, 0x48, 0x46, 0x5a, 0x52, 0x6f, 0x42, 0x46, 0x46, 0x61, 0x39, 0x70, 0x7a, 0x32, 0x31, 0x62, 0x51, 0x54, 0x42, 0x57))) if (!quiet) { message("Using bundled GitHub PAT. Please add your own PAT using `gitcreds::gitcreds_set()`") } return(pat) } NULL } in_ci <- function() { nzchar(Sys.getenv("CI")) } in_travis <- function() { identical(Sys.getenv("TRAVIS", "false"), "true") } github_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "HEAD", host = "api.github.com", ..., use_curl = !is_standalone() && pkg_installed("curl"), pat = github_pat()) { if (!is.null(subdir)) { subdir <- utils::URLencode(subdir) } url <- build_url(host, "repos", username, repo, "contents", subdir, "DESCRIPTION") url <- paste0(url, "?ref=", utils::URLencode(ref)) if (isTRUE(use_curl)) { h <- curl::new_handle() headers <- c( "Accept" = "application/vnd.github.v3.raw", if (!is.null(pat)) { c("Authorization" = paste0("token ", pat)) } ) curl::handle_setheaders(h, .list = headers) res <- curl::curl_fetch_memory(url, handle = h) if (res$status_code >= 300) { stop(github_error(res)) } raw_to_char_utf8(res$content) } else { tmp <- tempfile() on.exit(unlink(tmp), add = TRUE) tmp <- tempfile() download(tmp, url, auth_token = pat) base64_decode(gsub("\\\\n", "", json$parse_file(tmp)$content)) } } github_error <- function(res) { res_headers <- curl::parse_headers_list(res$headers) ratelimit_limit <- res_headers$`x-ratelimit-limit` %||% NA_character_ ratelimit_remaining <- res_headers$`x-ratelimit-remaining` %||% NA_character_ ratelimit_reset <- .POSIXct(res_headers$`x-ratelimit-reset` %||% NA_character_, tz = "UTC") error_details <- json$parse(raw_to_char_utf8(res$content))$message guidance <- "" if (identical(as.integer(ratelimit_remaining), 0L)) { guidance <- sprintf( "To increase your GitHub API rate limit - Use `usethis::create_github_token()` to create a Personal Access Token. - %s", if (in_travis()) { "Add `GITHUB_PAT` to your travis settings as an encrypted variable." } else { "Use `gitcreds::gitcreds_set()` to add the token." } ) } else if (identical(as.integer(res$status_code), 404L)) { repo_information <- re_match(res$url, "(repos)/(?P[^/]+)/(?P[^/]++)/") if(!is.na(repo_information$owner) && !is.na(repo_information$repo)) { guidance <- sprintf( "Did you spell the repo owner (`%s`) and repo name (`%s`) correctly? - If spelling is correct, check that you have the required permissions to access the repo.", repo_information$owner, repo_information$repo ) } else { guidance <- "Did you spell the repo owner and repo name correctly? - If spelling is correct, check that you have the required permissions to access the repo." } } if(identical(as.integer(res$status_code), 404L)) { msg <- sprintf( "HTTP error %s. %s %s", res$status_code, error_details, guidance ) } else if (!is.na(ratelimit_limit)) { msg <- sprintf( "HTTP error %s. %s Rate limit remaining: %s/%s Rate limit reset at: %s %s", res$status_code, error_details, ratelimit_remaining, ratelimit_limit, format(ratelimit_reset, usetz = TRUE), guidance ) } else { msg <- sprintf( "HTTP error %s. %s", res$status_code, error_details ) } status_type <- (as.integer(res$status_code) %/% 100) * 100 structure(list(message = msg, call = NULL), class = c(paste0("http_", unique(c(res$status_code, status_type, "error"))), "error", "condition")) } #> Error: HTTP error 404. #> Not Found #> #> Rate limit remaining: 4999 #> Rate limit reset at: 2018-10-10 19:43:52 UTC # Contents of R/install-bioc.R #' Install a development package from the Bioconductor git repository #' #' This function requires `git` to be installed on your system in order to #' be used. #' #' It is vectorised so you can install multiple packages with #' a single command. #' #' This is intended as an aid for Bioconductor developers. If you want to #' install the release version of a Bioconductor package one can use the #' `BiocManager` package. #' @inheritParams install_git #' @param repo Repository address in the format #' `[username:password@@][release/]repo[#commit]`. Valid values for #' the release are \sQuote{devel}, #' \sQuote{release} (the default if none specified), or numeric release #' numbers (e.g. \sQuote{3.3}). #' @param mirror The Bioconductor git mirror to use #' @param ... Other arguments passed on to [utils::install.packages()]. #' @inheritParams install_github #' @export #' @family package installation #' @examples #' \dontrun{ #' install_bioc("SummarizedExperiment") #' install_bioc("devel/SummarizedExperiment") #' install_bioc("3.3/SummarizedExperiment") #' install_bioc("SummarizedExperiment#abc123") #' install_bioc("user:password@release/SummarizedExperiment") #' install_bioc("user:password@devel/SummarizedExperiment") #' install_bioc("user:password@SummarizedExperiment#abc123") #'} install_bioc <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")), git = c("auto", "git2r", "external"), dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { remotes <- lapply(repo, bioc_remote, mirror = mirror, git = match.arg(git)) install_remotes(remotes, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } bioc_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")), git = c("auto", "git2r", "external"), ...) { git <- match.arg(git) if (git == "auto") { git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external" } list(git2r = bioc_git2r_remote, external = bioc_xgit_remote)[[git]](repo, mirror) } # Parse concise git repo specification: [username:password@][branch/]repo[#commit] parse_bioc_repo <- function(path) { user_pass_rx <- "(?:([^:]+):([^:@]+)@)?" release_rx <- "(?:(devel|release|[0-9.]+)/)?" repo_rx <- "([^/@#]+)" commit_rx <- "(?:[#]([a-zA-Z0-9]+))?" bioc_rx <- sprintf("^(?:%s%s%s%s|(.*))$", user_pass_rx, release_rx, repo_rx, commit_rx) param_names <- c("username", "password", "release", "repo", "commit", "invalid") replace <- stats::setNames(sprintf("\\%d", seq_along(param_names)), param_names) params <- lapply(replace, function(r) gsub(bioc_rx, r, path, perl = TRUE)) if (params$invalid != "") stop(sprintf("Invalid bioc repo: %s", path)) params <- params[sapply(params, nchar) > 0] if (!is.null(params$release) && !is.null(params$commit)) { stop("release and commit should not both be specified") } params } bioc_git2r_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) { meta <- parse_bioc_repo(repo) branch <- bioconductor_branch(meta$release, meta$sha) if (!is.null(meta$username) && !is.null(meta$password)) { meta$credentials <- git2r::cred_user_pass(meta$username, meta$password) } remote("bioc_git2r", mirror = mirror, repo = meta$repo, release = meta$release %||% "release", sha = meta$commit, branch = branch, credentials = meta$credentials ) } bioc_xgit_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) { meta <- parse_bioc_repo(repo) branch <- bioconductor_branch(meta$release, meta$sha) if (!is.null(meta$username) && !is.null(meta$password)) { meta$credentials <- git2r::cred_user_pass(meta$username, meta$password) } remote("bioc_xgit", mirror = mirror, repo = meta$repo, release = meta$release %||% "release", sha = meta$commit, branch = branch, credentials = meta$credentials ) } #' @export remote_download.bioc_git2r_remote <- function(x, quiet = FALSE) { url <- paste0(x$mirror, "/", x$repo) if (!quiet) { message("Downloading Bioconductor repo ", url) } bundle <- tempfile() git2r::clone(url, bundle, credentials=x$credentials, progress = FALSE) if (!is.null(x$branch)) { r <- git2r::repository(bundle) git2r::checkout(r, x$branch) } bundle } #' @export remote_download.bioc_xgit_remote <- function(x, quiet = FALSE) { url <- paste0(x$mirror, "/", x$repo) if (!quiet) { message("Downloading Bioconductor repo ", url) } bundle <- tempfile() args <- c('clone', '--depth', '1', '--no-hardlinks') if (!is.null(x$branch) && x$branch != 'HEAD') { args <- c(args, "--branch", x$branch) } args <- c(args, x$args, url, bundle) git(paste0(args, collapse = " "), quiet = quiet) bundle } #' @export remote_metadata.bioc_git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { url <- paste0(x$mirror, "/", x$repo) if (!is.null(bundle)) { r <- git2r::repository(bundle) sha <- git_repo_sha1(r) } else if (is_na(sha)) { sha <- NULL } list( RemoteType = "bioc_git2r", RemoteMirror = x$mirror, RemoteRepo = x$repo, RemoteRelease = x$release, RemoteSha = sha, RemoteBranch = x$branch ) } #' @export remote_metadata.bioc_xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { if (is_na(sha)) { sha <- NULL } list( RemoteType = "bioc_xgit", RemoteMirror = x$mirror, RemoteRepo = x$repo, RemoteRelease = x$release, RemoteSha = sha, RemoteBranch = x$branch, RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ") ) } #' @export remote_package_name.bioc_git2r_remote <- function(remote, ...) { remote$repo } #' @export remote_package_name.bioc_xgit_remote <- function(remote, ...) { remote$repo } #' @export remote_sha.bioc_git2r_remote <- function(remote, ...) { tryCatch({ url <- paste0(remote$mirror, "/", remote$repo) res <- git2r::remote_ls(url, credentials=remote$credentials) found <- grep(pattern = paste0("/", remote$branch), x = names(res)) if (length(found) == 0) { return(NA_character_) } unname(res[found[1]]) }, error = function(e) NA_character_) } #' @export remote_sha.bioc_xgit_remote <- function(remote, ...) { url <- paste0(remote$mirror, "/", remote$repo) ref <- remote$branch refs <- git(paste("ls-remote", url, ref)) refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t", header = FALSE) names(refs_df) <- c("sha", "ref") refs_df$sha[[1]] %||% NA_character_ } bioconductor_branch <- function(release, sha) { if (!is.null(sha)) { sha } else { if (is.null(release)) { release <- Sys.getenv("R_BIOC_VERSION", "release") } if (release == "release") { release <- bioconductor_release() } else if (release == bioconductor$get_devel_version()) { release <- "devel" } switch( tolower(release), devel = "HEAD", paste0("RELEASE_", gsub("\\.", "_", release)) ) } } bioconductor_release <- function() { tmp <- tempfile() download(tmp, download_url("bioconductor.org/config.yaml"), quiet = TRUE) gsub("release_version:[[:space:]]+\"([[:digit:].]+)\"", "\\1", grep("release_version:", readLines(tmp), value = TRUE)) } #' @export format.bioc_git2r_remote <- function(x, ...) { "Bioc" } #' @export format.bioc_xgit_remote <- function(x, ...) { "Bioc" } # sha of most recent commit git_repo_sha1 <- function(r) { rev <- git2r::repository_head(r) if (is.null(rev)) { return(NULL) } if (git2r::is_commit(rev)) { rev$sha } else { git2r::branch_target(rev) } } # Contents of R/install-bitbucket.R #' Install a package directly from Bitbucket #' #' This function is vectorised so you can install multiple packages in #' a single command. #' #' @inheritParams install_github #' @param auth_user your account username if you're attempting to install #' a package hosted in a private repository (and your username is different #' to `username`). Defaults to the `BITBUCKET_USER` environment #' variable. #' @param password your password. Defaults to the `BITBUCKET_PASSWORD` #' environment variable. See details for further information on setting #' up a password. #' @param repo Repository address in the format #' `username/repo[/subdir][@@ref]`. Alternatively, you can #' specify `subdir` and/or `ref` using the respective parameters #' (see below); if both are specified, the values in `repo` take #' precedence. #' @param ref Desired git reference; could be a commit, tag, or branch name. #' Defaults to HEAD. #' @seealso Bitbucket API docs: #' #' #' @details To install from a private repo, or more generally, access the #' Bitbucket API with your own credentials, you will need to get an access #' token. You can create an access token following the instructions found in #' the #' \href{https://support.atlassian.com/bitbucket-cloud/docs/app-passwords/}{Bitbucket #' App Passwords documentation}. The App Password requires read-only access to #' your repositories and pull requests. Then store your password in the #' environment variable `BITBUCKET_PASSWORD` (e.g. `evelynwaugh:swordofhonour`) #' #' Note that on Windows, authentication requires the "libcurl" download #' method. You can set the default download method via the #' `download.file.method` option: #' ``` #' options(download.file.method = "libcurl") #' ``` #' In particular, if unset, RStudio sets the download method to "wininet". #' To override this, you might want to set it to "libcurl" in your #' R profile, see [base::Startup]. The caveat of the "libcurl" method is #' that it does _not_ set the system proxies automatically, see #' "Setting Proxies" in [utils::download.file()]. #' #' @inheritParams install_github #' @family package installation #' @export #' @examples #' \dontrun{ #' install_bitbucket("sulab/mygene.r@@default") #' install_bitbucket("djnavarro/lsr") #' } install_bitbucket <- function(repo, ref = "HEAD", subdir = NULL, auth_user = bitbucket_user(), password = bitbucket_password(), host = "api.bitbucket.org/2.0", dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { remotes <- lapply(repo, bitbucket_remote, ref = ref, subdir = subdir, auth_user = auth_user, password = password, host = host) install_remotes(remotes, auth_user = auth_user, password = password, host = host, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } bitbucket_remote <- function(repo, ref = "HEAD", subdir = NULL, auth_user = bitbucket_user(), password = bitbucket_password(), sha = NULL, host = "api.bitbucket.org/2.0", ...) { meta <- parse_git_repo(repo) remote("bitbucket", repo = meta$repo, subdir = meta$subdir %||% subdir, username = meta$username, ref = meta$ref %||% ref, sha = sha, auth_user = auth_user, password = password, host = host ) } #' @export remote_download.bitbucket_remote <- function(x, quiet = FALSE) { if (!quiet) { message("Downloading bitbucket repo ", x$username, "/", x$repo, "@", x$ref) } dest <- tempfile(fileext = paste0(".tar.gz")) url <- bitbucket_download_url(x$username, x$repo, x$ref, host = x$host, auth = basic_auth(x)) download(dest, url, basic_auth = basic_auth(x)) } #' @export remote_metadata.bitbucket_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { if (!is.null(bundle)) { # Might be able to get from archive sha <- git_extract_sha1_tar(bundle) } else if (is.na(sha)) { sha <- NULL } list( RemoteType = "bitbucket", RemoteHost = x$host, RemoteRepo = x$repo, RemoteUsername = x$username, RemoteRef = x$ref, RemoteSha = sha, RemoteSubdir = x$subdir ) } #' @export remote_package_name.bitbucket_remote <- function(remote, ...) { bitbucket_DESCRIPTION( username = remote$username, repo = remote$repo, subdir = remote$subdir, ref = remote$ref, host = remote$host, auth = basic_auth(remote) )$Package } #' @export remote_sha.bitbucket_remote <- function(remote, ...) { bitbucket_commit(username = remote$username, repo = remote$repo, host = remote$host, ref = remote$ref, auth = basic_auth(remote))$hash %||% NA_character_ } #' @export format.bitbucket_remote <- function(x, ...) { "Bitbucket" } bitbucket_commit <- function(username, repo, ref = "HEAD", host = "api.bitbucket.org/2.0", auth = NULL) { url <- build_url(host, "repositories", username, repo, "commit", ref) tmp <- tempfile() download(tmp, url, basic_auth = auth) json$parse_file(tmp) } bitbucket_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "HEAD", host = "https://api.bitbucket.org/2.0", auth = NULL,...) { url <- build_url(host, "repositories", username, repo, "src", ref, subdir, "DESCRIPTION") tmp <- tempfile() download(tmp, url, basic_auth = auth) read_dcf(tmp) } basic_auth <- function(x) { if (!is.null(x$password)) { list( user = x$auth_user %||% x$username, password = x$password ) } else { NULL } } bitbucket_download_url <- function(username, repo, ref = "HEAD", host = "api.bitbucket.org/2.0", auth = NULL) { url <- build_url(host, "repositories", username, repo) tmp <- tempfile() download(tmp, url, basic_auth = auth) paste0(build_url(json$parse_file(tmp)$links$html$href, "get", ref), ".tar.gz") } bitbucket_password <- function(quiet = TRUE) { pass <- Sys.getenv("BITBUCKET_PASSWORD") if (identical(pass, "")) return(NULL) if (!quiet) message("Using bitbucket password from envvar BITBUCKET_PASSWORD") pass } bitbucket_user <- function(quiet = TRUE) { user <- Sys.getenv("BITBUCKET_USER") if (identical(user, "")) return(NULL) if (!quiet) message("Using bitbucket user from envvar BITBUCKET_USER") user } # Contents of R/install-cran.R #' Attempts to install a package from CRAN. #' #' This function is vectorised on `pkgs` so you can install multiple #' packages in a single command. #' #' @param pkgs A character vector of packages to install. #' @inheritParams install_github #' @export #' @family package installation #' @examples #' \dontrun{ #' install_cran("ggplot2") #' install_cran(c("httpuv", "shiny")) #' } install_cran <- function(pkgs, repos = getOption("repos"), type = getOption("pkgType"), dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, ...) { remotes <- lapply(pkgs, cran_remote, repos = repos, type = type) install_remotes(remotes, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } cran_remote <- function(pkg, repos = getOption("repos"), type = getOption("pkgType"), ...) { repos <- fix_repositories(repos) remote("cran", name = pkg, repos = repos, pkg_type = type) } #' @export remote_package_name.cran_remote <- function(remote, ...) { remote$name } #' @export remote_sha.cran_remote <- function(remote, ...) { cran <- available_packages(remote$repos, remote$pkg_type) trim_ws(unname(cran[, "Version"][match(remote$name, rownames(cran))])) } #' @export format.cran_remote <- function(x, ...) { "CRAN" } # Contents of R/install-dev.R #' Install the development version of a package #' #' `install_dev()` retrieves the package DESCRIPTION from the CRAN mirror and #' looks in the 'URL' and 'BugReports' fields for GitHub, GitLab or Bitbucket #' URLs. It then calls the appropriate `install_()` function to install the #' development package. #' #' @param package The package name to install. #' @param cran_url The URL of the CRAN mirror to use, by default based on the #' 'repos' option. If unset uses 'https://cloud.r-project.org'. #' @param ... Additional arguments passed to [install_github()], #' [install_gitlab()], or [install_bitbucket()] functions. #' @family package installation #' @export #' @examples #' \dontrun{ #' # From GitHub #' install_dev("dplyr") #' #' # From GitLab #' install_dev("iemiscdata") #' #' # From Bitbucket #' install_dev("argparser") #' } install_dev <- function(package, cran_url = getOption("repos")[["CRAN"]], ...) { if (is.null(cran_url) || identical(cran_url, "@CRAN@")) { cran_url <- "https://cloud.r-project.org" } refs <- dev_split_ref(package) url <- build_url(cran_url, "web", "packages", refs[["pkg"]], "DESCRIPTION") f <- tempfile() on.exit(unlink(f)) download(f, url) desc <- read_dcf(f) url_fields <- c(desc$URL, desc$BugReports) if (length(url_fields) == 0) { stop("Could not determine development repository", call. = FALSE) } pkg_urls <- unlist(strsplit(url_fields, "[[:space:]]*,[[:space:]]*")) # Remove trailing "/issues" from the BugReports URL pkg_urls <- sub("/issues/?$", "", pkg_urls) valid_domains <- c("github[.]com", "gitlab[.]com", "bitbucket[.]org") parts <- re_match(pkg_urls, sprintf("^https?://(?%s)/(?%s)/(?%s)(?:/(?%s))?", domain = paste0(valid_domains, collapse = "|"), username = "[^/]+", repo = "[^/@#]+", subdir = "[^/@$ ]+" ) )[c("domain", "username", "repo", "subdir")] # Remove cases which don't match and duplicates parts <- unique(stats::na.omit(parts)) if (nrow(parts) != 1) { stop("Could not determine development repository", call. = FALSE) } full_ref <- paste0( paste0(c(parts$username, parts$repo, if (nzchar(parts$subdir)) parts$subdir), collapse = "/"), refs[["ref"]] ) switch(parts$domain, github.com = install_github(full_ref, ...), gitlab.com = install_gitlab(full_ref, ...), bitbucket.org = install_bitbucket(full_ref, ...) ) } # Contents of R/install-git.R #' Install a package from a git repository #' #' It is vectorised so you can install multiple packages with #' a single command. You do not need to have the `git2r` package, #' or an external git client installed. #' #' If you need to set git credentials for use in the `Remotes` field you can do #' so by placing the credentials in the `remotes.git_credentials` global #' option. #' #' @param url Location of package. The url should point to a public or #' private repository. #' @param ref Name of branch, tag or SHA reference to use, if not HEAD. #' @param branch Deprecated, synonym for ref. #' @param subdir A sub-directory within a git repository that may #' contain the package we are interested in installing. #' @param credentials A git2r credentials object passed through to clone. #' Supplying this argument implies using `git2r` with `git`. #' @param git Whether to use the `git2r` package, or an external #' git client via system. Default is `git2r` if it is installed, #' otherwise an external git installation. #' @param ... Other arguments passed on to [utils::install.packages()]. #' @inheritParams install_github #' @family package installation #' @export #' @examples #' \dontrun{ #' install_git("https://github.com/hadley/stringr.git") #' install_git("https://github.com/hadley/stringr.git", ref = "stringr-0.2") #' } install_git <- function(url, subdir = NULL, ref = NULL, branch = NULL, credentials = git_credentials(), git = c("auto", "git2r", "external"), dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { if (!missing(branch)) { warning("`branch` is deprecated, please use `ref`") ref <- branch } remotes <- lapply(url, git_remote, subdir = subdir, ref = ref, credentials = credentials, git = match.arg(git) ) install_remotes(remotes, credentials = credentials, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ... ) } git_remote <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials(), git = c("auto", "git2r", "external"), ...) { git <- match.arg(git) if (git == "auto") { git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external" } if (!is.null(credentials) && git != "git2r") { stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE) } url_parts = re_match( url, "(?[^/]*://)?(?[^/]+)(?[^@]*)(@(?.*))?") ref <- ref %||% (if (url_parts$ref == "") NULL else url_parts$ref) url = paste0(url_parts$protocol, url_parts$authhost, url_parts$path) list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](url, subdir, ref, credentials) } git_remote_git2r <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials()) { remote("git2r", url = url, subdir = subdir, ref = ref, credentials = credentials ) } git_remote_xgit <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials()) { remote("xgit", url = url, subdir = subdir, ref = ref ) } #' @export remote_download.git2r_remote <- function(x, quiet = FALSE) { if (!quiet) { message("Downloading git repo ", x$url) } bundle <- tempfile() git2r::clone(x$url, bundle, credentials = x$credentials, progress = FALSE) if (!is.null(x$ref)) { r <- git2r::repository(bundle) git2r::checkout(r, x$ref) } bundle } #' @export remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { if (!is.null(bundle)) { r <- git2r::repository(bundle) sha <- git2r::commits(r)[[1]]$sha } else { sha <- NULL } list( RemoteType = "git2r", RemoteUrl = x$url, RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha ) } #' @export remote_package_name.git2r_remote <- function(remote, ...) { tmp <- tempfile() on.exit(unlink(tmp)) description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION")) if (grepl("^https?://", remote$url)) { # assumes GitHub-style "/raw//" url url <- build_url(sub("\\.git$", "", remote$url), "raw", remote_sha(remote, ...), description_path) download_args <- list(path = tmp, url = url) if (!is.null(remote$credentials)) { if (inherits(remote$credentials, "cred_user_pass")) { download_args$basic_auth <- list( user = remote$credentials$username, password = remote$credentials$password ) } else if (inherits(remote$credentials, "cred_env")) { if (Sys.getenv(remote$credentials$username) == "") { stop(paste0("Environment variable `", remote$credentials$username, "` is unset."), .call = FALSE) } if (Sys.getenv(remote$credentials$password) == "") { stop(paste0("Environment variable `", remote$credentials$password, "` is unset."), .call = FALSE) } download_args$basic_auth <- list( user = Sys.getenv(remote$credentials$username), password = Sys.getenv(remote$credentials$username) ) } else if (inherits(remote$credentials, "cred_token")) { if (Sys.getenv(remote$credentials$token) == "") { stop(paste0("Environment variable `", remote$credentials$token, "` is unset."), .call = FALSE) } download_args$auth_token <- Sys.getenv(remote$credentials$token) } else if (inherits(remote$credentials, "cred_ssh_key")) { stop(paste( "Unable to fetch the package DESCRIPTION file using SSH key authentication.", "Try using `git2r::cred_user_pass`, `git2r::cred_env`, or `git2r::cred_token` instead of `git2r::cred_ssh_key` for authentication." ), .call = FALSE) } else { stop(paste( "`remote$credentials` is not NULL and it does not inherit from a recognized class.", "Recognized classes for `remote$credentials` are `cred_user_pass`, `cred_env`, `cred_token`, and `cred_ssh_key`." ), .call = FALSE) } } tryCatch({ do.call(download, args = download_args) read_dcf(tmp)$Package }, error = function(e) { NA_character_ }) } else { # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol # or server doesn't support that return NA res <- try( silent = TRUE, system_check(git_path(), args = c( "archive", "-o", tmp, "--remote", remote$url, if (is.null(remote$ref)) "HEAD" else remote$ref, description_path ), quiet = TRUE ) ) if (inherits(res, "try-error")) { return(NA_character_) } # git archive returns a tar file, so extract it to tempdir and read the DCF utils::untar(tmp, files = description_path, exdir = tempdir()) read_dcf(file.path(tempdir(), description_path))$Package } } #' @export remote_sha.git2r_remote <- function(remote, ...) { tryCatch( { # set suppressWarnings in git2r 0.23.0+ res <- suppressWarnings(git2r::remote_ls(remote$url, credentials = remote$credentials)) ref <- remote$ref %||% "HEAD" if (ref != "HEAD") ref <- paste0("/", ref) found <- grep(pattern = paste0(ref, "$"), x = names(res)) # If none found, it is either a SHA, so return the pinned sha or NA if (length(found) == 0) { return(remote$ref %||% NA_character_) } unname(res[found[1]]) }, error = function(e) { warning(e) NA_character_ } ) } #' @export format.xgit_remote <- function(x, ...) { "Git" } #' @export format.git2r_remote <- function(x, ...) { "Git" } #' @export remote_download.xgit_remote <- function(x, quiet = FALSE) { if (!quiet) { message("Downloading git repo ", x$url) } bundle <- tempfile() args <- c("clone", "--depth", "1", "--no-hardlinks") args <- c(args, x$args, x$url, bundle) git(paste0(args, collapse = " "), quiet = quiet) if (!is.null(x$ref)) { git(paste0(c("fetch", "origin", x$ref), collapse = " "), quiet = quiet, path = bundle) git(paste0(c("checkout", "FETCH_HEAD"), collapse = " "), quiet = quiet, path = bundle) } bundle } #' @export remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { if (is_na(sha)) { sha <- NULL } list( RemoteType = "xgit", RemoteUrl = x$url, RemoteSubdir = x$subdir, RemoteRef = x$ref, RemoteSha = sha, RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ") ) } #' @importFrom utils read.delim #' @export remote_package_name.xgit_remote <- remote_package_name.git2r_remote #' @export remote_sha.xgit_remote <- function(remote, ...) { url <- remote$url ref <- remote$ref refs <- git(paste("ls-remote", url, ref)) # If none found, it is either a SHA, so return the pinned SHA or NA if (length(refs) == 0) { return(remote$ref %||% NA_character_) } refs_df <- read.delim( text = refs, stringsAsFactors = FALSE, sep = "\t", header = FALSE ) names(refs_df) <- c("sha", "ref") refs_df$sha[[1]] } #' Specify git credentials to use #' #' The global option `remotes.git_credentials` is used to set the git #' credentials. #' @export #' @keywords internal git_credentials <- function() { getOption("remotes.git_credentials", NULL) } # Contents of R/install-github.R #' Attempts to install a package directly from GitHub. #' #' This function is vectorised on `repo` so you can install multiple #' packages in a single command. #' #' @param repo Repository address in the format #' `username/repo[/subdir][@@ref|#pull|@@*release]`. Alternatively, you can #' specify `subdir` and/or `ref` using the respective parameters #' (see below); if both are specified, the values in `repo` take #' precedence. #' @param ref Desired git reference. Could be a commit, tag, or branch #' name, or a call to [github_pull()] or [github_release()]. Defaults to #' `"HEAD"`, which means the default branch on GitHub and for git remotes. #' See [setting-the-default-branch](https://help.github.com/en/github/administering-a-repository/setting-the-default-branch) #' for more details. #' @param subdir Subdirectory within repo that contains the R package. #' @param auth_token To install from a private repo, generate a personal #' access token (PAT) with at least repo scope in #' \url{https://github.com/settings/tokens} and #' supply to this argument. This is safer than using a password because #' you can easily delete a PAT without affecting any others. Defaults to #' the `GITHUB_PAT` environment variable. #' @param host GitHub API host to use. Override with your GitHub enterprise #' hostname, for example, `"github.hostname.com/api/v3"`. #' @param force Force installation, even if the remote state has not changed #' since the previous install. #' @inheritParams install_deps #' @param ... Other arguments passed on to [utils::install.packages()]. #' @details #' If the repository uses submodules a command-line git client is required to #' clone the submodules. #' @family package installation #' @export #' @seealso [github_pull()] #' @examples #' \dontrun{ #' install_github("klutometis/roxygen") #' install_github("wch/ggplot2", ref = github_pull("142")) #' install_github(c("rstudio/httpuv", "rstudio/shiny")) #' install_github(c("hadley/httr@@v0.4", "klutometis/roxygen#142", #' "r-lib/roxygen2@@*release", "mfrasca/r-logging/pkg")) #' #' # To install from a private repo, use auth_token with a token #' # from https://github.com/settings/tokens. You only need the #' # repo scope. Best practice is to save your PAT in env var called #' # GITHUB_PAT. #' install_github("hadley/private", auth_token = "abc") #' #' # To pass option arguments to `R CMD INSTALL` use `INSTALL_opts`. e.g. to #' install a package with source references and tests #' install_github("rstudio/shiny", INSTALL_opts = c("--with-keep.source", "--install-tests")) #' } install_github <- function(repo, ref = "HEAD", subdir = NULL, auth_token = github_pat(quiet), host = "api.github.com", dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { remotes <- lapply(repo, github_remote, ref = ref, subdir = subdir, auth_token = auth_token, host = host) install_remotes(remotes, auth_token = auth_token, host = host, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } #' Create a new github_remote #' #' This is an internal function to create a new github_remote, users should #' generally have no need for it. #' @inheritParams install_github #' @export #' @keywords internal github_remote <- function(repo, ref = "HEAD", subdir = NULL, auth_token = github_pat(), sha = NULL, host = "api.github.com", ...) { meta <- parse_git_repo(repo) meta <- github_resolve_ref(meta$ref %||% ref, meta, host = host, auth_token = auth_token) remote("github", host = host, package = meta$package, repo = meta$repo, subdir = meta$subdir %||% subdir, username = meta$username, ref = meta$ref, sha = sha, auth_token = auth_token ) } #' @export remote_download.github_remote <- function(x, quiet = FALSE) { if (!quiet) { message("Downloading GitHub repo ", x$username, "/", x$repo, "@", x$ref) } dest <- tempfile(fileext = paste0(".tar.gz")) src_root <- build_url(x$host, "repos", x$username, x$repo) src <- paste0(src_root, "/tarball/", utils::URLencode(x$ref, reserved = TRUE)) download(dest, src, auth_token = x$auth_token) } #' @export remote_metadata.github_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { if (!is.null(bundle)) { # Might be able to get from archive sha <- git_extract_sha1_tar(bundle) } else if (is_na(sha)) { sha <- NULL } list( RemoteType = "github", RemoteHost = x$host, RemotePackage = x$package, RemoteRepo = x$repo, RemoteUsername = x$username, RemoteRef = x$ref, RemoteSha = sha, RemoteSubdir = x$subdir, # Backward compatibility for packrat etc. GithubRepo = x$repo, GithubUsername = x$username, GithubRef = x$ref, GithubSHA1 = sha, GithubSubdir = x$subdir ) } #' GitHub references #' #' Use as `ref` parameter to [install_github()]. #' Allows installing a specific pull request or the latest release. #' #' @param pull Character string specifying the pull request to install #' @seealso [install_github()] #' @examples #' github_pull("42") #' @rdname github_refs #' @export github_pull <- function(pull) structure(pull, class = "github_pull") #' @rdname github_refs #' @export github_release <- function() structure(NA_integer_, class = "github_release") github_resolve_ref <- function(x, params, ...) UseMethod("github_resolve_ref") #' @export github_resolve_ref.default <- function(x, params, ...) { params$ref <- x params } #' @export github_resolve_ref.NULL <- function(x, params, ...) { params$ref <- "HEAD" params } #' @export github_resolve_ref.github_pull <- function(x, params, ..., host, auth_token = github_pat()) { # GET /repos/:user/:repo/pulls/:number path <- file.path("repos", params$username, params$repo, "pulls", x) response <- tryCatch( github_GET(path, host = host, pat = auth_token), error = function(e) e ) ## Just because libcurl might download the error page... if (methods::is(response, "error") || is.null(response$head)) { stop("Cannot find GitHub pull request ", params$username, "/", params$repo, "#", x, "\n", response$message) } params$username <- response$head$user$login params$ref <- response$head$ref params } # Retrieve the ref for the latest release #' @export github_resolve_ref.github_release <- function(x, params, ..., host, auth_token = github_pat()) { # GET /repos/:user/:repo/releases path <- paste("repos", params$username, params$repo, "releases", sep = "/") response <- tryCatch( github_GET(path, host = host, pat = auth_token), error = function(e) e ) if (methods::is(response, "error") || !is.null(response$message)) { stop("Cannot find repo ", params$username, "/", params$repo, ".", "\n", response$message) } if (length(response) == 0L) stop("No releases found for repo ", params$username, "/", params$repo, ".") params$ref <- response[[1L]]$tag_name params } #' @export remote_package_name.github_remote <- function(remote, ..., use_local = TRUE, use_curl = !is_standalone() && pkg_installed("curl")) { # If the package name was explicitly specified, use that if (!is.null(remote$package)) { return(remote$package) } # Otherwise if the repo is an already installed package assume that. if (isTRUE(use_local)) { local_name <- suppressWarnings(utils::packageDescription(remote$repo, fields = "Package")) if (!is.na(local_name)) { return(local_name) } } # Otherwise lookup the package name from the remote DESCRIPTION file desc <- github_DESCRIPTION(username = remote$username, repo = remote$repo, subdir = remote$subdir, host = remote$host, ref = remote$ref, pat = remote$auth_token %||% github_pat(), use_curl = use_curl) if (is.null(desc)) { return(NA_character_) } tmp <- tempfile() writeChar(desc, tmp) on.exit(unlink(tmp)) read_dcf(tmp)$Package } #' @export remote_sha.github_remote <- function(remote, ..., use_curl = !is_standalone() && pkg_installed("curl")) { tryCatch( github_commit(username = remote$username, repo = remote$repo, host = remote$host, ref = remote$ref, pat = remote$auth_token %||% github_pat(), use_curl = use_curl), # 422 errors most often occur when a branch or PR has been deleted, so we # ignore the error in this case http_422 = function(e) NA_character_ ) } #' @export format.github_remote <- function(x, ...) { "GitHub" } # Contents of R/install-gitlab.R #' Install a package from GitLab #' #' This function is vectorised on `repo` so you can install multiple #' packages in a single command. Like other remotes the repository will skip #' installation if `force == FALSE` (the default) and the remote state has #' not changed since the previous installation. #' #' @inheritParams install_github #' @param repo Repository address in the format #' `username/repo[@@ref]`. #' @param host GitLab API host to use. Override with your GitLab enterprise #' hostname, for example, `"gitlab.hostname.com"`. #' The PROTOCOL is required by packrat during Posit Connect deployment. While #' \link{install_gitlab} may work without, omitting it generally #' leads to package restoration errors. #' @param auth_token To install from a private repo, generate a personal access #' token (PAT) with at least read_api scope in #' \url{https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html} and #' supply to this argument. This is safer than using a password because you #' can easily delete a PAT without affecting any others. Defaults to the #' GITLAB_PAT environment variable. #' @inheritParams install_github #' @export #' @family package installation #' @examples #' \dontrun{ #' install_gitlab("jimhester/covr") #' } install_gitlab <- function(repo, subdir = NULL, auth_token = gitlab_pat(quiet), host = "gitlab.com", dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { remotes <- lapply(repo, gitlab_remote, subdir = subdir, auth_token = auth_token, host = host) install_remotes(remotes, auth_token = auth_token, host = host, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } gitlab_remote <- function(repo, subdir = NULL, auth_token = gitlab_pat(), sha = NULL, host = "gitlab.com", ...) { meta <- parse_git_repo(repo) meta$ref <- meta$ref %||% "HEAD" remote("gitlab", host = host, repo = paste(c(meta$repo, meta$subdir), collapse = "/"), subdir = subdir, username = meta$username, ref = meta$ref, sha = sha, auth_token = auth_token ) } #' @export remote_download.gitlab_remote <- function(x, quiet = FALSE) { dest <- tempfile(fileext = paste0(".tar.gz")) project_id <- gitlab_project_id(x$username, x$repo, x$ref, x$host, x$auth_token) src_root <- build_url(x$host, "api", "v4", "projects", project_id) src <- paste0(src_root, "/repository/archive.tar.gz?sha=", utils::URLencode(x$ref, reserved = TRUE)) if (!quiet) { message("Downloading GitLab repo ", x$username, "/", x$repo, "@", x$ref, "\nfrom URL ", src) } download(dest, src, headers = c("Private-Token" = x$auth_token)) } #' @export remote_metadata.gitlab_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { if (!is.null(bundle)) { # Might be able to get from archive sha <- git_extract_sha1_tar(bundle) } else if (is_na(sha)) { sha <- NULL } list( RemoteType = "gitlab", RemoteHost = x$host, RemoteRepo = x$repo, RemoteUsername = x$username, RemoteRef = x$ref, RemoteSha = sha, RemoteSubdir = x$subdir ) } #' @export remote_package_name.gitlab_remote <- function(remote, ...) { tmp <- tempfile() src_root <- build_url( remote$host, "api", "v4", "projects", utils::URLencode(paste0(remote$username, "/", remote$repo), reserved = TRUE), "repository") src <- paste0( src_root, "/files/", ifelse( is.null(remote$subdir), "DESCRIPTION", utils::URLencode(paste0(remote$subdir, "/DESCRIPTION"), reserved = TRUE)), "/raw?ref=", utils::URLencode(remote$ref, reserved = TRUE)) dest <- tempfile() res <- download(dest, src, headers = c("Private-Token" = remote$auth_token)) tryCatch( read_dcf(dest)$Package, error = function(e) remote$repo) } #' @export remote_sha.gitlab_remote <- function(remote, ...) { gitlab_commit(username = remote$username, repo = remote$repo, host = remote$host, ref = remote$ref, pat = remote$auth_token) } #' @export format.gitlab_remote <- function(x, ...) { "GitLab" } gitlab_commit <- function(username, repo, ref = "HEAD", host = "gitlab.com", pat = gitlab_pat()) { url <- build_url(host, "api", "v4", "projects", utils::URLencode(paste0(username, "/", repo), reserved = TRUE), "repository", "commits", utils::URLencode(ref, reserved = TRUE)) tmp <- tempfile() download(tmp, url, headers = c("Private-Token" = pat)) json$parse_file(tmp)$id } #' Retrieve GitLab personal access token. #' #' A GitLab personal access token #' Looks in env var `GITLAB_PAT` #' #' @keywords internal #' @export gitlab_pat <- function(quiet = TRUE) { pat <- Sys.getenv("GITLAB_PAT") if (nzchar(pat)) { if (!quiet) { message("Using GitLab PAT from envvar GITLAB_PAT") } return(pat) } return(NULL) } gitlab_project_id <- function(username, repo, ref = "HEAD", host = "gitlab.com", pat = gitlab_pat()) { url <- build_url(host, "api", "v4", "projects", utils::URLencode(paste0(username, "/", repo), reserved = TRUE), "repository", "commits", utils::URLencode(ref, reserved = TRUE)) tmp <- tempfile() download(tmp, url, headers = c("Private-Token" = pat)) json$parse_file(tmp)$project_id } # Contents of R/install-local.R #' Install a package from a local file #' #' This function is vectorised so you can install multiple packages in #' a single command. #' #' @param path path to local directory, or compressed file (tar, zip, tar.gz #' tar.bz2, tgz2 or tbz) #' @inheritParams install_url #' @inheritParams install_github #' @export #' @family package installation #' @examples #' \dontrun{ #' dir <- tempfile() #' dir.create(dir) #' pkg <- download.packages("testthat", dir, type = "source") #' install_local(pkg[, 2]) #' } install_local <- function(path = ".", subdir = NULL, dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = !is_binary_pkg(path), build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { remotes <- lapply(path, local_remote, subdir = subdir) install_remotes(remotes, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } local_remote <- function(path, subdir = NULL, branch = NULL, args = character(0), ...) { remote("local", path = normalizePath(path), subdir = subdir ) } #' @export remote_download.local_remote <- function(x, quiet = FALSE) { # Already downloaded - just need to copy to tempdir() bundle <- tempfile() dir.create(bundle) suppressWarnings( res <- file.copy(x$path, bundle, recursive = TRUE) ) if (!all(res)) { stop("Could not copy `", x$path, "` to `", bundle, "`", call. = FALSE) } # file.copy() creates directory inside of bundle dir(bundle, full.names = TRUE)[1] } #' @export remote_metadata.local_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { list( RemoteType = "local", RemoteUrl = x$path, RemoteSubdir = x$subdir ) } #' @export remote_package_name.local_remote <- function(remote, ...) { is_tarball <- !dir.exists(remote$path) if (is_tarball) { # Assume the name is the name of the tarball return(sub("_.*$", "", basename(remote$path))) } description_path <- file.path(remote$path, "DESCRIPTION") read_dcf(description_path)$Package } #' @export remote_sha.local_remote <- function(remote, ...) { is_tarball <- !dir.exists(remote$path) if (is_tarball) { return(NA_character_) } read_dcf(file.path(remote$path, "DESCRIPTION"))$Version } #' @export format.local_remote <- function(x, ...) { "local" } # Contents of R/install-remote.R #' Install a remote package. #' #' This: #' \enumerate{ #' \item downloads source bundle #' \item decompresses & checks that it's a package #' \item adds metadata to DESCRIPTION #' \item calls install #' } #' #' It uses the additional S3 generic functions to work. Writing methods for #' these functions would allow 3rd party packages to define custom remotes. #' @inheritParams install_github #' @keywords internal #' @export install_remote <- function(remote, dependencies, upgrade, force, quiet, build, build_opts, build_manual, build_vignettes, repos, type, ...) { stopifnot(is.remote(remote)) package_name <- remote_package_name(remote) local_sha <- local_sha(package_name) remote_sha <- remote_sha(remote, local_sha) if (!isTRUE(force) && !different_sha(remote_sha = remote_sha, local_sha = local_sha)) { if (!quiet) { message( "Skipping install of '", package_name, "' from a ", sub("_remote", "", class(remote)[1L]), " remote,", " the SHA1 (", substr(remote_sha, 1L, 8L), ") has not changed since last install.\n", " Use `force = TRUE` to force installation") } return(invisible(package_name)) } if (inherits(remote, "cran_remote")) { install_packages( package_name, repos = remote$repos, type = remote$pkg_type, dependencies = dependencies, quiet = quiet, ...) return(invisible(package_name)) } res <- try(bundle <- remote_download(remote, quiet = quiet), silent = quiet) if (inherits(res, "try-error")) { return(NA_character_) } on.exit(unlink(bundle), add = TRUE) source <- source_pkg(bundle, subdir = remote$subdir) on.exit(unlink(source, recursive = TRUE), add = TRUE) update_submodules(source, remote$subdir, quiet) add_metadata(source, remote_metadata(remote, bundle, source, remote_sha)) # Because we've modified DESCRIPTION, its original MD5 value is wrong clear_description_md5(source) install(source, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } install_remotes <- function(remotes, ...) { res <- character(length(remotes)) for (i in seq_along(remotes)) { tryCatch( res[[i]] <- install_remote(remotes[[i]], ...), error = function(e) { stop(remote_install_error(remotes[[i]], e)) }) } invisible(res) } remote_install_error <- function(remote, error) { msg <- sprintf( "Failed to install '%s' from %s:\n %s", remote_name_or_unknown(remote), format(remote), conditionMessage(error) ) structure(list(message = msg, call = NULL, error = error, remote = remote), class = c("install_error", "error", "condition")) } remote_name_or_unknown <- function(remote) { res <- tryCatch( res <- remote_package_name(remote), error = function(e) NA_character_) if (is.na(res)) { return("unknown package") } res } #' @rdname install_remote #' @export #' @keywords internal add_metadata <- function(pkg_path, meta) { # During installation, the DESCRIPTION file is read and an package.rds file # created with most of the information from the DESCRIPTION file. Functions # that read package metadata may use either the DESCRIPTION file or the # package.rds file, therefore we attempt to modify both of them source_desc <- file.path(pkg_path, "DESCRIPTION") binary_desc <- file.path(pkg_path, "Meta", "package.rds") if (file.exists(source_desc)) { desc <- read_dcf(source_desc) desc <- utils::modifyList(desc, meta) write_dcf(source_desc, desc) } if (file.exists(binary_desc)) { pkg_desc <- base::readRDS(binary_desc) desc <- as.list(pkg_desc$DESCRIPTION) desc <- utils::modifyList(desc, meta) pkg_desc$DESCRIPTION <- stats::setNames(as.character(desc), names(desc)) base::saveRDS(pkg_desc, binary_desc) } } # Modify the MD5 file - remove the line for DESCRIPTION clear_description_md5 <- function(pkg_path) { path <- file.path(pkg_path, "MD5") if (file.exists(path)) { text <- readLines(path) text <- text[!grepl(".*\\*DESCRIPTION$", text)] writeLines(text, path) } } remote <- function(type, ...) { structure(list(...), class = c(paste0(type, "_remote"), "remote")) } is.remote <- function(x) inherits(x, "remote") #' @rdname install_remote #' @keywords internal #' @export remote_download <- function(x, quiet = FALSE) UseMethod("remote_download") #' @rdname install_remote #' @keywords internal #' @export remote_metadata <- function(x, bundle = NULL, source = NULL, sha = NULL) UseMethod("remote_metadata") #' @rdname install_remote #' @keywords internal #' @export remote_package_name <- function(remote, ...) UseMethod("remote_package_name") #' @rdname install_remote #' @keywords internal #' @export remote_sha <- function(remote, ...) UseMethod("remote_sha") #' @export remote_package_name.default <- function(remote, ...) remote$repo #' @export remote_sha.default <- function(remote, ...) NA_character_ different_sha <- function(remote_sha, local_sha) { same <- remote_sha == local_sha same <- isTRUE(same) && !is.na(same) !same } local_sha <- function(name) { package2remote(name)$sha %||% NA_character_ } # Convert an installed package to its equivalent remote. This constructs the # remote from metadata stored in the package's DESCRIPTION file; the metadata # is added to the package when it is installed by remotes. If the package is # installed some other way, such as by `install.packages()` there will be no # meta-data, so there we construct a generic CRAN remote. package2remote <- function(name, lib = .libPaths(), repos = getOption("repos"), type = getOption("pkgType")) { x <- tryCatch(utils::packageDescription(name, lib.loc = lib), error = function(e) NA, warning = function(e) NA) # will be NA if not installed if (identical(x, NA)) { return(remote("cran", name = name, repos = repos, pkg_type = type, sha = NA_character_)) } if (is.null(x$RemoteType) || x$RemoteType %in% c("cran", "standard", "any")) { # Packages installed with install.packages() or locally without remotes return(remote("cran", name = x$Package, repos = repos, pkg_type = type, sha = x$Version)) } switch(x$RemoteType, standard = remote("cran", name = x$Package, repos = x$RemoteRepos %||% repos, pkg_type = x$RemotePkgType %||% type, sha = x$RemoteSha), github = remote("github", host = x$RemoteHost, package = x$RemotePackage, repo = x$RemoteRepo, subdir = x$RemoteSubdir, username = x$RemoteUsername, ref = x$RemoteRef, sha = x$RemoteSha, auth_token = github_pat()), gitlab = remote("gitlab", host = x$RemoteHost, repo = x$RemoteRepo, subdir = x$RemoteSubdir, username = x$RemoteUsername, ref = x$RemoteRef, sha = x$RemoteSha, auth_token = gitlab_pat()), xgit = remote("xgit", url = trim_ws(x$RemoteUrl), ref = x$RemoteRef %||% x$RemoteBranch, sha = x$RemoteSha, subdir = x$RemoteSubdir, args = x$RemoteArgs), git2r = remote("git2r", url = trim_ws(x$RemoteUrl), ref = x$RemoteRef %||% x$RemoteBranch, sha = x$RemoteSha, subdir = x$RemoteSubdir, credentials = git_credentials()), bitbucket = remote("bitbucket", host = x$RemoteHost, repo = x$RemoteRepo, username = x$RemoteUsername, ref = x$RemoteRef, sha = x$RemoteSha, subdir = x$RemoteSubdir, auth_user = bitbucket_user(), password = bitbucket_password()), svn = remote("svn", url = trim_ws(x$RemoteUrl), svn_subdir = x$RemoteSubdir, revision = x$RemoteSha, args = x$RemoteArgs), local = remote("local", path = { path <- trim_ws(x$RemoteUrl) if (length(path) == 0) { path <- parse_pkg_ref(x$RemotePkgRef)$ref } path }, subdir = x$RemoteSubdir, sha = { # Packages installed locally might have RemoteSha == NA_character_ x$RemoteSha %||% x$Version }), url = remote("url", url = trim_ws(x$RemoteUrl), subdir = x$RemoteSubdir, config = x$RemoteConfig, pkg_type = x$RemotePkgType %||% type), bioc_git2r = remote("bioc_git2r", mirror = x$RemoteMirror, repo = x$RemoteRepo, release = x$RemoteRelease, sha = x$RemoteSha, branch = x$RemoteBranch), bioc_xgit = remote("bioc_xgit", mirror = x$RemoteMirror, repo = x$RemoteRepo, release = x$RemoteRelease, sha = x$RemoteSha, branch = x$RemoteBranch), stop(sprintf("can't convert package %s with RemoteType '%s' to remote", name, x$RemoteType)) ) } parse_pkg_ref <- function(x) { res <- re_match(x, "(?[^:]+)::(?.*)") if (is.na(res$ref)) { stop("Invalid package reference:\n ", x, call. = FALSE) } res } #' @export format.remotes <- function(x, ...) { vapply(x, format, character(1)) } # Contents of R/install-svn.R #' Install a package from a SVN repository #' #' This function requires \command{svn} to be installed on your system in order to #' be used. #' #' It is vectorised so you can install multiple packages with #' a single command. #' #' @inheritParams install_git #' @param subdir A sub-directory within a svn repository that contains the #' package we are interested in installing. #' @param args A character vector providing extra options to pass on to #' \command{svn}. #' @param revision svn revision, if omitted updates to latest #' @param ... Other arguments passed on to [utils::install.packages()]. #' @inheritParams install_github #' @family package installation #' @export #' #' @examples #' \dontrun{ #' install_svn("https://github.com/hadley/stringr/trunk") #' install_svn("https://github.com/hadley/httr/branches/oauth") #'} install_svn <- function(url, subdir = NULL, args = character(0), revision = NULL, dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { remotes <- lapply(url, svn_remote, svn_subdir = subdir, revision = revision, args = args) install_remotes(remotes, args = args, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } svn_remote <- function(url, svn_subdir = NULL, revision = NULL, args = character(0), ...) { remote("svn", url = url, svn_subdir = svn_subdir, revision = revision, args = args ) } #' @export remote_download.svn_remote <- function(x, quiet = FALSE) { if (!quiet) { message("Downloading svn repo ", x$url) } bundle <- tempfile() svn_binary_path <- svn_path() url <- x$url args <- "co" if (!is.null(x$revision)) { args <- c(args, "-r", x$revision) } args <- c(args, x$args, full_svn_url(x), bundle) if (!quiet) { message(shQuote(svn_binary_path), " ", paste0(args, collapse = " ")) } request <- system2(svn_binary_path, args, stdout = FALSE, stderr = FALSE) # This is only looking for an error code above 0-success if (request > 0) { stop("There seems to be a problem retrieving this SVN-URL.", call. = FALSE) } in_dir(bundle, { if (!is.null(x$revision)) { request <- system2(svn_binary_path, paste("update -r", x$revision), stdout = FALSE, stderr = FALSE) if (request > 0) { stop("There was a problem switching to the requested SVN revision", call. = FALSE) } } }) bundle } #' @export remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { if (!is.null(bundle)) { in_dir(bundle, { revision <- svn_revision() }) } else { revision <- sha } list( RemoteType = "svn", RemoteUrl = x$url, RemoteSubdir = x$svn_subdir, RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " "), RemoteSha = revision # for compatibility with other remotes ) } svn_path <- function(svn_binary_name = NULL) { # Use user supplied path if (!is.null(svn_binary_name)) { if (!file.exists(svn_binary_name)) { stop("Path ", svn_binary_name, " does not exist", .call = FALSE) } return(svn_binary_name) } # Look on path svn_path <- Sys.which("svn")[[1]] if (svn_path != "") return(svn_path) # On Windows, look in common locations if (os_type() == "windows") { look_in <- c( "C:/Program Files/Svn/bin/svn.exe", "C:/Program Files (x86)/Svn/bin/svn.exe" ) found <- file.exists(look_in) if (any(found)) return(look_in[found][1]) } stop("SVN does not seem to be installed on your system.", call. = FALSE) } #' @export remote_package_name.svn_remote <- function(remote, ...) { description_url <- file.path(full_svn_url(remote), "DESCRIPTION") tmp_file <- tempfile() on.exit(rm(tmp_file)) response <- system2(svn_path(), paste("cat", description_url), stdout = tmp_file) if (!identical(response, 0L)) { return(NA_character_) } read_dcf(tmp_file)$Package } #' @export remote_sha.svn_remote <- function(remote, ...) { svn_revision(full_svn_url(remote)) } svn_revision <- function(url = NULL, svn_binary_path = svn_path()) { request <- system2(svn_binary_path, paste("info --xml", url), stdout = TRUE) if (!is.null(attr(request, "status")) && !identical(attr(request, "status"), 0L)) { stop("There was a problem retrieving the current SVN revision", call. = FALSE) } gsub(".*.*", "\\1", paste(collapse = "\n", request)) } full_svn_url <- function(x) { url <- x$url if (!is.null(x$svn_subdir)) { url <- file.path(url, x$svn_subdir) } url } format.svn_remote <- function(x, ...) { "SVN" } # Contents of R/install-url.R #' Install a package from a url #' #' This function is vectorised so you can install multiple packages in #' a single command. #' #' @param url location of package on internet. The url should point to a #' zip file, a tar file or a bzipped/gzipped tar file. #' @param subdir subdirectory within url bundle that contains the R package. #' @param ... Other arguments passed on to [utils::install.packages()]. #' @inheritParams install_github #' @export #' #' @family package installation #' @examples #' \dontrun{ #' install_url("https://github.com/hadley/stringr/archive/HEAD.zip") #' } install_url <- function(url, subdir = NULL, dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = getOption("pkgType"), ...) { remotes <- lapply(url, url_remote, subdir = subdir) install_remotes(remotes, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ...) } url_remote <- function(url, subdir = NULL, ...) { remote("url", url = url, subdir = subdir ) } #' @importFrom tools file_ext #' @export remote_download.url_remote <- function(x, quiet = FALSE) { if (!quiet) { message("Downloading package from url: ", x$url) # nocov } ext <- if (grepl("\\.tar\\.gz$", x$url)) "tar.gz" else file_ext(x$url) bundle <- tempfile(fileext = paste0(".", ext)) download(bundle, x$url) } #' @export remote_metadata.url_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { list( RemoteType = "url", RemoteUrl = x$url, RemoteSubdir = x$subdir ) } #' @export remote_package_name.url_remote <- function(remote, ...) { NA_character_ } #' @export remote_sha.url_remote <- function(remote, ...) { NA_character_ } #' @export format.url_remote <- function(x, ...) { "URL" } # Contents of R/install-version.R #' Install specific version of a package. #' #' This function knows how to look in multiple CRAN-like package repositories, and in their #' \code{archive} directories, in order to find specific versions of the requested package. #' #' The repositories are searched in the order specified by the \code{repos} argument. This enables #' teams to maintain multiple in-house repositories with different policies - for instance, one repo #' for development snapshots and one for official releases. A common setup would be to first search #' the official release repo, then the dev snapshot repo, then a public CRAN mirror. #' #' Older versions of packages on CRAN are usually only available in source form. If your requested #' package contains compiled code, you will need to have an R development environment installed. You #' can check if you do by running `devtools::has_devel` (you need the `devtools` package for this). #' #' @export #' @family package installation #' @param package Name of the package to install. #' @param version Version of the package to install. Can either be a string giving the exact #' version required, or a specification in the same format as the parenthesized expressions used #' in package dependencies. One of the following formats: #' - An exact version required, as a string, e.g. `"0.1.13"` #' - A comparison operator and a version, e.g. `">= 0.1.12"` #' - Several criteria to satisfy, as a comma-separated string, e.g. `">= 1.12.0, < 1.14"` #' - Several criteria to satisfy, as elements of a character vector, e.g. `c(">= 1.12.0", "< 1.14")` #' @param ... Other arguments passed on to [utils::install.packages()]. #' @inheritParams utils::install.packages #' @inheritParams install_github #' @examples #' \dontrun{ #' install_version("devtools", "1.11.0") #' install_version("devtools", ">= 1.12.0, < 1.14") #' #' ## Specify search order (e.g. in ~/.Rprofile) #' options(repos = c( #' prod = "http://mycompany.example.com/r-repo", #' dev = "http://mycompany.example.com/r-repo-dev", #' CRAN = "https://cran.revolutionanalytics.com" #' )) #' install_version("mypackage", "1.15") # finds in 'prod' #' install_version("mypackage", "1.16-39487") # finds in 'dev' #' } #' @importFrom utils available.packages contrib.url install.packages install_version <- function(package, version = NULL, dependencies = NA, upgrade = c("default", "ask", "always", "never"), force = FALSE, quiet = FALSE, build = FALSE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, repos = getOption("repos"), type = "source", ...) { # TODO would it make sense to vectorize this, e.g. `install_version(c("foo", "bar"), c("1.1", "2.2"))`? if (length(package) < 1) { return() } if (length(package) > 1) { stop("install_version() must be called with a single 'package' argument - multiple packages given") } if (!identical(type, "source")) { stop("`type` must be 'source' for `install_version()`", call. = FALSE) } url <- download_version_url(package, version, repos, type) res <- install_url(url, dependencies = dependencies, upgrade = upgrade, force = force, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, repos = repos, type = type, ... ) lib <- list(...)$lib %||% .libPaths() # Remove Metadata from installed package add_metadata( system.file(package = package, lib.loc = lib), list(RemoteType = NULL, RemoteUrl = NULL, RemoteSubdir = NULL) ) invisible(res) } version_from_tarball <- function(tarball_name) { package_ver_regex <- paste0(".+_(", .standard_regexps()$valid_package_version, ")\\.tar\\.gz$") ifelse(grepl(package_ver_regex, tarball_name), sub(package_ver_regex, "\\1", tarball_name), NULL) } version_satisfies_criteria <- function(to_check, criteria) { to_check <- package_version(to_check) result <- apply(version_criteria(criteria), 1, function(r) { if (is.na(r["compare"])) { TRUE } else { get(r["compare"], mode = "function")(to_check, r["version"]) } }) all(result) } package_installed <- function(pkg, criteria) { v <- suppressWarnings(utils::packageDescription(pkg, fields = "Version")) !is.na(v) && version_satisfies_criteria(v, criteria) } version_criteria <- function(criteria) { if (is.character(criteria) && length(criteria) == 1) { criteria <- strsplit(criteria, ",")[[1]] } numeric_ver <- .standard_regexps()$valid_numeric_version package <- "p" # dummy package name, required by parse_deps() spec <- if (is.null(criteria) || (length(criteria) == 1 && is.na(criteria[[1L]]))) { package } else { ifelse(grepl(paste0("^", numeric_ver, "$"), criteria), paste0(package, "(== ", criteria, ")"), paste0(package, "(", criteria, ")") ) } parse_deps(paste(spec, collapse = ", "))[c("compare", "version")] } # Find a given package record in the `archive.rds` file of a repository package_find_archives <- function(package, repo, verbose = FALSE) { if (verbose) { message("Trying ", repo) } # TODO it would be nice to cache these downloaded files like `available.packages` does archive <- tryCatch( { tf <- tempfile(fileext = ".gz") on.exit(unlink(tf), add = TRUE) download(tf, sprintf("%s/src/contrib/Meta/archive.rds", repo)) con <- gzfile(tf, "rb") on.exit(close(con), add = TRUE) readRDS(con) }, warning = function(e) list(), error = function(e) list() ) info <- archive[[package]] if (!is.null(info)) { info$repo <- repo return(info) } NULL } #' Download a specified version of a CRAN package #' #' It downloads the package to a temporary file, and #' returns the name of the file. #' #' @inheritParams install_version #' @return Name of the downloaded file. #' #' @export download_version <- function(package, version = NULL, repos = getOption("repos"), type = getOption("pkgType"), ...) { url <- download_version_url(package, version, repos, type) download(path = tempfile(), url = url) } download_version_url <- function(package, version, repos, type, available, verbose = length(repos) > 1) { ## TODO should we do for(r in repos) { for (t in c('published','archive')) {...}}, or ## for (t in c('published','archive')) { for(r in repos) {...}} ? Right now it's the latter. It ## only matters if required version is satisfied by both an early repo in archive/ and a late repo if (missing(available)) { contriburl <- contrib.url(repos, type) available <- available.packages(contriburl, filters = c("R_version", "OS_type", "subarch")) } package_exists <- FALSE # available.packages() returns a matrix with entries in the same order as the repositories in # `repos`, so the first packages we encounter should be preferred. for (ix in which(available[, "Package"] == package)) { package_exists <- TRUE row <- available[ix, ] if (version_satisfies_criteria(row["Version"], version)) { return(paste0( row["Repository"], "/", row["Package"], "_", row["Version"], ".tar.gz" )) } } for (repo in repos) { info <- package_find_archives(package, repo, verbose = verbose) if (is.null(info)) { next } package_exists <- TRUE for (i in rev(seq_len(nrow(info)))) { package_path <- row.names(info)[i] if (version_satisfies_criteria(version_from_tarball(package_path), version)) { return(file.path(repo, "src", "contrib", "Archive", package_path)) } } } if (!package_exists) { stop(sprintf("couldn't find package '%s'", package)) } stop(sprintf("version '%s' is invalid for package '%s'", version, package)) } # Contents of R/install.R install <- function(pkgdir, dependencies, quiet, build, build_opts, build_manual, build_vignettes, upgrade, repos, type, ...) { warn_for_potential_errors() if (file.exists(file.path(pkgdir, "src"))) { if (!is_standalone() && has_package("pkgbuild")) { pkgbuild::local_build_tools(required = TRUE) } else if (!has_devel()) { missing_devel_warning(pkgdir) } } pkg_name <- load_pkg_description(pkgdir)$package ## Check for circular dependencies. We need to know about the root ## of the install process. if (is_root_install()) on.exit(exit_from_root_install(), add = TRUE) if (check_for_circular_dependencies(pkgdir, quiet)) { return(invisible(pkg_name)) } install_deps(pkgdir, dependencies = dependencies, quiet = quiet, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, upgrade = upgrade, repos = repos, type = type, ...) if (isTRUE(build)) { dir <- tempfile() dir.create(dir) on.exit(unlink(dir), add = TRUE) pkgdir <- safe_build_package(pkgdir, build_opts, build_manual, build_vignettes, dir, quiet) } safe_install_packages( pkgdir, repos = NULL, quiet = quiet, type = "source", ... ) invisible(pkg_name) } safe_install_packages <- function(...) { lib <- paste(.libPaths(), collapse = .Platform$path.sep) if (!is_standalone() && has_package("crancache") && has_package("callr")) { i.p <- "crancache" %::% "install_packages" } else { i.p <- utils::install.packages } with_options(list(install.lock = getOption("install.lock", TRUE)), { with_envvar( c(R_LIBS = lib, R_LIBS_USER = lib, R_LIBS_SITE = lib, RGL_USE_NULL = "TRUE"), # Set options(warn = 2) for this process and child processes, so that # warnings from `install.packages()` are converted to errors. if (should_error_for_warnings()) { with_options(list(warn = 2), with_rprofile_user("options(warn = 2)", i.p(...) ) ) } else { i.p(...) } ) }) } normalize_build_opts <- function(build_opts, build_manual, build_vignettes) { if (!isTRUE(build_manual)) { build_opts <- union(build_opts, "--no-manual") } else { build_opts <- setdiff(build_opts, "--no-manual") } if (!isTRUE(build_vignettes)) { build_opts <- union(build_opts, "--no-build-vignettes") } else { build_opts <- setdiff(build_opts, "--no-build-vignettes") } build_opts } safe_build_package <- function(pkgdir, build_opts, build_manual, build_vignettes, dest_path, quiet, use_pkgbuild = !is_standalone() && pkg_installed("pkgbuild")) { build_opts <- normalize_build_opts(build_opts, build_manual, build_vignettes) if (use_pkgbuild) { vignettes <- TRUE manual <- FALSE has_no_vignettes <- grepl("--no-build-vignettes", build_opts) if (any(has_no_vignettes)) { vignettes <- FALSE } has_no_manual <- grepl("--no-manual", build_opts) if (!any(has_no_manual)) { manual <- TRUE } build_opts <- build_opts[!(has_no_vignettes | has_no_manual)] pkgbuild::build(pkgdir, dest_path = dest_path, binary = FALSE, vignettes = vignettes, manual = manual, args = build_opts, quiet = quiet) } else { # No pkgbuild, so we need to call R CMD build ourselves lib <- paste(.libPaths(), collapse = .Platform$path.sep) env <- c(R_LIBS = lib, R_LIBS_USER = lib, R_LIBS_SITE = lib, R_PROFILE_USER = tempfile()) pkgdir <- normalizePath(pkgdir) message("Running `R CMD build`...") in_dir(dest_path, { with_envvar(env, { output <- rcmd("build", c(build_opts, shQuote(pkgdir)), quiet = quiet, fail_on_status = FALSE) }) }) if (output$status != 0) { cat("STDOUT:\n") cat(output$stdout, sep = "\n") cat("STDERR:\n") cat(output$stderr, sep = "\n") msg_for_long_paths(output) stop(sprintf("Failed to `R CMD build` package, try `build = FALSE`."), call. = FALSE) } building_regex <- paste0( "^[*] building[^[:alnum:]]+", # prefix, "* building '" "([-[:alnum:]_.]+)", # package file name, e.g. xy_1.0-2.tar.gz "[^[:alnum:]]+$" # trailing quote ) pkgfile <- sub(building_regex, "\\1", output$stdout[length(output$stdout)]) file.path(dest_path, pkgfile) } } msg_for_long_paths <- function(output) { if (sys_type() == "windows" && (r_error_matches("over-long path", output$stderr) || r_error_matches("over-long path length", output$stderr))) { message( "\nIt seems that this package contains files with very long paths.\n", "This is not supported on most Windows versions. Please contact the\n", "package authors and tell them about this. See this GitHub issue\n", "for more details: https://github.com/r-lib/remotes/issues/84\n") } } r_error_matches <- function(msg, str) { any(grepl(msg, str)) || any(grepl(gettext(msg, domain = "R"), str)) } #' Install package dependencies if needed. #' #' @inheritParams package_deps #' @param ... additional arguments passed to [utils::install.packages()]. #' @param build If `TRUE` build the package before installing. #' @param build_opts Options to pass to `R CMD build`, only used when `build` is `TRUE`. #' @param build_manual If `FALSE`, don't build PDF manual ('--no-manual'). #' @param build_vignettes If `FALSE`, don't build package vignettes ('--no-build-vignettes'). #' @export #' @examples #' \dontrun{install_deps(".")} install_deps <- function(pkgdir = ".", dependencies = NA, repos = getOption("repos"), type = getOption("pkgType"), upgrade = c("default", "ask", "always", "never"), quiet = FALSE, build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), build_manual = FALSE, build_vignettes = FALSE, ...) { packages <- dev_package_deps( pkgdir, repos = repos, dependencies = dependencies, type = type ) dep_deps <- if (isTRUE(dependencies)) NA else dependencies update( packages, dependencies = dep_deps, quiet = quiet, upgrade = upgrade, build = build, build_opts = build_opts, build_manual = build_manual, build_vignettes = build_vignettes, type = type, repos = repos, ... ) } should_error_for_warnings <- function() { no_errors <- Sys.getenv("R_REMOTES_NO_ERRORS_FROM_WARNINGS", "true") !config_val_to_logical(no_errors) } # Contents of R/json.R # Standalone JSON parser # # The purpose of this file is to provide a standalone JSON parser. # It is quite slow and bare. If you need a proper parser please use the # jsonlite package. # # The canonical location of this file is in the remotes package: # https://github.com/r-lib/remotes/blob/HEAD/R/json.R # # API: # parse(text) # parse_file(filename) # # NEWS: # - 2019/05/15 First standalone version json <- local({ tokenize_json <- function(text) { text <- paste(text, collapse = "\n") ESCAPE <- '(\\\\[^u[:cntrl:]]|\\\\u[0-9a-fA-F]{4})' CHAR <- '[^[:cntrl:]"\\\\]' STRING <- paste0('"', CHAR, '*(', ESCAPE, CHAR, '*)*"') NUMBER <- "-?(0|[1-9][0-9]*)([.][0-9]*)?([eE][+-]?[0-9]*)?" KEYWORD <- 'null|false|true' SPACE <- '[[:space:]]+' match <- gregexpr( pattern = paste0( STRING, "|", NUMBER, "|", KEYWORD, "|", SPACE, "|", "." ), text = text, perl = TRUE ) grep("^\\s+$", regmatches(text, match)[[1]], value = TRUE, invert = TRUE) } throw <- function(...) { stop("JSON: ", ..., call. = FALSE) } # Parse a JSON file # # @param filename Path to the JSON file. # @return R objects corresponding to the JSON file. parse_file <- function(filename) { parse(readLines(filename, warn = FALSE)) } # Parse a JSON string # # @param text JSON string. # @return R object corresponding to the JSON string. parse <- function(text) { tokens <- tokenize_json(text) token <- NULL ptr <- 1 read_token <- function() { if (ptr <= length(tokens)) { token <<- tokens[ptr] ptr <<- ptr + 1 } else { token <<- 'EOF' } } parse_value <- function(name = "") { if (token == "{") { parse_object() } else if (token == "[") { parse_array() } else if (token == "EOF" || (nchar(token) == 1 && ! token %in% 0:9)) { throw("EXPECTED value GOT ", token) } else { j2r(token) } } parse_object <- function() { res <- structure(list(), names = character()) read_token() ## Invariant: we are at the beginning of an element while (token != "}") { ## "key" if (grepl('^".*"$', token)) { key <- j2r(token) } else { throw("EXPECTED string GOT ", token) } ## : read_token() if (token != ":") { throw("EXPECTED : GOT ", token) } ## value read_token() res[key] <- list(parse_value()) ## } or , read_token() if (token == "}") { break } else if (token != ",") { throw("EXPECTED , or } GOT ", token) } read_token() } res } parse_array <- function() { res <- list() read_token() ## Invariant: we are at the beginning of an element while (token != "]") { ## value res <- c(res, list(parse_value())) ## ] or , read_token() if (token == "]") { break } else if (token != ",") { throw("EXPECTED , GOT ", token) } read_token() } res } read_token() parse_value(tokens) } j2r <- function(token) { if (token == "null") { NULL } else if (token == "true") { TRUE } else if (token == "false") { FALSE } else if (grepl('^".*"$', token)) { trimq(token) } else { as.numeric(token) } } trimq <- function(x) { sub('^"(.*)"$', "\\1", x) } structure( list( .internal = environment(), parse = parse, parse_file = parse_file ), class = c("standalone_json", "standalone")) }) # Contents of R/package-deps.R parse_deps <- function(string) { if (is.null(string)) return() stopifnot(is.character(string), length(string) == 1) if (grepl("^\\s*$", string)) return() # Split by commas with surrounding whitespace removed pieces <- strsplit(string, "[[:space:]]*,[[:space:]]*")[[1]] # Get the names names <- gsub("\\s*\\(.*?\\)", "", pieces) names <- gsub("^\\s+|\\s+$", "", names) # Get the versions and comparison operators versions_str <- pieces have_version <- grepl("\\(.*\\)", versions_str) versions_str[!have_version] <- NA compare <- sub(".*\\(\\s*(\\S+)\\s+.*\\s*\\).*", "\\1", versions_str) versions <- sub(".*\\(\\s*\\S+\\s+(\\S*)\\s*\\).*", "\\1", versions_str) # Check that non-NA comparison operators are valid compare_nna <- compare[!is.na(compare)] compare_valid <- compare_nna %in% c(">", ">=", "==", "<=", "<") if(!all(compare_valid)) { stop("Invalid comparison operator in dependency: ", paste(compare_nna[!compare_valid], collapse = ", ")) } deps <- data.frame(name = names, compare = compare, version = versions, stringsAsFactors = FALSE) # Remove R dependency deps[names != "R", ] } # Contents of R/package.R load_pkg_description <- function(path) { path <- normalizePath(path, mustWork = TRUE) if (!is_dir(path)) { dir <- tempfile() path_desc <- untar_description(path, dir = dir) on.exit(unlink(dir, recursive = TRUE)) } else { path_desc <- file.path(path, "DESCRIPTION") } desc <- read_dcf(path_desc) names(desc) <- tolower(names(desc)) desc$path <- path desc } # Contents of R/parse-git.R #' Parse a remote git repo specification #' #' A remote repo can be specified in two ways: #' \describe{ #' \item{as a URL}{`parse_github_url()` handles HTTPS and SSH remote URLs #' and various GitHub browser URLs} #' \item{via a shorthand}{`parse_repo_spec()` handles this concise form: #' `[username/]repo[/subdir][#pull|@ref|@*release]`} #' } #' #' @param repo Character scalar, the repo specification. #' @return List with members: `username`, `repo`, `subdir` #' `ref`, `pull`, `release`, some which will be empty. #' #' @name parse-git-repo #' @examples #' parse_repo_spec("metacran/crandb") #' parse_repo_spec("jimhester/covr#47") ## pull request #' parse_repo_spec("jeroen/curl@v0.9.3") ## specific tag #' parse_repo_spec("tidyverse/dplyr@*release") ## shorthand for latest release #' parse_repo_spec("r-lib/remotes@550a3c7d3f9e1493a2ba") ## commit SHA #' parse_repo_spec("igraph=igraph/rigraph") ## Different package name from repo name #' #' parse_github_url("https://github.com/jeroen/curl.git") #' parse_github_url("git@github.com:metacran/crandb.git") #' parse_github_url("https://github.com/jimhester/covr") #' parse_github_url("https://github.example.com/user/repo.git") #' parse_github_url("git@github.example.com:user/repo.git") #' #' parse_github_url("https://github.com/r-lib/remotes/pull/108") #' parse_github_url("https://github.com/r-lib/remotes/tree/name-of-branch") #' parse_github_url("https://github.com/r-lib/remotes/commit/1234567") #' parse_github_url("https://github.com/r-lib/remotes/releases/latest") #' parse_github_url("https://github.com/r-lib/remotes/releases/tag/1.0.0") NULL #' @export #' @rdname parse-git-repo parse_repo_spec <- function(repo) { package_name_rx <- "(?:(?[[:alpha:]][[:alnum:].]*[[:alnum:]])=)?" username_rx <- "(?:(?[^/]+)/)" repo_rx <- "(?[^/@#]+)" subdir_rx <- "(?:/(?[^@#]*[^@#/])/?)?" ref_rx <- "(?:@(?[^*].*))" pull_rx <- "(?:#(?[0-9]+))" release_rx <- "(?:@(?[*]release))" ref_or_pull_or_release_rx <- sprintf( "(?:%s|%s|%s)?", ref_rx, pull_rx, release_rx ) spec_rx <- sprintf( "^%s%s%s%s%s$", package_name_rx, username_rx, repo_rx, subdir_rx, ref_or_pull_or_release_rx ) params <- as.list(re_match(text = repo, pattern = spec_rx)) if (is.na(params$.match)) { stop(sprintf("Invalid git repo specification: '%s'", repo)) } params[grepl("^[^\\.]", names(params))] } #' @export #' @rdname parse-git-repo parse_github_repo_spec <- parse_repo_spec #' @export #' @rdname parse-git-repo parse_github_url <- function(repo) { prefix_rx <- "(?:github[^/:]+[/:])" username_rx <- "(?:(?[^/]+)/)" repo_rx <- "(?[^/@#]+)" ref_rx <- "(?:(?:tree|commit|releases/tag)/(?.+$))" pull_rx <- "(?:pull/(?.+$))" release_rx <- "(?:releases/)(?.+$)" ref_or_pull_or_release_rx <- sprintf( "(?:/(%s|%s|%s))?", ref_rx, pull_rx, release_rx ) url_rx <- sprintf( "%s%s%s%s", prefix_rx, username_rx, repo_rx, ref_or_pull_or_release_rx ) params <- as.list(re_match(text = repo, pattern = url_rx)) if (is.na(params$.match)) { stop(sprintf("Invalid GitHub URL: '%s'", repo)) } if (params$ref == "" && params$pull == "" && params$release == "") { params$repo <- gsub("\\.git$", "", params$repo) } if (params$release == "latest") { params$release <- "*release" } params[grepl("^[^\\.]", names(params))] } parse_git_repo <- function(repo) { if (grepl("^https://github|^git@github", repo)) { params <- parse_github_url(repo) } else { params <- parse_repo_spec(repo) } params <- params[viapply(params, nchar) > 0] if (!is.null(params$pull)) { params$ref <- github_pull(params$pull) params$pull <- NULL } if (!is.null(params$release)) { params$ref <- github_release() params$release <- NULL } params } # Contents of R/remotes-package.R #' @keywords internal "_PACKAGE" ## usethis namespace: start ## usethis namespace: end NULL # Contents of R/submodule.R parse_submodules <- function(file) { if (grepl("\n", file)) { x <- strsplit(file, "\n")[[1]] } else { x <- readLines(file) } # https://git-scm.com/docs/git-config#_syntax # Subsection names are case sensitive and can contain any characters except # newline and the null byte. Doublequote " and backslash can be included by # escaping them as \" and \\ double_quoted_string_with_escapes <- '(?:\\\\.|[^"])*' # Otherwise extract section names section_names <- re_match( x, sprintf('^[[:space:]]*\\[submodule "(?%s)"\\][[:space:]]*$', double_quoted_string_with_escapes) )$submodule # If no sections found return the empty list if (all(is.na(section_names))) { return(list()) } # Extract name = value # The variable names are case-insensitive, allow only alphanumeric characters # and -, and must start with an alphabetic character. variable_name <- "[[:alpha:]][[:alnum:]\\-]*" mapping_values <- re_match( x, sprintf('^[[:space:]]*(?%s)[[:space:]]*=[[:space:]]*(?.*)[[:space:]]*$', variable_name), ) values <- cbind(submodule = fill(section_names), mapping_values[c("name", "value")], stringsAsFactors = FALSE) values <- values[!is.na(mapping_values$.match), ] # path and valid url are required if (!all(c("path", "url") %in% values$name)) { warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE) return(list()) } # Roughly equivalent to tidyr::spread(values, name, value) res <- stats::reshape(values, idvar = "submodule", timevar = "name", v.name = "value", direction = "wide") # Set the column names, reshape prepends `value.` to path, url and branch colnames(res) <- gsub("value[.]", "", colnames(res)) # path and valid url are required if (any(is.na(res$url), is.na(res$path))) { warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE) return(list()) } # branch is optional if (!exists("branch", res)) { res$branch <- NA_character_ } # Remove unneeded attribute attr(res, "reshapeWide") <- NULL # Remove rownames rownames(res) <- NULL res } # Adapted from https://stackoverflow.com/a/9517731/2055486 fill <- function(x) { not_missing <- !is.na(x) res <- x[not_missing] res[cumsum(not_missing)] } update_submodule <- function(url, path, branch, quiet) { args <- c('clone', '--depth', '1', '--no-hardlinks --recurse-submodules') if (length(branch) > 0 && !is.na(branch) && branch != 'HEAD') { args <- c(args, "--branch", branch) } args <- c(args, url, path) git(paste0(args, collapse = " "), quiet = quiet) } update_submodules <- function(source, subdir, quiet) { file <- file.path(source, ".gitmodules") if (!file.exists(file)) { if (!is.null(subdir)) { nb_sub_folders <- lengths(strsplit(subdir, "/")) source <- do.call(file.path, as.list(c(source, rep("..", nb_sub_folders)))) } file <- file.path(source, ".gitmodules") if (!file.exists(file)) { return() } } info <- parse_submodules(file) # Fixes #234 if (length(info) == 0) { return() } to_ignore <- in_r_build_ignore(info$path, file.path(source, ".Rbuildignore")) if (!(length(info) > 0)) { return() } info <- info[!to_ignore, ] for (i in seq_len(NROW(info))) { update_submodule(info$url[[i]], file.path(source, info$path[[i]]), info$branch[[i]], quiet) } } # Contents of R/system.R system_check <- function(command, args = character(), quiet = TRUE, error = TRUE, path = ".") { out <- tempfile() err <- tempfile() on.exit(unlink(out), add = TRUE) on.exit(unlink(err), add = TRUE) ## We suppress warnings, they are given if the command ## exits with a non-zero status res <- in_dir( path, suppressWarnings( system2(command, args = args, stdout = out, stderr = err) ) ) res <- list( stdout = tryCatch( suppressWarnings(win2unix(read_char(out))), error = function(e) "" ), stderr = tryCatch( suppressWarnings(win2unix(read_char(err))), error = function(e) "" ), status = res ) if (error && res$status != 0) { stop("Command ", command, " failed ", res$stderr) } if (! quiet) { if (! identical(res$stdout, NA_character_)) cat(res$stdout) if (! identical(res$stderr, NA_character_)) cat(res$stderr) } res } win2unix <- function(str) { gsub("\r\n", "\n", str, fixed = TRUE) } read_char <- function(path, ...) { readChar(path, nchars = file.info(path)$size, ...) } # Contents of R/system_requirements.R DEFAULT_RSPM_REPO_ID <- "1" # cran DEFAULT_RSPM <- "https://packagemanager.posit.co" #' Query the system requirements for a package (and its dependencies) #' #' Returns a character vector of commands to run that will install system #' requirements for the queried operating system. #' #' @param os,os_release The operating system and operating system release version, see #' for the #' list of supported operating systems. #' #' If `os_release` is `NULL`, `os` must consist of the operating system #' and the version separated by a dash, e.g. `"ubuntu-18.04"`. #' @param path The path to the dev package's root directory. #' @param package CRAN package name(s) to lookup system requirements for. If not #' `NULL`, this is used and `path` is ignored. #' @param curl The location of the curl binary on your system. #' @return A character vector of commands needed to install the system requirements for the package. #' @export system_requirements <- function(os, os_release = NULL, path = ".", package = NULL, curl = Sys.which("curl")) { if (is.null(os_release)) { os_release <- strsplit(os, "-", fixed = TRUE)[[1]] if (length(os_release) != 2) { stop("If os_release is missing, os must consist of name and release.", call. = FALSE) } os <- os_release[[1]] os_release <- os_release[[2]] } os_versions <- supported_os_versions() os <- match.arg(os, names(os_versions)) os_release <- match.arg(os_release, os_versions[[os]]) if (!nzchar(curl)) { stop("`curl` must be on the `PATH`.", call. = FALSE) } rspm <- Sys.getenv("RSPM_ROOT", DEFAULT_RSPM) rspm_repo_id <- Sys.getenv("RSPM_REPO_ID", DEFAULT_RSPM_REPO_ID) rspm_repo_url <- sprintf("%s/__api__/repos/%s", rspm, rspm_repo_id) if (!is.null(package)) { res <- system2( curl, args = c( "--silent", "-L", shQuote(sprintf("%s/sysreqs?all=false&pkgname=%s&distribution=%s&release=%s", rspm_repo_url, paste(package, collapse = "&pkgname="), os, os_release) )), stdout = TRUE ) res <- json$parse(res) if (!is.null(res$error)) { stop(res$error) } pre_install <- unique(unlist(c(res[["pre_install"]], lapply(res[["requirements"]], `[[`, c("requirements", "pre_install"))))) install_scripts <- unique(unlist(c(res[["install_scripts"]], lapply(res[["requirements"]], `[[`, c("requirements", "install_scripts"))))) } else { desc_file <- normalizePath(file.path(path, "DESCRIPTION"), mustWork = FALSE) if (!file.exists(desc_file)) { stop("`", path, "` must contain a package.", call. = FALSE) } res <- system2( curl, args = c( "--silent", "-L", "--data-binary", shQuote(paste0("@", desc_file)), shQuote(sprintf("%s/sysreqs?distribution=%s&release=%s&suggests=true", rspm_repo_url, os, os_release) ) ), stdout = TRUE ) res <- json$parse(res) if (!is.null(res$error)) { stop(res$error) } pre_install <- unique(unlist(c(res[["pre_install"]], lapply(res[["dependencies"]], `[[`, "pre_install")))) install_scripts <- unique(unlist(c(res[["install_scripts"]], lapply(res[["dependencies"]], `[[`, "install_scripts")))) } as.character(c(pre_install, install_scripts)) } # Adapted from https://github.com/rstudio/r-system-requirements/blob/master/systems.json # OSs commented out are not currently supported by the API supported_os_versions <- function() { list( #"debian" = c("8", "9"), "ubuntu" = c("14.04", "16.04", "18.04", "20.04", "22.04"), "centos" = c("6", "7", "8"), "redhat" = c("6", "7", "8"), "opensuse" = c("42.3", "15.0"), "sle" = c("12.3", "15.0") #"windows" = c("") ) } # Contents of R/utils.R `%||%` <- function (a, b) if (!is.null(a)) a else b `%:::%` <- function (p, f) get(f, envir = asNamespace(p)) `%::%` <- function (p, f) get(f, envir = asNamespace(p)) viapply <- function(X, FUN, ..., USE.NAMES = TRUE) { vapply(X, FUN, integer(1L), ..., USE.NAMES = USE.NAMES) } vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) { vapply(X, FUN, logical(1L), ..., USE.NAMES = USE.NAMES) } rcmd <- function(cmd, args, path = R.home("bin"), quiet, fail_on_status = TRUE) { if (os_type() == "windows") { real_cmd <- file.path(path, "Rcmd.exe") args <- c(cmd, args) } else { real_cmd <- file.path(path, "R") args <- c("CMD", cmd, args) } stdoutfile <- tempfile() stderrfile <- tempfile() on.exit(unlink(c(stdoutfile, stderrfile), recursive = TRUE), add = TRUE) status <- system2(real_cmd, args, stderr = stderrfile, stdout = stdoutfile) out <- tryCatch(readLines(stdoutfile, warn = FALSE), error = function(x) "") err <- tryCatch(readLines(stderrfile, warn = FALSE), error = function(x) "") if (fail_on_status && status != 0) { cat("STDOUT:\n") cat(out, sep = "\n") cat("STDERR:\n") cat(err, sep = "\n") stop(sprintf("Error running '%s' (status '%i')", cmd, status), call. = FALSE) } if (!quiet) { cat(out, sep = "\n") } list(stdout = out, stderr = err, status = status) } is_bioconductor <- function(x) { !is.null(x$biocviews) } trim_ws <- function(x) { gsub("^[[:space:]]+|[[:space:]]+$", "", x) } set_envvar <- function(envs) { if (length(envs) == 0) return() stopifnot(is.named(envs)) old <- Sys.getenv(names(envs), names = TRUE, unset = NA) set <- !is.na(envs) both_set <- set & !is.na(old) if (any(set)) do.call("Sys.setenv", as.list(envs[set])) if (any(!set)) Sys.unsetenv(names(envs)[!set]) invisible(old) } with_envvar <- function(new, code) { old <- set_envvar(new) on.exit(set_envvar(old)) force(code) } is.named <- function(x) { !is.null(names(x)) && all(names(x) != "") } pkg_installed <- function(pkg) { if (pkg %in% loadedNamespaces()) { TRUE } else if (requireNamespace(pkg, quietly = TRUE)) { try(unloadNamespace(pkg)) TRUE } else { FALSE } } has_package <- function(pkg) { if (pkg %in% loadedNamespaces()) { TRUE } else { requireNamespace(pkg, quietly = TRUE) } } with_something <- function(set, reset = set) { function(new, code) { old <- set(new) on.exit(reset(old)) force(code) } } in_dir <- with_something(setwd) get_r_version <- function() { paste(R.version$major, sep = ".", R.version$minor) } set_options <- function(x) { do.call(options, as.list(x)) } with_options <- with_something(set_options) # Read the current user .Rprofile. Here is the order it is searched, from # ?Startup # # 'R_PROFILE_USER’ environment variable (and tilde expansion # will be performed). If this is unset, a file called ‘.Rprofile’ # is searched for in the current directory or in the user's home # directory (in that order). The user profile file is sourced into # the workspace. read_rprofile_user <- function() { f <- normalizePath(Sys.getenv("R_PROFILE_USER", ""), mustWork = FALSE) if (file.exists(f)) { return(readLines(f)) } f <- normalizePath("~/.Rprofile", mustWork = FALSE) if (file.exists(f)) { return(readLines(f)) } character() } with_rprofile_user <- function(new, code) { temp_rprofile <- tempfile() on.exit(unlink(temp_rprofile), add = TRUE) writeLines(c(read_rprofile_user(), new), temp_rprofile) with_envvar(c("R_PROFILE_USER" = temp_rprofile), { force(code) }) } ## There are two kinds of tar on windows, one needs --force-local ## not to interpret : characters, the other does not. We try both ways. untar <- function(tarfile, ...) { if (os_type() == "windows") { tarhelp <- tryCatch( system2("tar", "--help", stdout = TRUE, stderr = TRUE), error = function(x) "") if (any(grepl("--force-local", tarhelp))) { status <- try( suppressWarnings(utils::untar(tarfile, extras = "--force-local", ...)), silent = TRUE) if (! is_tar_error(status)) { return(status) } else { message("External tar failed with `--force-local`, trying without") } } } utils::untar(tarfile, ...) } is_tar_error <- function(status) { inherits(status, "try-error") || is_error_status(status) || is_error_status(attr(status, "status")) } is_error_status <- function(x) { is.numeric(x) && length(x) > 0 && !is.na(x) && x != 0 } os_type <- function() { .Platform$OS.type } sys_type <- function() { if (.Platform$OS.type == "windows") { "windows" } else if (Sys.info()["sysname"] == "Darwin") { "macos" } else if (Sys.info()["sysname"] == "Linux") { "linux" } else if (.Platform$OS.type == "unix") { "unix" } else { stop("Unknown OS") } } is_dir <- function(path) { file.info(path)$isdir } untar_description <- function(tarball, dir = tempfile()) { files <- untar(tarball, list = TRUE) desc <- grep("^[^/]+/DESCRIPTION$", files, value = TRUE) if (length(desc) < 1) stop("No 'DESCRIPTION' file in package") untar(tarball, desc, exdir = dir) file.path(dir, desc) } ## copied from rematch2@180fb61 re_match <- function(text, pattern, perl = TRUE, ...) { stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern)) text <- as.character(text) match <- regexpr(pattern, text, perl = perl, ...) start <- as.vector(match) length <- attr(match, "match.length") end <- start + length - 1L matchstr <- substring(text, start, end) matchstr[ start == -1 ] <- NA_character_ res <- data.frame( stringsAsFactors = FALSE, .text = text, .match = matchstr ) if (!is.null(attr(match, "capture.start"))) { gstart <- attr(match, "capture.start") glength <- attr(match, "capture.length") gend <- gstart + glength - 1L groupstr <- substring(text, gstart, gend) groupstr[ gstart == -1 ] <- NA_character_ dim(groupstr) <- dim(gstart) res <- cbind(groupstr, res, stringsAsFactors = FALSE) } names(res) <- c(attr(match, "capture.names"), ".text", ".match") class(res) <- c("tbl_df", "tbl", class(res)) res } is_standalone <- function() { isTRUE(config_val_to_logical(Sys.getenv("R_REMOTES_STANDALONE", "false"))) } # This code is adapted from the perl MIME::Base64 module https://perldoc.perl.org/MIME/Base64.html # https://github.com/gisle/mime-base64/blob/cf23d49e517c6ed8f4b24295f63721e8c9935010/Base64.xs#L197 XX <- 255L EQ <- 254L INVALID <- XX index_64 <- as.integer(c( XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,62, XX,XX,XX,63, 52,53,54,55, 56,57,58,59, 60,61,XX,XX, XX,EQ,XX,XX, XX, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 11,12,13,14, 15,16,17,18, 19,20,21,22, 23,24,25,XX, XX,XX,XX,XX, XX,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40, 41,42,43,44, 45,46,47,48, 49,50,51,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX )) base64_decode <- function(x) { if (is.character(x)) { x <- charToRaw(x) } len <- length(x) idx <- 1 c <- integer(4) out <- raw() while(idx <= len) { i <- 1 while(i <= 4) { uc <- index_64[[as.integer(x[[idx]]) + 1L]] idx <- idx + 1 if (uc != INVALID) { c[[i]] <- uc i <- i + 1 } if (idx > len) { if (i <= 4) { if (i <= 2) return(rawToChar(out)) if (i == 3) { c[[3]] <- EQ c[[4]] <- EQ } break } } } if (c[[1]] == EQ || c[[2]] == EQ) { break } #print(sprintf("c1=%d,c2=%d,c3=%d,c4=%d\n", c[1],c[2],c[3],c[4])) out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(c[[1]], 2L), bitwShiftR(bitwAnd(c[[2]], 0x30), 4L))) if (c[[3]] == EQ) { break } out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[2]], 0x0F), 4L), bitwShiftR(bitwAnd(c[[3]], 0x3C), 2L))) if (c[[4]] == EQ) { break } out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[3]], 0x03), 6L), c[[4]])) } rawToChar(out) } basis64 <- charToRaw(paste(c(LETTERS, letters, 0:9, "+", "/"), collapse = "")) base64_encode <- function(x) { if (is.character(x)) { x <- charToRaw(x) } len <- length(x) rlen <- floor((len + 2L) / 3L) * 4L out <- raw(rlen) ip <- op <- 1L c <- integer(4) while (len > 0L) { c[[1]] <- as.integer(x[[ip]]) ip <- ip + 1L if (len > 1L) { c[[2]] <- as.integer(x[ip]) ip <- ip + 1L } else { c[[2]] <- 0L } out[op] <- basis64[1 + bitwShiftR(c[[1]], 2L)] op <- op + 1L out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[1]], 3L), 4L), bitwShiftR(bitwAnd(c[[2]], 240L), 4L))] op <- op + 1L if (len > 2) { c[[3]] <- as.integer(x[ip]) ip <- ip + 1L out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[2]], 15L), 2L), bitwShiftR(bitwAnd(c[[3]], 192L), 6L))] op <- op + 1L out[op] <- basis64[1 + bitwAnd(c[[3]], 63)] op <- op + 1L } else if (len == 2) { out[op] <- basis64[1 + bitwShiftL(bitwAnd(c[[2]], 15L), 2L)] op <- op + 1L out[op] <- charToRaw("=") op <- op + 1L } else { ## len == 1 out[op] <- charToRaw("=") op <- op + 1L out[op] <- charToRaw("=") op <- op + 1L } len <- len - 3L } rawToChar(out) } build_url <- function(host, ...) { download_url(do.call(file.path, as.list(c(host, ...)))) } download_url <- function(url) { if (!grepl("^[[:alpha:]]+://", url)) { scheme <- if (download_method_secure()) "https://" else "http://" return(paste0(scheme, url)) } url } is_na <- function(x) { length(x) == 1 && is.na(x) } dir.exists <- function(paths) { if (getRversion() < "3.2") { x <- base::file.info(paths)$isdir !is.na(x) & x } else { ("base" %::% "dir.exists")(paths) } } is_binary_pkg <- function(x) { file_ext(x) %in% c("tgz", "zip") } format_str <- function(x, width = Inf, trim = TRUE, justify = "none", ...) { x <- format(x, trim = trim, justify = justify, ...) if (width < Inf) { x_width <- nchar(x, "width") too_wide <- x_width > width if (any(too_wide)) { x[too_wide] <- paste0(substr(x[too_wide], 1, width - 3), "...") } } x } warn_for_potential_errors <- function() { if (sys_type() == "windows" && grepl(" ", R.home()) && getRversion() <= "3.4.2") { warning(immediate. = TRUE, "\n!!! Installation will probably fail!\n", "This version of R has trouble with building and installing packages if\n", "the R HOME directory (currently '", R.home(), "')\n", "has space characters. Possible workarounds include:\n", "- installing R to the C: drive,\n", "- installing it into a path without a space, or\n", "- creating a drive letter for R HOME via the `subst` windows command, and\n", " starting R from the new drive.\n", "See also https://github.com/r-lib/remotes/issues/98\n") } } # Return all directories in the input paths directories <- function(paths) { dirs <- unique(dirname(paths)) out <- dirs[dirs != "."] while(length(dirs) > 0 && any(dirs != ".")) { out <- unique(c(out, dirs[dirs != "."])) dirs <- unique(dirname(dirs)) } sort(out) } in_r_build_ignore <- function(paths, ignore_file) { ignore <- ("tools" %:::% "get_exclude_patterns")() if (file.exists(ignore_file)) { ignore <- c(ignore, readLines(ignore_file, warn = FALSE)) } matches_ignores <- function(x) { any(vlapply(ignore, grepl, x, perl = TRUE, ignore.case = TRUE)) } # We need to search for the paths as well as directories in the path, so # `^foo$` matches `foo/bar` should_ignore <- function(path) { any(vlapply(c(path, directories(path)), matches_ignores)) } vlapply(paths, should_ignore) } dev_split_ref <- function(x) { re_match(x, "^(?[^@#]+)(?[@#].*)?$") } get_json_sha <- function(text) { m <- regexpr(paste0('"sha"\\s*:\\s*"(\\w+)"'), text, perl = TRUE) if (all(m == -1)) { return(json$parse(text)$sha %||% NA_character_) } start <- attr(m, "capture.start") end <- start + attr(m, "capture.length") - 1L substring(text, start, end) } # from tools:::config_val_to_logical config_val_to_logical <- function (val) { v <- tolower(val) if (v %in% c("1", "yes", "true")) TRUE else if (v %in% c("0", "no", "false")) FALSE else { NA } } raw_to_char_utf8 <- function(x) { res <- rawToChar(x) Encoding(res) <- "UTF-8" res } ## Standalone mode, make sure that we restore the env var on exit old <- Sys.getenv("R_REMOTES_STANDALONE", NA_character_) Sys.setenv("R_REMOTES_STANDALONE" = "true") if (is.na(old)) { on.exit(Sys.unsetenv("R_REMOTES_STANDALONE"), add = TRUE) } else { on.exit(Sys.setenv("R_REMOTES_STANDALONE" = old), add = TRUE) } install_github(...) } )("xiaowangCN/GeneDMRs")