1#' Install a remote package. 2#' 3#' This: 4#' \enumerate{ 5#' \item downloads source bundle 6#' \item decompresses & checks that it's a package 7#' \item adds metadata to DESCRIPTION 8#' \item calls install 9#' } 10#' 11#' It uses the additional S3 generic functions to work. Writing methods for 12#' these functions would allow 3rd party packages to define custom remotes. 13#' @inheritParams install_github 14#' @keywords internal 15#' @export 16install_remote <- function(remote, 17 dependencies, 18 upgrade, 19 force, 20 quiet, 21 build, 22 build_opts, 23 build_manual, 24 build_vignettes, 25 repos, 26 type, 27 ...) { 28 29 stopifnot(is.remote(remote)) 30 31 package_name <- remote_package_name(remote) 32 local_sha <- local_sha(package_name) 33 remote_sha <- remote_sha(remote, local_sha) 34 35 if (!isTRUE(force) && 36 !different_sha(remote_sha = remote_sha, local_sha = local_sha)) { 37 38 if (!quiet) { 39 message( 40 "Skipping install of '", package_name, "' from a ", sub("_remote", "", class(remote)[1L]), " remote,", 41 " the SHA1 (", substr(remote_sha, 1L, 8L), ") has not changed since last install.\n", 42 " Use `force = TRUE` to force installation") 43 } 44 return(invisible(package_name)) 45 } 46 47 if (inherits(remote, "cran_remote")) { 48 install_packages( 49 package_name, repos = remote$repos, type = remote$pkg_type, 50 dependencies = dependencies, 51 quiet = quiet, 52 ...) 53 return(invisible(package_name)) 54 } 55 56 res <- try(bundle <- remote_download(remote, quiet = quiet), silent = quiet) 57 if (inherits(res, "try-error")) { 58 return(NA_character_) 59 } 60 61 on.exit(unlink(bundle), add = TRUE) 62 63 source <- source_pkg(bundle, subdir = remote$subdir) 64 on.exit(unlink(source, recursive = TRUE), add = TRUE) 65 66 update_submodules(source, remote$subdir, quiet) 67 68 add_metadata(source, remote_metadata(remote, bundle, source, remote_sha)) 69 70 # Because we've modified DESCRIPTION, its original MD5 value is wrong 71 clear_description_md5(source) 72 73 install(source, 74 dependencies = dependencies, 75 upgrade = upgrade, 76 force = force, 77 quiet = quiet, 78 build = build, 79 build_opts = build_opts, 80 build_manual = build_manual, 81 build_vignettes = build_vignettes, 82 repos = repos, 83 type = type, 84 ...) 85} 86 87install_remotes <- function(remotes, ...) { 88 res <- character(length(remotes)) 89 for (i in seq_along(remotes)) { 90 tryCatch( 91 res[[i]] <- install_remote(remotes[[i]], ...), 92 error = function(e) { 93 stop(remote_install_error(remotes[[i]], e)) 94 }) 95 } 96 invisible(res) 97} 98 99remote_install_error <- function(remote, error) { 100 msg <- sprintf( 101 "Failed to install '%s' from %s:\n %s", remote_name_or_unknown(remote), format(remote), conditionMessage(error) 102 ) 103 104 structure(list(message = msg, call = NULL, error = error, remote = remote), class = c("install_error", "error", "condition")) 105} 106 107remote_name_or_unknown <- function(remote) { 108 res <- tryCatch( 109 res <- remote_package_name(remote), 110 error = function(e) NA_character_) 111 112 if (is.na(res)) { 113 return("unknown package") 114 } 115 116 res 117} 118 119#' @rdname install_remote 120#' @export 121#' @keywords internal 122add_metadata <- function(pkg_path, meta) { 123 124 # During installation, the DESCRIPTION file is read and an package.rds file 125 # created with most of the information from the DESCRIPTION file. Functions 126 # that read package metadata may use either the DESCRIPTION file or the 127 # package.rds file, therefore we attempt to modify both of them 128 source_desc <- file.path(pkg_path, "DESCRIPTION") 129 binary_desc <- file.path(pkg_path, "Meta", "package.rds") 130 if (file.exists(source_desc)) { 131 desc <- read_dcf(source_desc) 132 133 desc <- utils::modifyList(desc, meta) 134 135 write_dcf(source_desc, desc) 136 } 137 138 if (file.exists(binary_desc)) { 139 pkg_desc <- base::readRDS(binary_desc) 140 desc <- as.list(pkg_desc$DESCRIPTION) 141 desc <- utils::modifyList(desc, meta) 142 pkg_desc$DESCRIPTION <- stats::setNames(as.character(desc), names(desc)) 143 base::saveRDS(pkg_desc, binary_desc) 144 } 145} 146 147# Modify the MD5 file - remove the line for DESCRIPTION 148clear_description_md5 <- function(pkg_path) { 149 path <- file.path(pkg_path, "MD5") 150 151 if (file.exists(path)) { 152 text <- readLines(path) 153 text <- text[!grepl(".*\\*DESCRIPTION$", text)] 154 155 writeLines(text, path) 156 } 157} 158 159remote <- function(type, ...) { 160 structure(list(...), class = c(paste0(type, "_remote"), "remote")) 161} 162 163is.remote <- function(x) inherits(x, "remote") 164 165#' @rdname install_remote 166#' @keywords internal 167#' @export 168remote_download <- function(x, quiet = FALSE) UseMethod("remote_download") 169 170#' @rdname install_remote 171#' @keywords internal 172#' @export 173remote_metadata <- function(x, bundle = NULL, source = NULL, sha = NULL) UseMethod("remote_metadata") 174 175#' @rdname install_remote 176#' @keywords internal 177#' @export 178remote_package_name <- function(remote, ...) UseMethod("remote_package_name") 179 180#' @rdname install_remote 181#' @keywords internal 182#' @export 183remote_sha <- function(remote, ...) UseMethod("remote_sha") 184 185remote_package_name.default <- function(remote, ...) remote$repo 186remote_sha.default <- function(remote, ...) NA_character_ 187 188different_sha <- function(remote_sha, local_sha) { 189 190 same <- remote_sha == local_sha 191 same <- isTRUE(same) && !is.na(same) 192 !same 193} 194 195local_sha <- function(name) { 196 package2remote(name)$sha %||% NA_character_ 197} 198 199# Convert an installed package to its equivalent remote. This constructs the 200# remote from metadata stored in the package's DESCRIPTION file; the metadata 201# is added to the package when it is installed by remotes. If the package is 202# installed some other way, such as by `install.packages()` there will be no 203# meta-data, so there we construct a generic CRAN remote. 204package2remote <- function(name, lib = .libPaths(), repos = getOption("repos"), type = getOption("pkgType")) { 205 206 x <- tryCatch(utils::packageDescription(name, lib.loc = lib), error = function(e) NA, warning = function(e) NA) 207 208 # will be NA if not installed 209 if (identical(x, NA)) { 210 return(remote("cran", 211 name = name, 212 repos = repos, 213 pkg_type = type, 214 sha = NA_character_)) 215 } 216 217 if (is.null(x$RemoteType) || x$RemoteType == "cran") { 218 219 # Packages installed with install.packages() or locally without remotes 220 return(remote("cran", 221 name = x$Package, 222 repos = repos, 223 pkg_type = type, 224 sha = x$Version)) 225 } 226 227 switch(x$RemoteType, 228 standard = remote("cran", 229 name = x$Package, 230 repos = x$RemoteRepos %||% repos, 231 pkg_type = x$RemotePkgType %||% type, 232 sha = x$RemoteSha), 233 github = remote("github", 234 host = x$RemoteHost, 235 package = x$RemotePackage, 236 repo = x$RemoteRepo, 237 subdir = x$RemoteSubdir, 238 username = x$RemoteUsername, 239 ref = x$RemoteRef, 240 sha = x$RemoteSha, 241 auth_token = github_pat()), 242 gitlab = remote("gitlab", 243 host = x$RemoteHost, 244 repo = x$RemoteRepo, 245 subdir = x$RemoteSubdir, 246 username = x$RemoteUsername, 247 ref = x$RemoteRef, 248 sha = x$RemoteSha, 249 auth_token = gitlab_pat()), 250 xgit = remote("xgit", 251 url = trim_ws(x$RemoteUrl), 252 ref = x$RemoteRef %||% x$RemoteBranch, 253 sha = x$RemoteSha, 254 subdir = x$RemoteSubdir, 255 args = x$RemoteArgs), 256 git2r = remote("git2r", 257 url = trim_ws(x$RemoteUrl), 258 ref = x$RemoteRef %||% x$RemoteBranch, 259 sha = x$RemoteSha, 260 subdir = x$RemoteSubdir, 261 credentials = git_credentials()), 262 bitbucket = remote("bitbucket", 263 host = x$RemoteHost, 264 repo = x$RemoteRepo, 265 username = x$RemoteUsername, 266 ref = x$RemoteRef, 267 sha = x$RemoteSha, 268 subdir = x$RemoteSubdir, 269 auth_user = bitbucket_user(), 270 password = bitbucket_password()), 271 svn = remote("svn", 272 url = trim_ws(x$RemoteUrl), 273 svn_subdir = x$RemoteSubdir, 274 revision = x$RemoteSha, 275 args = x$RemoteArgs), 276 local = remote("local", 277 path = { 278 path <- trim_ws(x$RemoteUrl) 279 if (length(path) == 0) { 280 path <- parse_pkg_ref(x$RemotePkgRef)$ref 281 } 282 path 283 }, 284 subdir = x$RemoteSubdir, 285 sha = { 286 # Packages installed locally might have RemoteSha == NA_character_ 287 x$RemoteSha %||% x$Version 288 }), 289 url = remote("url", 290 url = trim_ws(x$RemoteUrl), 291 subdir = x$RemoteSubdir, 292 config = x$RemoteConfig, 293 pkg_type = x$RemotePkgType %||% type), 294 bioc_git2r = remote("bioc_git2r", 295 mirror = x$RemoteMirror, 296 repo = x$RemoteRepo, 297 release = x$RemoteRelease, 298 sha = x$RemoteSha, 299 branch = x$RemoteBranch), 300 bioc_xgit = remote("bioc_xgit", 301 mirror = x$RemoteMirror, 302 repo = x$RemoteRepo, 303 release = x$RemoteRelease, 304 sha = x$RemoteSha, 305 branch = x$RemoteBranch), 306 stop(sprintf("can't convert package %s with RemoteType '%s' to remote", name, x$RemoteType)) 307 ) 308} 309 310parse_pkg_ref <- function(x) { 311 res <- re_match(x, "(?<type>[^:]+)::(?<ref>.*)") 312 if (is.na(res$ref)) { 313 stop("Invalid package reference:\n ", x, call. = FALSE) 314 } 315 res 316} 317 318#' @export 319format.remotes <- function(x, ...) { 320 vapply(x, format, character(1)) 321} 322