1# Autogenerated from contents in the package's R directory, do not edit! 2# Run make to update. 3 4function(...) { 5 6 ## This is the code of the package, put in here by brew 7 8 # Contents of R/bioc-standalone.R 9 #' Tools for Bioconductor versions and repositories 10 #' 11 #' \section{API:} 12 #' 13 #' ``` 14 #' get_yaml_config(forget = FALSE) 15 #' set_yaml_config(text) 16 #' 17 #' get_release_version(forget = FALSE) 18 #' get_devel_version(forget = FALSE) 19 #' 20 #' get_version_map(forget = FALSE) 21 #' get_matching_bioc_version(r_version = getRversion(), forget = FALSE) 22 #' get_bioc_version(r_version = getRversion(), forget = FALSE) 23 #' 24 #' get_repos(bioc_version = "auto", forget = FALSE) 25 #' ``` 26 #' 27 #' * `forget`: Whether to forget the cached version of the Bioconductor 28 #' config YAML file and download it again. 29 #' * `text`: character vector (linewise) or scalar, the contents of the 30 #' `config.yaml` file, if obtained externally, to be used as a cached 31 #' version in the future. 32 #' * `r_version`: R version string, or `package_version` object. 33 #' * `bioc_version`: Bioc version string or `package_version` object, 34 #' or the string `"auto"` to use the one matching the current R version. 35 #' 36 #' `get_yaml_config()` returns the raw contents of the `config.yaml` file, 37 #' linewise. It is typically not needed, except if one needs information 38 #' that cannot be surfaces via the other API functions. 39 #' 40 #' `set_yaml_config()` can be used to _set_ the contents of the 41 #' `config.yaml` file. This is useful, if one has already obtained it 42 #' externally, but wants to use the obtained file with the rest of the 43 #' bioc standalone code. 44 #' 45 #' `get_release_version()` returns the version of the current Bioconductor 46 #' release. 47 #' 48 #' `get_devel_version()` returns the version of the current development 49 #' version of Bioconductor. 50 #' 51 #' `get_version_map()` return the mapping between R versions and 52 #' Bioconductor versions. Note that this is not a one to one mapping. 53 #' E.g. currently R `3.6.x` maps to both Bioc `3.9` (Bioc release) and 54 #' `3.10` (Bioc devel); and also Bioc `3.10` maps to both R `3.6.x` and 55 #' R `3.7.x` (current R-devel). It returns a data frame with three columns: 56 #' `bioc_version`, `r_version` and `bioc_status`. The first two columns 57 #' contain `package_vesion` objects, the third is a factor with levels: 58 #' `out-of-date`, `release`, `devel`, `future`. 59 #' 60 #' `get_matching_bioc_version()` returns the matching Bioc version for an 61 #' R version. If the R version matches to both a released and a devel 62 #' version, then the released version is chosen. 63 #' 64 #' `get_bioc_version()` returns the matching Bioc version for the 65 #' specified R version. It does observe the `R_BIOC_VERSION` environment 66 #' variable, which can be used to force a Bioconductor version. If this is 67 #' not set, it just calls `get_matching_bioc_version()`. 68 #' 69 #' `get_repos()` returns the Bioc repositories of the specified Bioc 70 #' version. It defaults to the Bioc version that matches the calling R 71 #' version. It returns a named character vector. 72 #' 73 #' \section{NEWS:} 74 #' * 2019-05-30 First version in remotes. 75 #' * 2020-03-22 get_matching_bioc_version() is now correct if the current 76 #' R version is not in the builtin mapping. 77 #' * 2020-11-21 Update internal map for 3.12. 78 #' 79 #' @name bioconductor 80 #' @keywords internal 81 #' @noRd 82 NULL 83 84 85 bioconductor <- local({ 86 87 # ------------------------------------------------------------------- 88 # Configuration that does not change often 89 90 config_url <- "https://bioconductor.org/config.yaml" 91 92 builtin_map <- list( 93 "2.1" = package_version("1.6"), 94 "2.2" = package_version("1.7"), 95 "2.3" = package_version("1.8"), 96 "2.4" = package_version("1.9"), 97 "2.5" = package_version("2.0"), 98 "2.6" = package_version("2.1"), 99 "2.7" = package_version("2.2"), 100 "2.8" = package_version("2.3"), 101 "2.9" = package_version("2.4"), 102 "2.10" = package_version("2.5"), 103 "2.11" = package_version("2.6"), 104 "2.12" = package_version("2.7"), 105 "2.13" = package_version("2.8"), 106 "2.14" = package_version("2.9"), 107 "2.15" = package_version("2.11"), 108 "3.0" = package_version("2.13"), 109 "3.1" = package_version("3.0"), 110 "3.2" = package_version("3.2"), 111 "3.3" = package_version("3.4"), 112 "3.4" = package_version("3.6"), 113 "3.5" = package_version("3.8"), 114 "3.6" = package_version("3.10"), 115 "4.0" = package_version("3.12"), 116 "4.1" = package_version("3.14") 117 ) 118 119 # ------------------------------------------------------------------- 120 # Cache 121 122 devel_version <- NULL 123 release_version <- NULL 124 version_map <- NULL 125 yaml_config <- NULL 126 127 # ------------------------------------------------------------------- 128 # API 129 130 get_yaml_config <- function(forget = FALSE) { 131 if (forget || is.null(yaml_config)) { 132 new <- tryCatch(read_url(config_url), error = function(x) x) 133 if (inherits(new, "error")) { 134 http_url <- sub("^https", "http", config_url) 135 new <- tryCatch(read_url(http_url), error = function(x) x) 136 } 137 if (inherits(new, "error")) stop(new) 138 yaml_config <<- new 139 } 140 141 yaml_config 142 } 143 144 set_yaml_config <- function(text) { 145 if (length(text) == 1) text <- strsplit(text, "\n", fixed = TRUE)[[1]] 146 yaml_config <<- text 147 } 148 149 get_release_version <- function(forget = FALSE) { 150 if (forget || is.null(release_version)) { 151 yaml <- get_yaml_config(forget) 152 pattern <- "^release_version: \"(.*)\"" 153 release_version <<- package_version( 154 sub(pattern, "\\1", grep(pattern, yaml, value=TRUE)) 155 ) 156 } 157 release_version 158 } 159 160 get_devel_version <- function(forget = FALSE) { 161 if (forget || is.null(devel_version)) { 162 yaml <- get_yaml_config(forget) 163 pattern <- "^devel_version: \"(.*)\"" 164 devel_version <<- package_version( 165 sub(pattern, "\\1", grep(pattern, yaml, value=TRUE)) 166 ) 167 } 168 devel_version 169 } 170 171 get_version_map <- function(forget = FALSE) { 172 if (forget || is.null(version_map)) { 173 txt <- get_yaml_config(forget) 174 grps <- grep("^[^[:blank:]]", txt) 175 start <- match(grep("r_ver_for_bioc_ver", txt), grps) 176 map <- txt[seq(grps[start] + 1, grps[start + 1] - 1)] 177 map <- trimws(gsub("\"", "", sub(" #.*", "", map))) 178 pattern <- "(.*): (.*)" 179 bioc <- package_version(sub(pattern, "\\1", map)) 180 r <- package_version(sub(pattern, "\\2", map)) 181 status <- rep("out-of-date", length(bioc)) 182 release <- get_release_version() 183 devel <- get_devel_version() 184 status[bioc == release] <- "release" 185 status[bioc == devel] <- "devel" 186 187 # append final version for 'devel' R 188 bioc <- c( 189 bioc, max(bioc) 190 ) 191 r <- c(r, package_version(paste(unlist(max(r)) + 0:1, collapse = "."))) 192 status <- c(status, "future") 193 194 version_map <<- rbind( 195 .VERSION_MAP_SENTINEL, 196 data.frame( 197 bioc_version = bioc, r_version = r, 198 bioc_status = factor( 199 status, 200 levels = c("out-of-date", "release", "devel", "future") 201 ) 202 ) 203 ) 204 } 205 version_map 206 } 207 208 get_matching_bioc_version <- function(r_version = getRversion(), 209 forget = FALSE) { 210 211 minor <- as.character(get_minor_r_version(r_version)) 212 if (minor %in% names(builtin_map)) return(builtin_map[[minor]]) 213 214 # If we are not in the map, then we need to look this up in 215 # YAML data. It is possible that the current R version matches multiple 216 # Bioc versions. Then we choose the latest released version. If none 217 # of them were released (e.g. they are 'devel' and 'future'), then 218 # we'll use the 'devel' version. 219 220 map <- get_version_map(forget = forget) 221 mine <- which(package_version(minor) == map$r_version) 222 if (length(mine) == 0) { 223 mine <- NA 224 } else if (length(mine) > 1) { 225 if ("release" %in% map$bioc_status[mine]) { 226 mine <- mine["release" == map$bioc_status[mine]] 227 } else if ("devel" %in% map$bioc_status[mine]) { 228 mine <- mine["devel" == map$bioc_status[mine]] 229 } else { 230 mine <- rev(mine)[1] 231 } 232 } 233 if (!is.na(mine)) return(map$bioc_version[mine]) 234 235 # If it is not even in the YAML, then it must be some very old 236 # or very new version. If old, we fail. If new, we assume bioc-devel. 237 if (package_version(minor) < "2.1") { 238 stop("R version too old, cannot run Bioconductor") 239 } 240 241 get_devel_version() 242 } 243 244 get_bioc_version <- function(r_version = getRversion(), 245 forget = FALSE) { 246 if (nzchar(v <- Sys.getenv("R_BIOC_VERSION", ""))) { 247 return(package_version(v)) 248 } 249 get_matching_bioc_version(r_version, forget = forget) 250 } 251 252 get_repos <- function(bioc_version = "auto", forget = FALSE) { 253 if (identical(bioc_version, "auto")) { 254 bioc_version <- get_bioc_version(getRversion(), forget) 255 } else { 256 bioc_version <- package_version(bioc_version) 257 } 258 mirror <- Sys.getenv("R_BIOC_MIRROR", "https://bioconductor.org") 259 mirror <- getOption("BioC_mirror", mirror) 260 repos <- c( 261 BioCsoft = "{mirror}/packages/{bv}/bioc", 262 BioCann = "{mirror}/packages/{bv}/data/annotation", 263 BioCexp = "{mirror}/packages/{bv}/data/experiment", 264 BioCworkflows = 265 if (bioc_version >= "3.7") "{mirror}/packages/{bv}/workflows", 266 BioCextra = 267 if (bioc_version <= "3.5") "{mirror}/packages/{bv}/extra", 268 BioCbooks = 269 if (bioc_version >= "3.12") "{mirror}/packages/{bv}/books" 270 ) 271 272 ## It seems that if a repo is not available yet for bioc-devel, 273 ## they redirect to the bioc-release version, so we do not need to 274 ## parse devel_repos from the config.yaml file 275 276 sub("{mirror}", mirror, fixed = TRUE, 277 sub("{bv}", bioc_version, repos, fixed = TRUE)) 278 } 279 280 # ------------------------------------------------------------------- 281 # Internals 282 283 read_url <- function(url) { 284 tmp <- tempfile() 285 on.exit(unlink(tmp), add = TRUE) 286 suppressWarnings(download.file(url, tmp, quiet = TRUE)) 287 if (!file.exists(tmp) || file.info(tmp)$size == 0) { 288 stop("Failed to download `", url, "`") 289 } 290 readLines(tmp, warn = FALSE) 291 } 292 293 .VERSION_SENTINEL <- local({ 294 version <- package_version(list()) 295 class(version) <- c("unknown_version", class(version)) 296 version 297 }) 298 299 .VERSION_MAP_SENTINEL <- data.frame( 300 bioc_version = .VERSION_SENTINEL, 301 r_version = .VERSION_SENTINEL, 302 bioc_status = factor( 303 factor(), 304 levels = c("out-of-date", "release", "devel", "future") 305 ) 306 ) 307 308 get_minor_r_version <- function (x) { 309 package_version(x)[,1:2] 310 } 311 312 # ------------------------------------------------------------------- 313 314 structure( 315 list( 316 .internal = environment(), 317 get_yaml_config = get_yaml_config, 318 set_yaml_config = set_yaml_config, 319 get_release_version = get_release_version, 320 get_devel_version = get_devel_version, 321 get_version_map = get_version_map, 322 get_matching_bioc_version = get_matching_bioc_version, 323 get_bioc_version = get_bioc_version, 324 get_repos = get_repos 325 ), 326 class = c("standalone_bioc", "standalone")) 327 }) 328 # Contents of R/bioc.R 329 330 331 #' @export 332 #' @rdname bioc_install_repos 333 #' @keywords internal 334 #' @examples 335 #' bioc_version() 336 #' bioc_version("3.4") 337 338 bioc_version <- function(r_ver = getRversion()) { 339 bioconductor$get_bioc_version(r_ver) 340 } 341 342 #' Tools for Bioconductor repositories 343 #' 344 #' `bioc_version()` returns the Bioconductor version for the current or the 345 #' specified R version. 346 #' 347 #' `bioc_install_repos()` deduces the URLs of the Bioconductor repositories. 348 #' 349 #' @details 350 #' Both functions observe the `R_BIOC_VERSION` environment variable, which 351 #' can be set to force a Bioconductor version. If this is set, then the 352 #' `r_ver` and `bioc_ver` arguments are ignored. 353 #' 354 #' `bioc_install_repos()` observes the `R_BIOC_MIRROR` environment variable 355 #' and also the `BioC_mirror` option, which can be set to the desired 356 #' Bioconductor mirror. The option takes precedence if both are set. Its 357 #' default value is `https://bioconductor.org`. 358 #' 359 #' @return 360 #' `bioc_version()` returns a Bioconductor version, a `package_version` 361 #' object. 362 #' 363 #' `bioc_install_repos()` returns a named character vector of the URLs of 364 #' the Bioconductor repositories, appropriate for the current or the 365 #' specified R version. 366 #' 367 #' @param r_ver R version to use. For `bioc_install_repos()` it is 368 #' ignored if `bioc_ver` is specified. 369 #' @param bioc_ver Bioconductor version to use. Defaults to the default one 370 #' corresponding to `r_ver`. 371 #' 372 #' @export 373 #' @keywords internal 374 #' @examples 375 #' bioc_install_repos() 376 377 bioc_install_repos <- function(r_ver = getRversion(), 378 bioc_ver = bioc_version(r_ver)) { 379 bioconductor$get_repos(bioc_ver) 380 } 381 # Contents of R/circular.R 382 383 ## A environment to hold which packages are being installed so packages 384 ## with circular dependencies can be skipped the second time. 385 386 installing <- new.env(parent = emptyenv()) 387 388 is_root_install <- function() is.null(installing$packages) 389 390 exit_from_root_install <- function() installing$packages <- NULL 391 392 check_for_circular_dependencies <- function(pkgdir, quiet) { 393 pkgdir <- normalizePath(pkgdir) 394 pkg <- get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package") 395 396 if (pkg %in% installing$packages) { 397 if (!quiet) message("Skipping ", pkg, ", it is already being installed") 398 TRUE 399 400 } else { 401 installing$packages <- c(installing$packages, pkg) 402 FALSE 403 } 404 } 405 # Contents of R/cran.R 406 cache <- new.env(parent = emptyenv()) 407 408 #' @rdname available_packages 409 #' @export 410 available_packages_set <- function(repos, type, db) { 411 signature <- rawToChar(serialize(list(repos, type), NULL, ascii = TRUE)) 412 if (is.null(cache[[signature]])) { 413 cache[[signature]] <- db 414 } 415 cache[[signature]] 416 } 417 418 #' @rdname available_packages 419 #' @export 420 available_packages_reset <- function() { 421 rm(list = ls(envir = cache), envir = cache) 422 } 423 424 #' Simpler available.packages 425 #' 426 #' This is mostly equivalent to [utils::available.packages()] however it also 427 #' caches the full result. Additionally the cache can be assigned explicitly with 428 #' [available_packages_set()] and reset (cleared) with [available_packages_reset()]. 429 #' 430 #' @inheritParams utils::available.packages 431 #' @keywords internal 432 #' @seealso [utils::available.packages()] for full documentation on the output format. 433 #' @export 434 available_packages <- function(repos = getOption("repos"), type = getOption("pkgType")) { 435 available_packages_set( 436 repos, type, 437 suppressWarnings(utils::available.packages(utils::contrib.url(repos, type), type = type)) 438 ) 439 } 440 # Contents of R/dcf.R 441 read_dcf <- function(path) { 442 fields <- colnames(read.dcf(path)) 443 as.list(read.dcf(path, keep.white = fields)[1, ]) 444 } 445 446 write_dcf <- function(path, desc) { 447 write.dcf( 448 rbind(unlist(desc)), 449 file = path, 450 keep.white = names(desc), 451 indent = 0 452 ) 453 } 454 455 get_desc_field <- function(path, field) { 456 dcf <- read_dcf(path) 457 dcf[[field]] 458 } 459 # Contents of R/decompress.R 460 # Decompress pkg, if needed 461 source_pkg <- function(path, subdir = NULL) { 462 if (!dir.exists(path)) { 463 bundle <- path 464 outdir <- tempfile(pattern = "remotes") 465 dir.create(outdir) 466 467 path <- decompress(path, outdir) 468 } else { 469 bundle <- NULL 470 } 471 472 pkg_path <- if (is.null(subdir)) path else file.path(path, subdir) 473 474 # Check it's an R package 475 if (!file.exists(file.path(pkg_path, "DESCRIPTION"))) { 476 stop("Does not appear to be an R package (no DESCRIPTION)", call. = FALSE) 477 } 478 479 # Check configure is executable if present 480 config_path <- file.path(pkg_path, "configure") 481 if (file.exists(config_path)) { 482 Sys.chmod(config_path, "777") 483 } 484 485 pkg_path 486 } 487 488 489 decompress <- function(src, target) { 490 stopifnot(file.exists(src)) 491 492 if (grepl("\\.zip$", src)) { 493 my_unzip(src, target) 494 outdir <- getrootdir(as.vector(utils::unzip(src, list = TRUE)$Name)) 495 } else if (grepl("\\.(tar|tar\\.gz|tar\\.bz2|tgz|tbz)$", src)) { 496 untar(src, exdir = target) 497 outdir <- getrootdir(untar(src, list = TRUE)) 498 } else { 499 ext <- gsub("^[^.]*\\.", "", src) 500 stop("Don't know how to decompress files with extension ", ext, 501 call. = FALSE) 502 } 503 504 file.path(target, outdir) 505 } 506 507 508 # Returns everything before the last slash in a filename 509 # getdir("path/to/file") returns "path/to" 510 # getdir("path/to/dir/") returns "path/to/dir" 511 getdir <- function(path) sub("/[^/]*$", "", path) 512 513 # Given a list of files, returns the root (the topmost folder) 514 # getrootdir(c("path/to/file", "path/to/other/thing")) returns "path/to" 515 # It does not check that all paths have a common prefix. It fails for 516 # empty input vector. It assumes that directories end with '/'. 517 getrootdir <- function(file_list) { 518 stopifnot(length(file_list) > 0) 519 slashes <- nchar(gsub("[^/]", "", file_list)) 520 if (min(slashes) == 0) return(".") 521 522 getdir(file_list[which.min(slashes)]) 523 } 524 525 my_unzip <- function(src, target, unzip = getOption("unzip", "internal")) { 526 if (unzip %in% c("internal", "")) { 527 return(utils::unzip(src, exdir = target)) 528 } 529 530 args <- paste( 531 "-oq", shQuote(src), 532 "-d", shQuote(target) 533 ) 534 535 system_check(unzip, args) 536 } 537 # Contents of R/deps.R 538 539 #' Find all dependencies of a CRAN or dev package. 540 #' 541 #' Find all the dependencies of a package and determine whether they are ahead 542 #' or behind CRAN. A `print()` method identifies mismatches (if any) 543 #' between local and CRAN versions of each dependent package; an 544 #' `update()` method installs outdated or missing packages from CRAN. 545 #' 546 #' @param packages A character vector of package names. 547 #' @param pkgdir Path to a package directory, or to a package tarball. 548 #' @param dependencies Which dependencies do you want to check? 549 #' Can be a character vector (selecting from "Depends", "Imports", 550 #' "LinkingTo", "Suggests", or "Enhances"), or a logical vector. 551 #' 552 #' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and 553 #' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo" 554 #' and is the default. `FALSE` is shorthand for no dependencies (i.e. 555 #' just check this package, not its dependencies). 556 #' 557 #' The value "soft" means the same as `TRUE`, "hard" means the same as `NA`. 558 #' 559 #' You can also specify dependencies from one or more additional fields, 560 #' common ones include: 561 #' - Config/Needs/website - for dependencies used in building the pkgdown site. 562 #' - Config/Needs/coverage for dependencies used in calculating test coverage. 563 #' @param quiet If `TRUE`, suppress output. 564 #' @param upgrade Should package dependencies be upgraded? One of "default", "ask", "always", or "never". "default" 565 #' respects the value of the `R_REMOTES_UPGRADE` environment variable if set, 566 #' and falls back to "ask" if unset. "ask" prompts the user for which out of 567 #' date packages to upgrade. For non-interactive sessions "ask" is equivalent 568 #' to "always". `TRUE` and `FALSE` are also accepted and correspond to 569 #' "always" and "never" respectively. 570 #' @param repos A character vector giving repositories to use. 571 #' @param type Type of package to `update`. 572 #' 573 #' @param object A `package_deps` object. 574 #' @param ... Additional arguments passed to `install_packages`. 575 #' @inheritParams install_github 576 #' 577 #' @return 578 #' 579 #' A `data.frame` with columns: 580 #' 581 #' \tabular{ll}{ 582 #' `package` \tab The dependent package's name,\cr 583 #' `installed` \tab The currently installed version,\cr 584 #' `available` \tab The version available on CRAN,\cr 585 #' `diff` \tab An integer denoting whether the locally installed version 586 #' of the package is newer (1), the same (0) or older (-1) than the version 587 #' currently available on CRAN.\cr 588 #' } 589 #' 590 #' @export 591 #' @examples 592 #' \dontrun{ 593 #' package_deps("devtools") 594 #' # Use update to update any out-of-date dependencies 595 #' update(package_deps("devtools")) 596 #' } 597 598 package_deps <- function(packages, dependencies = NA, 599 repos = getOption("repos"), 600 type = getOption("pkgType")) { 601 602 repos <- fix_repositories(repos) 603 cran <- available_packages(repos, type) 604 605 deps <- find_deps(packages, available = cran, top_dep = dependencies) 606 607 # Remove base packages 608 inst <- utils::installed.packages() 609 base <- unname(inst[inst[, "Priority"] %in% c("base", "recommended"), "Package"]) 610 deps <- setdiff(deps, base) 611 612 # get remote types 613 remote <- structure(lapply(deps, package2remote, repos = repos, type = type), class = "remotes") 614 615 inst_ver <- vapply(deps, local_sha, character(1)) 616 cran_ver <- vapply(remote, function(x) remote_sha(x), character(1)) 617 is_cran_remote <- vapply(remote, inherits, logical(1), "cran_remote") 618 619 diff <- compare_versions(inst_ver, cran_ver, is_cran_remote) 620 621 res <- structure( 622 data.frame( 623 package = deps, 624 installed = inst_ver, 625 available = cran_ver, 626 diff = diff, 627 is_cran = is_cran_remote, 628 stringsAsFactors = FALSE 629 ), 630 class = c("package_deps", "data.frame") 631 ) 632 633 res$remote <- remote 634 635 res 636 } 637 638 #' `local_package_deps` extracts dependencies from a 639 #' local DESCRIPTION file. 640 #' 641 #' @export 642 #' @rdname package_deps 643 644 local_package_deps <- function(pkgdir = ".", dependencies = NA) { 645 pkg <- load_pkg_description(pkgdir) 646 647 dependencies <- tolower(standardise_dep(dependencies)) 648 dependencies <- intersect(dependencies, names(pkg)) 649 650 parsed <- lapply(pkg[tolower(dependencies)], parse_deps) 651 unlist(lapply(parsed, `[[`, "name"), use.names = FALSE) 652 } 653 654 #' `dev_package_deps` lists the status of the dependencies 655 #' of a local package. 656 #' 657 #' @export 658 #' @rdname package_deps 659 660 dev_package_deps <- function(pkgdir = ".", dependencies = NA, 661 repos = getOption("repos"), 662 type = getOption("pkgType")) { 663 664 pkg <- load_pkg_description(pkgdir) 665 repos <- c(repos, parse_additional_repositories(pkg)) 666 667 deps <- local_package_deps(pkgdir = pkgdir, dependencies = dependencies) 668 669 if (is_bioconductor(pkg)) { 670 bioc_repos <- bioc_install_repos() 671 672 missing_repos <- setdiff(names(bioc_repos), names(repos)) 673 674 if (length(missing_repos) > 0) 675 repos[missing_repos] <- bioc_repos[missing_repos] 676 } 677 678 cran_deps <- package_deps(deps, repos = repos, type = type) 679 680 res <- combine_remote_deps(cran_deps, extra_deps(pkg, "remotes")) 681 682 res <- do.call(rbind, c(list(res), lapply(get_extra_deps(pkg, dependencies), extra_deps, pkg = pkg), stringsAsFactors = FALSE)) 683 684 res[is.na(res$package) | !duplicated(res$package, fromLast = TRUE), ] 685 } 686 687 combine_remote_deps <- function(cran_deps, remote_deps) { 688 # If there are no dependencies there will be no remote dependencies either, 689 # so just return them (and don't force the remote_deps promise) 690 if (nrow(cran_deps) == 0) { 691 return(cran_deps) 692 } 693 694 # Only keep the remotes that are specified in the cran_deps or are NA 695 remote_deps <- remote_deps[is.na(remote_deps$package) | remote_deps$package %in% cran_deps$package, ] 696 697 # If there are remote deps remove the equivalent CRAN deps 698 cran_deps <- cran_deps[!(cran_deps$package %in% remote_deps$package), ] 699 700 rbind(remote_deps, cran_deps) 701 } 702 703 ## -2 = not installed, but available on CRAN 704 ## -1 = installed, but out of date 705 ## 0 = installed, most recent version 706 ## 1 = installed, version ahead of CRAN 707 ## 2 = package not on CRAN 708 709 compare_versions <- function(inst, remote, is_cran) { 710 stopifnot(length(inst) == length(remote) && length(inst) == length(is_cran)) 711 712 compare_var <- function(i, c, cran) { 713 if (!cran) { 714 if (identical(i, c)) { 715 return(CURRENT) 716 } else { 717 return(BEHIND) 718 } 719 } 720 if (is.na(c)) return(UNAVAILABLE) # not on CRAN 721 if (is.na(i)) return(UNINSTALLED) # not installed, but on CRAN 722 723 i <- package_version(i) 724 c <- package_version(c) 725 726 if (i < c) { 727 BEHIND # out of date 728 } else if (i > c) { 729 AHEAD # ahead of CRAN 730 } else { 731 CURRENT # most recent CRAN version 732 } 733 } 734 735 vapply(seq_along(inst), 736 function(i) compare_var(inst[[i]], remote[[i]], is_cran[[i]]), 737 integer(1)) 738 } 739 740 has_extra_deps <- function(pkg, dependencies) { 741 any(dependencies %in% names(pkg)) 742 } 743 744 get_extra_deps <- function(pkg, dependencies) { 745 dependencies <- tolower(dependencies) 746 747 dependencies <- intersect(dependencies, names(pkg)) 748 749 #remove standard dependencies 750 setdiff(dependencies, tolower(standardise_dep(TRUE))) 751 } 752 753 #' @export 754 print.package_deps <- function(x, show_ok = FALSE, ...) { 755 class(x) <- "data.frame" 756 x$remote <-lapply(x$remote, format) 757 758 ahead <- x$diff > 0L 759 behind <- x$diff < 0L 760 same_ver <- x$diff == 0L 761 762 x$diff <- NULL 763 x[] <- lapply(x, format_str, width = 12) 764 765 if (any(behind)) { 766 cat("Needs update -----------------------------\n") 767 print(x[behind, , drop = FALSE], row.names = FALSE, right = FALSE) 768 } 769 770 if (any(ahead)) { 771 cat("Not on CRAN ----------------------------\n") 772 print(x[ahead, , drop = FALSE], row.names = FALSE, right = FALSE) 773 } 774 775 if (show_ok && any(same_ver)) { 776 cat("OK ---------------------------------------\n") 777 print(x[same_ver, , drop = FALSE], row.names = FALSE, right = FALSE) 778 } 779 } 780 781 ## -2 = not installed, but available on CRAN 782 ## -1 = installed, but out of date 783 ## 0 = installed, most recent version 784 ## 1 = installed, version ahead of CRAN 785 ## 2 = package not on CRAN 786 787 UNINSTALLED <- -2L 788 BEHIND <- -1L 789 CURRENT <- 0L 790 AHEAD <- 1L 791 UNAVAILABLE <- 2L 792 793 #' @export 794 #' @rdname package_deps 795 #' @importFrom stats update 796 797 update.package_deps <- function(object, 798 dependencies = NA, 799 upgrade = c("default", "ask", "always", "never"), 800 force = FALSE, 801 quiet = FALSE, 802 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 803 build_manual = FALSE, build_vignettes = FALSE, 804 repos = getOption("repos"), 805 type = getOption("pkgType"), 806 ...) { 807 808 dependencies <- standardise_dep(dependencies) 809 810 object <- upgradable_packages(object, upgrade, quiet) 811 812 unavailable_on_cran <- object$diff == UNAVAILABLE & object$is_cran 813 814 unknown_remotes <- (object$diff == UNAVAILABLE | object$diff == UNINSTALLED) & !object$is_cran 815 816 if (any(unavailable_on_cran) && !quiet) { 817 message("Skipping ", sum(unavailable_on_cran), " packages not available: ", 818 paste(object$package[unavailable_on_cran], collapse = ", ")) 819 } 820 821 if (any(unknown_remotes)) { 822 install_remotes(object$remote[unknown_remotes], 823 dependencies = dependencies, 824 upgrade = upgrade, 825 force = force, 826 quiet = quiet, 827 build = build, 828 build_opts = build_opts, 829 build_manual = build_manual, 830 build_vignettes = build_vignettes, 831 repos = repos, 832 type = type, 833 ...) 834 } 835 836 ahead_of_cran <- object$diff == AHEAD & object$is_cran 837 if (any(ahead_of_cran) && !quiet) { 838 message("Skipping ", sum(ahead_of_cran), " packages ahead of CRAN: ", 839 paste(object$package[ahead_of_cran], collapse = ", ")) 840 } 841 842 ahead_remotes <- object$diff == AHEAD & !object$is_cran 843 if (any(ahead_remotes)) { 844 install_remotes(object$remote[ahead_remotes], 845 dependencies = dependencies, 846 upgrade = upgrade, 847 force = force, 848 quiet = quiet, 849 build = build, 850 build_opts = build_opts, 851 build_manual = build_manual, 852 build_vignettes = build_vignettes, 853 repos = repos, 854 type = type, 855 ...) 856 } 857 858 behind <- is.na(object$installed) | object$diff < CURRENT 859 860 if (any(object$is_cran & !unavailable_on_cran & behind)) { 861 # get the first cran-like remote and use its repos and pkg_type 862 r <- object$remote[object$is_cran & behind][[1]] 863 install_packages(object$package[object$is_cran & behind], repos = r$repos, 864 type = r$pkg_type, dependencies = dependencies, quiet = quiet, ...) 865 } 866 867 install_remotes(object$remote[!object$is_cran & behind], 868 dependencies = dependencies, 869 upgrade = upgrade, 870 force = force, 871 quiet = quiet, 872 build = build, 873 build_opts = build_opts, 874 build_manual = build_manual, 875 build_vignettes = build_vignettes, 876 repos = repos, 877 type = type, 878 ...) 879 880 invisible() 881 } 882 883 install_packages <- function(packages, repos = getOption("repos"), 884 type = getOption("pkgType"), ..., 885 dependencies = FALSE, quiet = NULL) { 886 887 # We want to pass only args that exist in the downstream functions 888 args_to_keep <- 889 unique( 890 names( 891 c( 892 formals(utils::install.packages), 893 formals(utils::download.file) 894 ) 895 ) 896 ) 897 898 args <- list(...) 899 args <- args[names(args) %in% args_to_keep] 900 901 if (is.null(quiet)) 902 quiet <- !identical(type, "source") 903 904 message("Installing ", length(packages), " packages: ", 905 paste(packages, collapse = ", ")) 906 907 do.call( 908 safe_install_packages, 909 c(list( 910 packages, 911 repos = repos, 912 type = type, 913 dependencies = dependencies, 914 quiet = quiet 915 ), 916 args 917 ) 918 ) 919 } 920 921 find_deps <- function(packages, available = available_packages(), 922 top_dep = TRUE, rec_dep = NA, include_pkgs = TRUE) { 923 if (length(packages) == 0 || identical(top_dep, FALSE)) 924 return(character()) 925 926 top_dep <- standardise_dep(top_dep) 927 rec_dep <- standardise_dep(rec_dep) 928 929 top <- tools::package_dependencies(packages, db = available, which = top_dep) 930 top_flat <- unlist(top, use.names = FALSE) 931 932 if (length(rec_dep) != 0 && length(top_flat) > 0) { 933 rec <- tools::package_dependencies(top_flat, db = available, which = rec_dep, 934 recursive = TRUE) 935 rec_flat <- unlist(rec, use.names = FALSE) 936 } else { 937 rec_flat <- character() 938 } 939 940 # We need to return these in reverse order, so that the packages furthest 941 # down in the tree are installed first. 942 unique(rev(c(if (include_pkgs) packages, top_flat, rec_flat))) 943 } 944 945 #' Standardise dependencies using the same logical as [install.packages] 946 #' 947 #' @param x The dependencies to standardise. 948 #' A character vector (selecting from "Depends", "Imports", 949 #' "LinkingTo", "Suggests", or "Enhances"), or a logical vector. 950 #' 951 #' `TRUE` is shorthand for "Depends", "Imports", "LinkingTo" and 952 #' "Suggests". `NA` is shorthand for "Depends", "Imports" and "LinkingTo" 953 #' and is the default. `FALSE` is shorthand for no dependencies. 954 #' 955 #' The value "soft" means the same as `TRUE`, "hard" means the same as `NA`. 956 #' 957 #' Any additional values that don't match one of the standard dependency 958 #' types are filtered out. 959 #' 960 #' @seealso <https://r-pkgs.org/description.html> for 961 #' additional information on what each dependency type means. 962 #' @keywords internal 963 #' @export 964 standardise_dep <- function(x) { 965 if (identical(x, NA)) { 966 c("Depends", "Imports", "LinkingTo") 967 } else if (isTRUE(x)) { 968 c("Depends", "Imports", "LinkingTo", "Suggests") 969 } else if (identical(x, FALSE)) { 970 character(0) 971 } else if (is.character(x)) { 972 if (any(x == "hard")) { 973 c("Depends", "Imports", "LinkingTo") 974 } else if (any(x == "soft")) { 975 c("Depends", "Imports", "LinkingTo", "Suggests") 976 } else { 977 intersect(x, c("Depends", "Imports", "LinkingTo", "Suggests", "Enhances")) 978 } 979 } else { 980 stop("Dependencies must be a boolean or a character vector", call. = FALSE) 981 } 982 } 983 984 #' Update packages that are missing or out-of-date. 985 #' 986 #' Works similarly to [utils::install.packages()] but doesn't install packages 987 #' that are already installed, and also upgrades out dated dependencies. 988 #' 989 #' @param packages Character vector of packages to update. 990 #' @param force Deprecated, this argument has no effect. 991 #' @inheritParams install_github 992 #' @seealso [package_deps()] to see which packages are out of date/ 993 #' missing. 994 #' @export 995 #' @examples 996 #' \dontrun{ 997 #' update_packages("ggplot2") 998 #' update_packages(c("plyr", "ggplot2")) 999 #' } 1000 1001 update_packages <- function(packages = TRUE, 1002 dependencies = NA, 1003 upgrade = c("default", "ask", "always", "never"), 1004 force = FALSE, 1005 quiet = FALSE, 1006 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 1007 build_manual = FALSE, build_vignettes = FALSE, 1008 repos = getOption("repos"), 1009 type = getOption("pkgType"), 1010 ...) { 1011 1012 if (isTRUE(force)) { 1013 .Deprecated(msg = "`update_packages(force = TRUE)` is deprecated and has no effect.") 1014 } 1015 1016 if (isTRUE(packages)) { 1017 packages <- utils::installed.packages()[, "Package"] 1018 } 1019 1020 pkgs <- package_deps(packages, repos = repos, type = type) 1021 update(pkgs, 1022 dependencies = dependencies, 1023 upgrade = upgrade, 1024 force = FALSE, 1025 quiet = quiet, 1026 build = build, 1027 build_opts = build_opts, 1028 build_manual = build_manual, 1029 build_vignettes = build_vignettes, 1030 repos = repos, 1031 type = type, 1032 ...) 1033 } 1034 1035 has_additional_repositories <- function(pkg) { 1036 "additional_repositories" %in% names(pkg) 1037 } 1038 1039 parse_additional_repositories <- function(pkg) { 1040 if (has_additional_repositories(pkg)) { 1041 1042 strsplit(trim_ws(pkg[["additional_repositories"]]), "[,[:space:]]+")[[1]] 1043 } 1044 } 1045 1046 fix_repositories <- function(repos) { 1047 if (length(repos) == 0) 1048 repos <- character() 1049 1050 # Override any existing default values with the cloud mirror 1051 # Reason: A "@CRAN@" value would open a GUI for choosing a mirror 1052 repos[repos == "@CRAN@"] <- download_url("cloud.r-project.org") 1053 repos 1054 } 1055 1056 parse_one_extra <- function(x, ...) { 1057 pieces <- strsplit(x, "::", fixed = TRUE)[[1]] 1058 1059 if (length(pieces) == 1) { 1060 if (!grepl("/", pieces)) { 1061 type <- "cran" 1062 } else { 1063 type <- "github" 1064 } 1065 repo <- pieces 1066 } else if (length(pieces) == 2) { 1067 type <- pieces[1] 1068 repo <- pieces[2] 1069 } else { 1070 stop("Malformed remote specification '", x, "'", call. = FALSE) 1071 } 1072 1073 if (grepl("@", type)) { 1074 # Custom host 1075 tah <- strsplit(type, "@", fixed = TRUE)[[1]] 1076 type <- tah[1] 1077 host <- tah[2] 1078 } else { 1079 host <- NULL 1080 } 1081 1082 tryCatch({ 1083 # We need to use `environment(sys.function())` instead of 1084 # `asNamespace("remotes")` because when used as a script in 1085 # install-github.R there is no remotes namespace. 1086 1087 fun <- get(paste0(tolower(type), "_remote"), mode = "function", inherits = TRUE) 1088 1089 if (!is.null(host)) { 1090 res <- fun(repo, host = host, ...) 1091 } else { 1092 res <- fun(repo, ...) 1093 } 1094 }, error = function(e) stop("Unknown remote type: ", type, "\n ", conditionMessage(e), call. = FALSE) 1095 ) 1096 res 1097 } 1098 1099 split_extra_deps <- function(x, name = "Remotes") { 1100 pkgs <- trim_ws(unlist(strsplit(x, ",[[:space:]]*"))) 1101 if (any((res <- grep("[[:space:]]+", pkgs)) != -1)) { 1102 stop("Missing commas separating ", name, ": '", pkgs[res], "'", call. = FALSE) 1103 } 1104 pkgs 1105 } 1106 1107 1108 package_deps_new <- function(package = character(), installed = character(), 1109 available = character(), diff = logical(), is_cran = logical(), 1110 remote = list()) { 1111 1112 res <- structure( 1113 data.frame(package = package, installed = installed, available = available, diff = diff, is_cran = is_cran, stringsAsFactors = FALSE), 1114 class = c("package_deps", "data.frame") 1115 ) 1116 1117 res$remote = structure(remote, class = "remotes") 1118 res 1119 } 1120 1121 extra_deps <- function(pkg, field) { 1122 if (!has_extra_deps(pkg, field)) { 1123 return(package_deps_new()) 1124 } 1125 dev_packages <- split_extra_deps(pkg[[field]]) 1126 extra <- lapply(dev_packages, parse_one_extra) 1127 1128 package <- vapply(extra, function(x) remote_package_name(x), character(1), USE.NAMES = FALSE) 1129 installed <- vapply(package, function(x) local_sha(x), character(1), USE.NAMES = FALSE) 1130 available <- vapply(extra, function(x) remote_sha(x), character(1), USE.NAMES = FALSE) 1131 diff <- installed == available 1132 diff <- ifelse(!is.na(diff) & diff, CURRENT, BEHIND) 1133 diff[is.na(installed)] <- UNINSTALLED 1134 is_cran_remote <- vapply(extra, inherits, logical(1), "cran_remote") 1135 1136 package_deps_new(package, installed, available, diff, is_cran = is_cran_remote, extra) 1137 } 1138 1139 1140 # interactive is an argument to make testing easier. 1141 resolve_upgrade <- function(upgrade, is_interactive = interactive()) { 1142 if (isTRUE(upgrade)) { 1143 upgrade <- "always" 1144 } else if (identical(upgrade, FALSE)) { 1145 upgrade <- "never" 1146 } 1147 1148 upgrade <- match.arg(upgrade[[1]], c("default", "ask", "always", "never")) 1149 1150 if (identical(upgrade, "default")) 1151 upgrade <- Sys.getenv("R_REMOTES_UPGRADE", unset = "ask") 1152 1153 if (!is_interactive && identical(upgrade, "ask")) { 1154 upgrade <- "always" 1155 } 1156 1157 upgrade 1158 } 1159 1160 upgradable_packages <- function(x, upgrade, quiet, is_interactive = interactive()) { 1161 1162 uninstalled <- x$diff == UNINSTALLED 1163 1164 behind <- x$diff == BEHIND 1165 1166 switch(resolve_upgrade(upgrade, is_interactive = is_interactive), 1167 1168 always = { 1169 return(msg_upgrades(x, quiet)) 1170 }, 1171 1172 never = return(x[uninstalled, ]), 1173 1174 ask = { 1175 1176 if (!any(behind)) { 1177 return(x) 1178 } 1179 1180 pkgs <- format_upgrades(x[behind, ]) 1181 1182 choices <- pkgs 1183 if (length(choices) > 0) { 1184 choices <- c("All", "CRAN packages only", "None", choices) 1185 } 1186 1187 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?") 1188 1189 if ("None" %in% res || length(res) == 0) { 1190 return(x[uninstalled, ]) 1191 } 1192 1193 if ("All" %in% res) { 1194 wch <- seq_len(NROW(x)) 1195 } else { 1196 1197 if ("CRAN packages only" %in% res) { 1198 wch <- uninstalled | (behind & x$is_cran) 1199 } else { 1200 wch <- sort(c(which(uninstalled), which(behind)[pkgs %in% res])) 1201 } 1202 } 1203 1204 msg_upgrades(x[wch, ], quiet) 1205 } 1206 ) 1207 } 1208 1209 select_menu <- function(choices, title = NULL, msg = "Enter one or more numbers, or an empty line to skip updates: ", width = getOption("width")) { 1210 if (!is.null(title)) { 1211 cat(title, "\n", sep = "") 1212 } 1213 1214 nc <- length(choices) 1215 op <- paste0(format(seq_len(nc)), ": ", choices) 1216 fop <- format(op) 1217 cat("", fop, "", sep = "\n") 1218 repeat { 1219 answer <- readline(msg) 1220 answer <- strsplit(answer, "[ ,]+")[[1]] 1221 if (all(answer %in% seq_along(choices))) { 1222 return(choices[as.integer(answer)]) 1223 } 1224 } 1225 } 1226 1227 1228 msg_upgrades <- function(x, quiet) { 1229 1230 if (isTRUE(quiet) || nrow(x) == 0) { 1231 return(invisible(x)) 1232 } 1233 1234 cat(format_upgrades(x[x$diff <= BEHIND, ]), sep = "\n") 1235 1236 invisible(x) 1237 } 1238 1239 format_upgrades <- function(x) { 1240 1241 if (nrow(x) == 0) { 1242 return(character(0)) 1243 } 1244 1245 remote_type <- lapply(x$remote, format) 1246 1247 # This call trims widths to 12 characters 1248 x[] <- lapply(x, format_str, width = 12) 1249 1250 # This call aligns the columns 1251 x[] <- lapply(x, format, trim = FALSE, justify = "left") 1252 1253 pkgs <- paste0(x$package, " (", x$installed, " -> ", x$available, ") ", "[", remote_type, "]") 1254 pkgs 1255 } 1256 # Contents of R/devel.R 1257 1258 ## The checking code looks for the objects in the package namespace, so defining 1259 ## dll here removes the following NOTE 1260 ## Registration problem: 1261 ## Evaluating ‘dll$foo’ during check gives error 1262 ## ‘object 'dll' not found’: 1263 ## .C(dll$foo, 0L) 1264 ## See https://github.com/wch/r-source/blob/d4e8fc9832f35f3c63f2201e7a35fbded5b5e14c/src/library/tools/R/QC.R##L1950-L1980 1265 ## Setting the class is needed to avoid a note about returning the wrong class. 1266 ## The local object is found first in the actual call, so current behavior is 1267 ## unchanged. 1268 1269 dll <- list(foo = structure(list(), class = "NativeSymbolInfo")) 1270 1271 has_devel <- function() { 1272 tryCatch( 1273 has_devel2(), 1274 error = function(e) FALSE 1275 ) 1276 } 1277 1278 ## This is similar to devtools:::has_devel(), with some 1279 ## very minor differences. 1280 1281 has_devel2 <- function() { 1282 foo_path <- file.path(tempfile(fileext = ".c")) 1283 1284 cat("void foo(int *bar) { *bar=1; }\n", file = foo_path) 1285 on.exit(unlink(foo_path)) 1286 1287 R(c("CMD", "SHLIB", basename(foo_path)), dirname(foo_path)) 1288 dylib <- sub("\\.c$", .Platform$dynlib.ext, foo_path) 1289 on.exit(unlink(dylib), add = TRUE) 1290 1291 dll <- dyn.load(dylib) 1292 on.exit(dyn.unload(dylib), add = TRUE) 1293 1294 stopifnot(.C(dll$foo, 0L)[[1]] == 1L) 1295 TRUE 1296 } 1297 1298 missing_devel_warning <- function(pkgdir) { 1299 pkgname <- tryCatch( 1300 get_desc_field(file.path(pkgdir, "DESCRIPTION"), "Package"), 1301 error = function(e) NULL 1302 ) %||% "<unknown>" 1303 1304 sys <- sys_type() 1305 1306 warning( 1307 "Package ", 1308 pkgname, 1309 " has compiled code, but no suitable ", 1310 "compiler(s) were found. Installation will likely fail.\n ", 1311 if (sys == "windows") { 1312 c("Install Rtools (https://cran.r-project.org/bin/windows/Rtools/).", 1313 "Then use the pkgbuild package, or make sure that Rtools in the PATH.") 1314 }, 1315 if (sys == "macos") "Install XCode and make sure it works.", 1316 if (sys == "linux") "Install compilers via your Linux package manager." 1317 ) 1318 } 1319 1320 R <- function(args, path = tempdir()) { 1321 1322 r <- file.path(R.home("bin"), "R") 1323 1324 args <- c( 1325 "--no-site-file", "--no-environ", "--no-save", 1326 "--no-restore", "--quiet", 1327 args 1328 ) 1329 1330 system_check(r, args, path = path) 1331 } 1332 # Contents of R/download.R 1333 1334 #' Download a file 1335 #' 1336 #' Uses either the curl package for R versions older than 3.2.0, 1337 #' otherwise a wrapper around [download.file()]. 1338 #' 1339 #' We respect the `download.file.method` setting of the user. If it is 1340 #' not set, then see `download_method()` for choosing a method. 1341 #' 1342 #' Authentication can be supplied three ways: 1343 #' * By setting `auth_token`. This will append an HTTP `Authorization` 1344 #' header: `Authorization: token {auth_token}`. 1345 #' * By setting `basic_auth` to a list with elements `user` and `password`. 1346 #' This will append a proper `Authorization: Basic {encoded_password}` 1347 #' HTTP header. 1348 #' * By specifying the proper `headers` directly. 1349 #' 1350 #' If both `auth_token` and `basic_auth` are specified, that's an error. 1351 #' `auth_token` and `basic_auth` are _appended_ to `headers`, so they 1352 #' take precedence over an `Authorization` header that is specified 1353 #' directly in `headers`. 1354 #' 1355 #' @param path Path to download to. `dirname(path)` must exist. 1356 #' @param url URL. 1357 #' @param auth_token Token for token-based authentication or `NULL`. 1358 #' @param basic_auth List with `user` and `password` for basic HTTP 1359 #' authentication, or `NULL`. 1360 #' @param quiet Passed to [download.file()] or [curl::curl_download()]. 1361 #' @param headers Named character vector of HTTP headers to use. 1362 #' @return `path`, if the download was successful. 1363 #' 1364 #' @keywords internal 1365 #' @importFrom utils compareVersion 1366 1367 download <- function(path, url, auth_token = NULL, basic_auth = NULL, 1368 quiet = TRUE, headers = NULL) { 1369 1370 if (!is.null(basic_auth) && !is.null(auth_token)) { 1371 stop("Cannot use both Basic and Token authentication at the same time") 1372 } 1373 1374 if (!is.null(basic_auth)) { 1375 userpass <- paste0(basic_auth$user, ":", basic_auth$password) 1376 auth <- paste("Basic", base64_encode(charToRaw(userpass))) 1377 headers <- c(headers, Authorization = auth) 1378 } 1379 1380 if (!is.null(auth_token)) { 1381 headers <- c(headers, Authorization = paste("token", auth_token)) 1382 } 1383 1384 if (getRversion() < "3.2.0") { 1385 curl_download(url, path, quiet, headers) 1386 1387 } else { 1388 1389 base_download(url, path, quiet, headers) 1390 } 1391 1392 path 1393 } 1394 1395 base_download <- function(url, path, quiet, headers) { 1396 1397 method <- download_method() 1398 1399 status <- if (method == "wget") { 1400 base_download_wget(url, path, quiet, headers) 1401 } else if (method =="curl") { 1402 base_download_curl(url, path, quiet, headers) 1403 } else if (getRversion() < "3.6.0") { 1404 base_download_noheaders(url, path, quiet, headers, method) 1405 } else { 1406 base_download_headers(url, path, quiet, headers, method) 1407 } 1408 1409 if (status != 0) stop("Cannot download file from ", url, call. = FALSE) 1410 1411 path 1412 } 1413 1414 base_download_wget <- function(url, path, quiet, headers) { 1415 1416 extra <- getOption("download.file.extra") 1417 1418 if (length(headers)) { 1419 qh <- shQuote(paste0(names(headers), ": ", headers)) 1420 extra <- c(extra, paste0("--header=", qh)) 1421 } 1422 1423 with_options( 1424 list(download.file.extra = extra), 1425 suppressWarnings( 1426 utils::download.file( 1427 url, 1428 path, 1429 method = "wget", 1430 quiet = quiet, 1431 mode = "wb", 1432 extra = extra 1433 ) 1434 ) 1435 ) 1436 } 1437 1438 base_download_curl <- function(url, path, quiet, headers) { 1439 1440 extra <- getOption("download.file.extra") 1441 1442 # always add `-L`, so that curl follows redirects. GitHub in particular uses 1443 # 302 redirects extensively, so without -L these requests fail. 1444 extra <- c(extra, "--fail", "-L") 1445 1446 if (length(headers)) { 1447 qh <- shQuote(paste0(names(headers), ": ", headers)) 1448 extra <- c(extra, paste("-H", qh)) 1449 } 1450 1451 with_options( 1452 list(download.file.extra = extra), 1453 suppressWarnings( 1454 utils::download.file( 1455 url, 1456 path, 1457 method = "curl", 1458 quiet = quiet, 1459 mode = "wb", 1460 extra = extra 1461 ) 1462 ) 1463 ) 1464 } 1465 1466 base_download_noheaders <- function(url, path, quiet, headers, method) { 1467 1468 if (length(headers)) { 1469 1470 if (method == "wininet" && getRversion() < "3.6.0") { 1471 warning(paste( 1472 "R (< 3.6.0) cannot send HTTP headers with the `wininet` download method.", 1473 "This download will likely fail. Please choose a different download", 1474 "method, via the `download.file.method` option. The `libcurl` method is", 1475 "best, if available, and the `wget` and `curl` methods work as well,", 1476 "if the corresponding external tool is available. See `?download.file`")) 1477 } 1478 1479 get("unlockBinding", baseenv())("makeUserAgent", asNamespace("utils")) 1480 orig <- get("makeUserAgent", envir = asNamespace("utils")) 1481 on.exit({ 1482 assign("makeUserAgent", orig, envir = asNamespace("utils")) 1483 lockBinding("makeUserAgent", asNamespace("utils")) 1484 }, add = TRUE) 1485 ua <- orig(FALSE) 1486 1487 flathead <- paste0(names(headers), ": ", headers, collapse = "\r\n") 1488 agent <- paste0(ua, "\r\n", flathead) 1489 assign( 1490 "makeUserAgent", 1491 envir = asNamespace("utils"), 1492 function(format = TRUE) { 1493 if (format) { 1494 paste0("User-Agent: ", agent, "\r\n") 1495 } else { 1496 agent 1497 } 1498 }) 1499 } 1500 1501 suppressWarnings( 1502 utils::download.file( 1503 url, 1504 path, 1505 method = method, 1506 quiet = quiet, 1507 mode = "wb" 1508 ) 1509 ) 1510 } 1511 1512 base_download_headers <- function(url, path, quiet, headers, method) { 1513 suppressWarnings( 1514 utils::download.file( 1515 url, 1516 path, 1517 method = method, 1518 quiet = quiet, 1519 mode = "wb", 1520 headers = headers 1521 ) 1522 ) 1523 } 1524 1525 has_curl <- function() isTRUE(unname(capabilities("libcurl"))) 1526 1527 download_method <- function() { 1528 1529 user_option <- getOption("download.file.method") 1530 1531 if (!is.null(user_option)) { 1532 ## The user wants what the user wants 1533 user_option 1534 1535 } else if (has_curl()) { 1536 ## If we have libcurl, it is usually the best option 1537 "libcurl" 1538 1539 } else if (compareVersion(get_r_version(), "3.3") == -1 && 1540 os_type() == "windows") { 1541 ## Before 3.3 we select wininet on Windows 1542 "wininet" 1543 1544 } else { 1545 ## Otherwise this is probably hopeless, but let R select, and 1546 ## try something 1547 "auto" 1548 } 1549 } 1550 1551 curl_download <- function(url, path, quiet, headers) { 1552 1553 if (!pkg_installed("curl")) { 1554 stop("The 'curl' package is required if R is older than 3.2.0") 1555 } 1556 1557 handle <- curl::new_handle() 1558 if (!is.null(headers)) curl::handle_setheaders(handle, .list = headers) 1559 curl::curl_download(url, path, quiet = quiet, mode = "wb", handle = handle) 1560 } 1561 1562 true_download_method <- function(x) { 1563 if (identical(x, "auto")) { 1564 auto_download_method() 1565 } else { 1566 x 1567 } 1568 } 1569 1570 auto_download_method <- function() { 1571 if (isTRUE(capabilities("libcurl"))) { 1572 "libcurl" 1573 } else if (isTRUE(capabilities("http/ftp"))) { 1574 "internal" 1575 } else if (nzchar(Sys.which("wget"))) { 1576 "wget" 1577 } else if (nzchar(Sys.which("curl"))) { 1578 "curl" 1579 } else { 1580 "" 1581 } 1582 } 1583 1584 download_method_secure <- function() { 1585 method <- true_download_method(download_method()) 1586 1587 if (method %in% c("wininet", "libcurl", "wget", "curl")) { 1588 # known good methods 1589 TRUE 1590 } else if (identical(method, "internal")) { 1591 # only done before R 3.3 1592 if (utils::compareVersion(get_r_version(), "3.3") == -1) { 1593 # if internal then see if were using windows internal with inet2 1594 identical(Sys.info()[["sysname"]], "Windows") && utils::setInternet2(NA) 1595 } else { 1596 FALSE 1597 } 1598 } else { 1599 # method with unknown properties (e.g. "lynx") or unresolved auto 1600 FALSE 1601 } 1602 } 1603 # Contents of R/git.R 1604 1605 # Extract the commit hash from a git archive. Git archives include the SHA1 1606 # hash as the comment field of the tarball pax extended header 1607 # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html) 1608 # For GitHub archives this should be the first header after the default one 1609 # (512 byte) header. 1610 git_extract_sha1_tar <- function(bundle) { 1611 1612 # open the bundle for reading 1613 # We use gzcon for everything because (from ?gzcon) 1614 # > Reading from a connection which does not supply a ‘gzip’ magic 1615 # > header is equivalent to reading from the original connection 1616 conn <- gzcon(file(bundle, open = "rb", raw = TRUE)) 1617 on.exit(close(conn)) 1618 1619 # The default pax header is 512 bytes long and the first pax extended header 1620 # with the comment should be 51 bytes long 1621 # `52 comment=` (11 chars) + 40 byte SHA1 hash 1622 len <- 0x200 + 0x33 1623 res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len]) 1624 1625 if (grepl("^52 comment=", res)) { 1626 sub("52 comment=", "", res) 1627 } else { 1628 NULL 1629 } 1630 } 1631 1632 git <- function(args, quiet = TRUE, path = ".") { 1633 full <- paste0(shQuote(check_git_path()), " ", paste(args, collapse = "")) 1634 if (!quiet) { 1635 message(full) 1636 } 1637 1638 result <- in_dir(path, system(full, intern = TRUE, ignore.stderr = quiet)) 1639 1640 status <- attr(result, "status") %||% 0 1641 if (!identical(as.character(status), "0")) { 1642 stop("Command failed (", status, ")", call. = FALSE) 1643 } 1644 1645 result 1646 } 1647 1648 # Retrieve the current running path of the git binary. 1649 # @param git_binary_name The name of the binary depending on the OS. 1650 git_path <- function(git_binary_name = NULL) { 1651 # Use user supplied path 1652 if (!is.null(git_binary_name)) { 1653 if (!file.exists(git_binary_name)) { 1654 stop("Path ", git_binary_name, " does not exist", .call = FALSE) 1655 } 1656 return(git_binary_name) 1657 } 1658 1659 # Look on path 1660 git_path <- Sys.which("git")[[1]] 1661 if (git_path != "") return(git_path) 1662 1663 # On Windows, look in common locations 1664 if (os_type() == "windows") { 1665 look_in <- c( 1666 "C:/Program Files/Git/bin/git.exe", 1667 "C:/Program Files (x86)/Git/bin/git.exe" 1668 ) 1669 found <- file.exists(look_in) 1670 if (any(found)) return(look_in[found][1]) 1671 } 1672 1673 NULL 1674 } 1675 1676 check_git_path <- function(git_binary_name = NULL) { 1677 1678 path <- git_path(git_binary_name) 1679 1680 if (is.null(path)) { 1681 stop("Git does not seem to be installed on your system.", call. = FALSE) 1682 } 1683 1684 path 1685 } 1686 # Contents of R/github.R 1687 1688 github_GET <- function(path, ..., host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl")) { 1689 1690 url <- build_url(host, path) 1691 1692 if (isTRUE(use_curl)) { 1693 h <- curl::new_handle() 1694 headers <- c( 1695 if (!is.null(pat)) { 1696 c("Authorization" = paste0("token ", pat)) 1697 } 1698 ) 1699 curl::handle_setheaders(h, .list = headers) 1700 res <- curl::curl_fetch_memory(url, handle = h) 1701 1702 if (res$status_code >= 300) { 1703 stop(github_error(res)) 1704 } 1705 json$parse(raw_to_char_utf8(res$content)) 1706 } else { 1707 tmp <- tempfile() 1708 download(tmp, url, auth_token = pat) 1709 1710 json$parse_file(tmp) 1711 } 1712 } 1713 1714 github_commit <- function(username, repo, ref = "HEAD", 1715 host = "api.github.com", pat = github_pat(), use_curl = !is_standalone() && pkg_installed("curl"), current_sha = NULL) { 1716 1717 url <- build_url(host, "repos", username, repo, "commits", utils::URLencode(ref, reserved = TRUE)) 1718 1719 if (isTRUE(use_curl)) { 1720 h <- curl::new_handle() 1721 headers <- c( 1722 "Accept" = "application/vnd.github.v3.sha", 1723 if (!is.null(pat)) { 1724 c("Authorization" = paste0("token ", pat)) 1725 } 1726 ) 1727 1728 if (!is.null(current_sha)) { 1729 headers <- c(headers, "If-None-Match" = paste0('"', current_sha, '"')) 1730 } 1731 curl::handle_setheaders(h, .list = headers) 1732 res <- curl::curl_fetch_memory(url, handle = h) 1733 if (res$status_code == 304) { 1734 return(current_sha) 1735 } 1736 if (res$status_code >= 300) { 1737 stop(github_error(res)) 1738 } 1739 1740 raw_to_char_utf8(res$content) 1741 } else { 1742 tmp <- tempfile() 1743 on.exit(unlink(tmp), add = TRUE) 1744 1745 download(tmp, url, auth_token = pat) 1746 get_json_sha(paste0(readLines(tmp, warn = FALSE), collapse = "\n")) 1747 } 1748 } 1749 1750 #' Retrieve Github personal access token. 1751 #' 1752 #' A github personal access token 1753 #' Looks in env var `GITHUB_PAT` or `GITHUB_TOKEN`. 1754 #' 1755 #' @keywords internal 1756 #' @noRd 1757 github_pat <- function(quiet = TRUE) { 1758 1759 env_var_aliases <- c( 1760 "GITHUB_PAT", 1761 "GITHUB_TOKEN" 1762 ) 1763 1764 for (env_var in env_var_aliases) { 1765 pat <- Sys.getenv(env_var) 1766 if (nzchar(pat)) { 1767 if (!quiet) { 1768 message("Using github PAT from envvar ", env_var) 1769 } 1770 return(pat) 1771 } 1772 } 1773 1774 if (in_ci()) { 1775 pat <- rawToChar(as.raw(c(0x67, 0x68, 0x70, 0x5f, 0x71, 0x31, 0x4e, 0x54, 0x48, 1776 0x71, 0x43, 0x57, 0x54, 0x69, 0x4d, 0x70, 0x30, 0x47, 0x69, 0x6e, 1777 0x77, 0x61, 0x42, 0x64, 0x75, 0x74, 0x32, 0x4f, 0x4b, 0x43, 0x74, 1778 0x6a, 0x31, 0x77, 0x30, 0x7a, 0x55, 0x59, 0x33, 0x59))) 1779 1780 if (!quiet) { 1781 message("Using bundled GitHub PAT. Please add your own PAT to the env var `GITHUB_PAT`") 1782 } 1783 1784 return(pat) 1785 } 1786 1787 NULL 1788 } 1789 1790 in_ci <- function() { 1791 nzchar(Sys.getenv("CI")) 1792 } 1793 1794 in_travis <- function() { 1795 identical(Sys.getenv("TRAVIS", "false"), "true") 1796 } 1797 1798 github_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "HEAD", host = "api.github.com", ..., 1799 use_curl = !is_standalone() && pkg_installed("curl"), pat = github_pat()) { 1800 1801 if (!is.null(subdir)) { 1802 subdir <- utils::URLencode(subdir) 1803 } 1804 1805 url <- build_url(host, "repos", username, repo, "contents", subdir, "DESCRIPTION") 1806 url <- paste0(url, "?ref=", utils::URLencode(ref)) 1807 1808 if (isTRUE(use_curl)) { 1809 h <- curl::new_handle() 1810 headers <- c( 1811 "Accept" = "application/vnd.github.v3.raw", 1812 if (!is.null(pat)) { 1813 c("Authorization" = paste0("token ", pat)) 1814 } 1815 ) 1816 1817 curl::handle_setheaders(h, .list = headers) 1818 res <- curl::curl_fetch_memory(url, handle = h) 1819 if (res$status_code >= 300) { 1820 stop(github_error(res)) 1821 } 1822 raw_to_char_utf8(res$content) 1823 } else { 1824 tmp <- tempfile() 1825 on.exit(unlink(tmp), add = TRUE) 1826 1827 tmp <- tempfile() 1828 download(tmp, url, auth_token = pat) 1829 1830 base64_decode(gsub("\\\\n", "", json$parse_file(tmp)$content)) 1831 } 1832 } 1833 1834 github_error <- function(res) { 1835 res_headers <- curl::parse_headers_list(res$headers) 1836 1837 ratelimit_limit <- res_headers$`x-ratelimit-limit` %||% NA_character_ 1838 1839 ratelimit_remaining <- res_headers$`x-ratelimit-remaining` %||% NA_character_ 1840 1841 ratelimit_reset <- .POSIXct(res_headers$`x-ratelimit-reset` %||% NA_character_, tz = "UTC") 1842 1843 error_details <- json$parse(raw_to_char_utf8(res$content))$message 1844 1845 guidance <- "" 1846 if (identical(as.integer(ratelimit_remaining), 0L)) { 1847 guidance <- 1848 sprintf( 1849 "To increase your GitHub API rate limit 1850 - Use `usethis::create_github_token()` to create a Personal Access Token. 1851 - %s", 1852 if (in_travis()) { 1853 "Add `GITHUB_PAT` to your travis settings as an encrypted variable." 1854 } else { 1855 "Use `usethis::edit_r_environ()` and add the token as `GITHUB_PAT`." 1856 } 1857 ) 1858 } else if (identical(as.integer(res$status_code), 404L)) { 1859 repo_information <- re_match(res$url, "(repos)/(?P<owner>[^/]+)/(?P<repo>[^/]++)/") 1860 if(!is.na(repo_information$owner) && !is.na(repo_information$repo)) { 1861 guidance <- sprintf( 1862 "Did you spell the repo owner (`%s`) and repo name (`%s`) correctly? 1863 - If spelling is correct, check that you have the required permissions to access the repo.", 1864 repo_information$owner, 1865 repo_information$repo 1866 ) 1867 } else { 1868 guidance <- "Did you spell the repo owner and repo name correctly? 1869 - If spelling is correct, check that you have the required permissions to access the repo." 1870 } 1871 } 1872 if(identical(as.integer(res$status_code), 404L)) { 1873 msg <- sprintf( 1874 "HTTP error %s. 1875 %s 1876 1877 %s", 1878 1879 res$status_code, 1880 error_details, 1881 guidance 1882 ) 1883 } else if (!is.na(ratelimit_limit)) { 1884 msg <- sprintf( 1885 "HTTP error %s. 1886 %s 1887 1888 Rate limit remaining: %s/%s 1889 Rate limit reset at: %s 1890 1891 %s", 1892 1893 res$status_code, 1894 error_details, 1895 ratelimit_remaining, 1896 ratelimit_limit, 1897 format(ratelimit_reset, usetz = TRUE), 1898 guidance 1899 ) 1900 } else { 1901 msg <- sprintf( 1902 "HTTP error %s. 1903 %s", 1904 1905 res$status_code, 1906 error_details 1907 ) 1908 } 1909 1910 status_type <- (as.integer(res$status_code) %/% 100) * 100 1911 1912 structure(list(message = msg, call = NULL), class = c(paste0("http_", unique(c(res$status_code, status_type, "error"))), "error", "condition")) 1913 } 1914 1915 1916 #> Error: HTTP error 404. 1917 #> Not Found 1918 #> 1919 #> Rate limit remaining: 4999 1920 #> Rate limit reset at: 2018-10-10 19:43:52 UTC 1921 # Contents of R/install-bioc.R 1922 #' Install a development package from the Bioconductor git repository 1923 #' 1924 #' This function requires `git` to be installed on your system in order to 1925 #' be used. 1926 #' 1927 #' It is vectorised so you can install multiple packages with 1928 #' a single command. 1929 #' 1930 #' This is intended as an aid for Bioconductor developers. If you want to 1931 #' install the release version of a Bioconductor package one can use the 1932 #' `BiocManager` package. 1933 #' @inheritParams install_git 1934 #' @param repo Repository address in the format 1935 #' `[username:password@@][release/]repo[#commit]`. Valid values for 1936 #' the release are \sQuote{devel}, 1937 #' \sQuote{release} (the default if none specified), or numeric release 1938 #' numbers (e.g. \sQuote{3.3}). 1939 #' @param mirror The Bioconductor git mirror to use 1940 #' @param ... Other arguments passed on to [utils::install.packages()]. 1941 #' @inheritParams install_github 1942 #' @export 1943 #' @family package installation 1944 #' @examples 1945 #' \dontrun{ 1946 #' install_bioc("SummarizedExperiment") 1947 #' install_bioc("devel/SummarizedExperiment") 1948 #' install_bioc("3.3/SummarizedExperiment") 1949 #' install_bioc("SummarizedExperiment#abc123") 1950 #' install_bioc("user:password@release/SummarizedExperiment") 1951 #' install_bioc("user:password@devel/SummarizedExperiment") 1952 #' install_bioc("user:password@SummarizedExperiment#abc123") 1953 #'} 1954 install_bioc <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")), 1955 git = c("auto", "git2r", "external"), 1956 dependencies = NA, 1957 upgrade = c("default", "ask", "always", "never"), 1958 force = FALSE, 1959 quiet = FALSE, 1960 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 1961 build_manual = FALSE, build_vignettes = FALSE, 1962 repos = getOption("repos"), 1963 type = getOption("pkgType"), 1964 ...) { 1965 1966 remotes <- lapply(repo, bioc_remote, mirror = mirror, git = match.arg(git)) 1967 1968 install_remotes(remotes, 1969 dependencies = dependencies, 1970 upgrade = upgrade, 1971 force = force, 1972 quiet = quiet, 1973 build = build, 1974 build_opts = build_opts, 1975 build_manual = build_manual, 1976 build_vignettes = build_vignettes, 1977 repos = repos, 1978 type = type, 1979 ...) 1980 } 1981 1982 bioc_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages")), 1983 git = c("auto", "git2r", "external"), ...) { 1984 1985 git <- match.arg(git) 1986 if (git == "auto") { 1987 git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external" 1988 } 1989 1990 list(git2r = bioc_git2r_remote, external = bioc_xgit_remote)[[git]](repo, mirror) 1991 } 1992 1993 # Parse concise git repo specification: [username:password@][branch/]repo[#commit] 1994 parse_bioc_repo <- function(path) { 1995 user_pass_rx <- "(?:([^:]+):([^:@]+)@)?" 1996 release_rx <- "(?:(devel|release|[0-9.]+)/)?" 1997 repo_rx <- "([^/@#]+)" 1998 commit_rx <- "(?:[#]([a-zA-Z0-9]+))?" 1999 bioc_rx <- sprintf("^(?:%s%s%s%s|(.*))$", user_pass_rx, release_rx, repo_rx, commit_rx) 2000 2001 param_names <- c("username", "password", "release", "repo", "commit", "invalid") 2002 replace <- stats::setNames(sprintf("\\%d", seq_along(param_names)), param_names) 2003 params <- lapply(replace, function(r) gsub(bioc_rx, r, path, perl = TRUE)) 2004 if (params$invalid != "") 2005 stop(sprintf("Invalid bioc repo: %s", path)) 2006 2007 params <- params[sapply(params, nchar) > 0] 2008 2009 if (!is.null(params$release) && !is.null(params$commit)) { 2010 stop("release and commit should not both be specified") 2011 } 2012 2013 params 2014 } 2015 2016 bioc_git2r_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) { 2017 meta <- parse_bioc_repo(repo) 2018 2019 branch <- bioconductor_branch(meta$release, meta$sha) 2020 2021 if (!is.null(meta$username) && !is.null(meta$password)) { 2022 meta$credentials <- git2r::cred_user_pass(meta$username, meta$password) 2023 } 2024 2025 remote("bioc_git2r", 2026 mirror = mirror, 2027 repo = meta$repo, 2028 release = meta$release %||% "release", 2029 sha = meta$commit, 2030 branch = branch, 2031 credentials = meta$credentials 2032 ) 2033 } 2034 2035 bioc_xgit_remote <- function(repo, mirror = getOption("BioC_git", download_url("git.bioconductor.org/packages"))) { 2036 meta <- parse_bioc_repo(repo) 2037 2038 branch <- bioconductor_branch(meta$release, meta$sha) 2039 2040 if (!is.null(meta$username) && !is.null(meta$password)) { 2041 meta$credentials <- git2r::cred_user_pass(meta$username, meta$password) 2042 } 2043 2044 remote("bioc_xgit", 2045 mirror = mirror, 2046 repo = meta$repo, 2047 release = meta$release %||% "release", 2048 sha = meta$commit, 2049 branch = branch, 2050 credentials = meta$credentials 2051 ) 2052 } 2053 2054 #' @export 2055 remote_download.bioc_git2r_remote <- function(x, quiet = FALSE) { 2056 url <- paste0(x$mirror, "/", x$repo) 2057 2058 if (!quiet) { 2059 message("Downloading Bioconductor repo ", url) 2060 } 2061 2062 bundle <- tempfile() 2063 git2r::clone(url, bundle, credentials=x$credentials, progress = FALSE) 2064 2065 if (!is.null(x$branch)) { 2066 r <- git2r::repository(bundle) 2067 git2r::checkout(r, x$branch) 2068 } 2069 2070 bundle 2071 } 2072 2073 #' @export 2074 remote_download.bioc_xgit_remote <- function(x, quiet = FALSE) { 2075 url <- paste0(x$mirror, "/", x$repo) 2076 2077 if (!quiet) { 2078 message("Downloading Bioconductor repo ", url) 2079 } 2080 2081 bundle <- tempfile() 2082 2083 args <- c('clone', '--depth', '1', '--no-hardlinks') 2084 2085 if (!is.null(x$branch) && x$branch != 'HEAD') { 2086 args <- c(args, "--branch", x$branch) 2087 } 2088 2089 args <- c(args, x$args, url, bundle) 2090 git(paste0(args, collapse = " "), quiet = quiet) 2091 2092 bundle 2093 } 2094 2095 #' @export 2096 remote_metadata.bioc_git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 2097 url <- paste0(x$mirror, "/", x$repo) 2098 2099 if (!is.null(bundle)) { 2100 r <- git2r::repository(bundle) 2101 sha <- git_repo_sha1(r) 2102 } else if (is_na(sha)) { 2103 sha <- NULL 2104 } 2105 2106 list( 2107 RemoteType = "bioc_git2r", 2108 RemoteMirror = x$mirror, 2109 RemoteRepo = x$repo, 2110 RemoteRelease = x$release, 2111 RemoteSha = sha, 2112 RemoteBranch = x$branch 2113 ) 2114 } 2115 2116 #' @export 2117 remote_metadata.bioc_xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 2118 if (is_na(sha)) { 2119 sha <- NULL 2120 } 2121 2122 list( 2123 RemoteType = "bioc_xgit", 2124 RemoteMirror = x$mirror, 2125 RemoteRepo = x$repo, 2126 RemoteRelease = x$release, 2127 RemoteSha = sha, 2128 RemoteBranch = x$branch, 2129 RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ") 2130 ) 2131 } 2132 2133 #' @export 2134 remote_package_name.bioc_git2r_remote <- function(remote, ...) { 2135 remote$repo 2136 } 2137 2138 #' @export 2139 remote_package_name.bioc_xgit_remote <- function(remote, ...) { 2140 remote$repo 2141 } 2142 2143 #' @export 2144 remote_sha.bioc_git2r_remote <- function(remote, ...) { 2145 tryCatch({ 2146 url <- paste0(remote$mirror, "/", remote$repo) 2147 2148 res <- git2r::remote_ls(url, credentials=remote$credentials) 2149 2150 found <- grep(pattern = paste0("/", remote$branch), x = names(res)) 2151 2152 if (length(found) == 0) { 2153 return(NA_character_) 2154 } 2155 2156 unname(res[found[1]]) 2157 }, error = function(e) NA_character_) 2158 } 2159 2160 remote_sha.bioc_xgit_remote <- function(remote, ...) { 2161 url <- paste0(remote$mirror, "/", remote$repo) 2162 ref <- remote$branch 2163 2164 refs <- git(paste("ls-remote", url, ref)) 2165 2166 refs_df <- read.delim(text = refs, stringsAsFactors = FALSE, sep = "\t", 2167 header = FALSE) 2168 names(refs_df) <- c("sha", "ref") 2169 2170 refs_df$sha[[1]] %||% NA_character_ 2171 } 2172 2173 bioconductor_branch <- function(release, sha) { 2174 if (!is.null(sha)) { 2175 sha 2176 } else { 2177 if (is.null(release)) { 2178 release <- Sys.getenv("R_BIOC_VERSION", "release") 2179 } 2180 if (release == "release") { 2181 release <- bioconductor_release() 2182 } else if (release == bioconductor$get_devel_version()) { 2183 release <- "devel" 2184 } 2185 switch( 2186 tolower(release), 2187 devel = "HEAD", 2188 paste0("RELEASE_", gsub("\\.", "_", release)) 2189 ) 2190 } 2191 2192 } 2193 2194 bioconductor_release <- function() { 2195 tmp <- tempfile() 2196 download(tmp, download_url("bioconductor.org/config.yaml"), quiet = TRUE) 2197 2198 gsub("release_version:[[:space:]]+\"([[:digit:].]+)\"", "\\1", 2199 grep("release_version:", readLines(tmp), value = TRUE)) 2200 } 2201 2202 #' @export 2203 format.bioc_git2r_remote <- function(x, ...) { 2204 "Bioc" 2205 } 2206 2207 #' @export 2208 format.bioc_xgit_remote <- function(x, ...) { 2209 "Bioc" 2210 } 2211 2212 # sha of most recent commit 2213 git_repo_sha1 <- function(r) { 2214 rev <- git2r::repository_head(r) 2215 if (is.null(rev)) { 2216 return(NULL) 2217 } 2218 2219 if (git2r::is_commit(rev)) { 2220 rev$sha 2221 } else { 2222 git2r::branch_target(rev) 2223 } 2224 } 2225 # Contents of R/install-bitbucket.R 2226 2227 #' Install a package directly from Bitbucket 2228 #' 2229 #' This function is vectorised so you can install multiple packages in 2230 #' a single command. 2231 #' 2232 #' @inheritParams install_github 2233 #' @param auth_user your account username if you're attempting to install 2234 #' a package hosted in a private repository (and your username is different 2235 #' to `username`). Defaults to the `BITBUCKET_USER` environment 2236 #' variable. 2237 #' @param password your password. Defaults to the `BITBUCKET_PASSWORD` 2238 #' environment variable. See details for further information on setting 2239 #' up a password. 2240 #' @param repo Repository address in the format 2241 #' `username/repo[/subdir][@@ref]`. Alternatively, you can 2242 #' specify `subdir` and/or `ref` using the respective parameters 2243 #' (see below); if both are specified, the values in `repo` take 2244 #' precedence. 2245 #' @param ref Desired git reference; could be a commit, tag, or branch name. 2246 #' Defaults to HEAD. 2247 #' @seealso Bitbucket API docs: 2248 #' <https://confluence.atlassian.com/bitbucket/use-the-bitbucket-cloud-rest-apis-222724129.html> 2249 #' 2250 #' @details To install from a private repo, or more generally, access the 2251 #' Bitbucket API with your own credentials, you will need to get an access 2252 #' token. You can create an access token following the instructions found in 2253 #' the 2254 #' \href{https://support.atlassian.com/bitbucket-cloud/docs/app-passwords/}{Bitbucket 2255 #' App Passwords documentation}. The App Password requires read-only access to 2256 #' your repositories and pull requests. Then store your password in the 2257 #' environment variable `BITBUCKET_PASSWORD` (e.g. `evelynwaugh:swordofhonour`) 2258 #' 2259 #' Note that on Windows, authentication requires the "libcurl" download 2260 #' method. You can set the default download method via the 2261 #' `download.file.method` option: 2262 #' ``` 2263 #' options(download.file.method = "libcurl") 2264 #' ``` 2265 #' In particular, if unset, RStudio sets the download method to "wininet". 2266 #' To override this, you might want to set it to "libcurl" in your 2267 #' R profile, see [base::Startup]. The caveat of the "libcurl" method is 2268 #' that it does _not_ set the system proxies automatically, see 2269 #' "Setting Proxies" in [utils::download.file()]. 2270 #' 2271 #' @inheritParams install_github 2272 #' @family package installation 2273 #' @export 2274 #' @examples 2275 #' \dontrun{ 2276 #' install_bitbucket("sulab/mygene.r@@default") 2277 #' install_bitbucket("djnavarro/lsr") 2278 #' } 2279 install_bitbucket <- function(repo, ref = "HEAD", subdir = NULL, 2280 auth_user = bitbucket_user(), password = bitbucket_password(), 2281 host = "api.bitbucket.org/2.0", 2282 dependencies = NA, 2283 upgrade = c("default", "ask", "always", "never"), 2284 force = FALSE, 2285 quiet = FALSE, 2286 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 2287 build_manual = FALSE, build_vignettes = FALSE, 2288 repos = getOption("repos"), 2289 type = getOption("pkgType"), 2290 ...) { 2291 2292 remotes <- lapply(repo, bitbucket_remote, ref = ref, 2293 subdir = subdir, auth_user = auth_user, password = password, host = host) 2294 2295 install_remotes(remotes, auth_user = auth_user, password = password, host = host, 2296 dependencies = dependencies, 2297 upgrade = upgrade, 2298 force = force, 2299 quiet = quiet, 2300 build = build, 2301 build_opts = build_opts, 2302 build_manual = build_manual, 2303 build_vignettes = build_vignettes, 2304 repos = repos, 2305 type = type, 2306 ...) 2307 } 2308 2309 bitbucket_remote <- function(repo, ref = "HEAD", subdir = NULL, 2310 auth_user = bitbucket_user(), password = bitbucket_password(), 2311 sha = NULL, host = "api.bitbucket.org/2.0", ...) { 2312 2313 meta <- parse_git_repo(repo) 2314 2315 remote("bitbucket", 2316 repo = meta$repo, 2317 subdir = meta$subdir %||% subdir, 2318 username = meta$username, 2319 ref = meta$ref %||% ref, 2320 sha = sha, 2321 auth_user = auth_user, 2322 password = password, 2323 host = host 2324 ) 2325 } 2326 2327 #' @export 2328 remote_download.bitbucket_remote <- function(x, quiet = FALSE) { 2329 if (!quiet) { 2330 message("Downloading bitbucket repo ", x$username, "/", x$repo, "@", x$ref) 2331 } 2332 2333 dest <- tempfile(fileext = paste0(".tar.gz")) 2334 2335 url <- bitbucket_download_url(x$username, x$repo, x$ref, host = x$host, auth = basic_auth(x)) 2336 2337 download(dest, url, basic_auth = basic_auth(x)) 2338 } 2339 2340 #' @export 2341 remote_metadata.bitbucket_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 2342 if (!is.null(bundle)) { 2343 # Might be able to get from archive 2344 sha <- git_extract_sha1_tar(bundle) 2345 } else if (is.na(sha)) { 2346 sha <- NULL 2347 } 2348 2349 list( 2350 RemoteType = "bitbucket", 2351 RemoteHost = x$host, 2352 RemoteRepo = x$repo, 2353 RemoteUsername = x$username, 2354 RemoteRef = x$ref, 2355 RemoteSha = sha, 2356 RemoteSubdir = x$subdir 2357 ) 2358 } 2359 2360 #' @export 2361 remote_package_name.bitbucket_remote <- function(remote, ...) { 2362 2363 bitbucket_DESCRIPTION( 2364 username = remote$username, repo = remote$repo, 2365 subdir = remote$subdir, ref = remote$ref, 2366 host = remote$host, auth = basic_auth(remote) 2367 )$Package 2368 } 2369 2370 #' @export 2371 remote_sha.bitbucket_remote <- function(remote, ...) { 2372 bitbucket_commit(username = remote$username, repo = remote$repo, 2373 host = remote$host, ref = remote$ref, auth = basic_auth(remote))$hash %||% NA_character_ 2374 } 2375 2376 #' @export 2377 format.bitbucket_remote <- function(x, ...) { 2378 "Bitbucket" 2379 } 2380 2381 bitbucket_commit <- function(username, repo, ref = "HEAD", 2382 host = "api.bitbucket.org/2.0", auth = NULL) { 2383 2384 url <- build_url(host, "repositories", username, repo, "commit", ref) 2385 2386 tmp <- tempfile() 2387 download(tmp, url, basic_auth = auth) 2388 2389 json$parse_file(tmp) 2390 } 2391 2392 bitbucket_DESCRIPTION <- function(username, repo, subdir = NULL, ref = "HEAD", host = "https://api.bitbucket.org/2.0", auth = NULL,...) { 2393 2394 url <- build_url(host, "repositories", username, repo, "src", ref, subdir, "DESCRIPTION") 2395 2396 tmp <- tempfile() 2397 download(tmp, url, basic_auth = auth) 2398 2399 read_dcf(tmp) 2400 } 2401 2402 basic_auth <- function(x) { 2403 if (!is.null(x$password)) { 2404 list( 2405 user = x$auth_user %||% x$username, 2406 password = x$password 2407 ) 2408 } else { 2409 NULL 2410 } 2411 } 2412 2413 2414 bitbucket_download_url <- function(username, repo, ref = "HEAD", 2415 host = "api.bitbucket.org/2.0", auth = NULL) { 2416 2417 url <- build_url(host, "repositories", username, repo) 2418 2419 tmp <- tempfile() 2420 download(tmp, url, basic_auth = auth) 2421 2422 paste0(build_url(json$parse_file(tmp)$links$html$href, "get", ref), ".tar.gz") 2423 } 2424 2425 bitbucket_password <- function(quiet = TRUE) { 2426 pass <- Sys.getenv("BITBUCKET_PASSWORD") 2427 if (identical(pass, "")) return(NULL) 2428 if (!quiet) message("Using bitbucket password from envvar BITBUCKET_PASSWORD") 2429 pass 2430 } 2431 2432 bitbucket_user <- function(quiet = TRUE) { 2433 user <- Sys.getenv("BITBUCKET_USER") 2434 if (identical(user, "")) return(NULL) 2435 if (!quiet) message("Using bitbucket user from envvar BITBUCKET_USER") 2436 user 2437 } 2438 # Contents of R/install-cran.R 2439 2440 #' Attempts to install a package from CRAN. 2441 #' 2442 #' This function is vectorised on `pkgs` so you can install multiple 2443 #' packages in a single command. 2444 #' 2445 #' @param pkgs A character vector of packages to install. 2446 #' @inheritParams install_github 2447 #' @export 2448 #' @family package installation 2449 #' @examples 2450 #' \dontrun{ 2451 #' install_cran("ggplot2") 2452 #' install_cran(c("httpuv", "shiny")) 2453 #' } 2454 install_cran <- function(pkgs, repos = getOption("repos"), type = getOption("pkgType"), 2455 dependencies = NA, 2456 upgrade = c("default", "ask", "always", "never"), 2457 force = FALSE, 2458 quiet = FALSE, 2459 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 2460 build_manual = FALSE, build_vignettes = FALSE, 2461 ...) { 2462 2463 remotes <- lapply(pkgs, cran_remote, repos = repos, type = type) 2464 2465 install_remotes(remotes, 2466 dependencies = dependencies, 2467 upgrade = upgrade, 2468 force = force, 2469 quiet = quiet, 2470 build = build, 2471 build_opts = build_opts, 2472 build_manual = build_manual, 2473 build_vignettes = build_vignettes, 2474 repos = repos, 2475 type = type, 2476 ...) 2477 } 2478 2479 cran_remote <- function(pkg, repos = getOption("repos"), type = getOption("pkgType"), ...) { 2480 2481 repos <- fix_repositories(repos) 2482 2483 remote("cran", 2484 name = pkg, 2485 repos = repos, 2486 pkg_type = type) 2487 } 2488 2489 #' @export 2490 remote_package_name.cran_remote <- function(remote, ...) { 2491 remote$name 2492 } 2493 2494 #' @export 2495 remote_sha.cran_remote <- function(remote, ...) { 2496 cran <- available_packages(remote$repos, remote$pkg_type) 2497 2498 trim_ws(unname(cran[, "Version"][match(remote$name, rownames(cran))])) 2499 } 2500 2501 #' @export 2502 format.cran_remote <- function(x, ...) { 2503 "CRAN" 2504 } 2505 # Contents of R/install-dev.R 2506 #' Install the development version of a package 2507 #' 2508 #' `install_dev()` retrieves the package DESCRIPTION from the CRAN mirror and 2509 #' looks in the 'URL' and 'BugReports' fields for GitHub, GitLab or Bitbucket 2510 #' URLs. It then calls the appropriate `install_()` function to install the 2511 #' development package. 2512 #' 2513 #' @param package The package name to install. 2514 #' @param cran_url The URL of the CRAN mirror to use, by default based on the 2515 #' 'repos' option. If unset uses 'https://cloud.r-project.org'. 2516 #' @param ... Additional arguments passed to [install_github()], 2517 #' [install_gitlab()], or [install_bitbucket()] functions. 2518 #' @family package installation 2519 #' @export 2520 #' @examples 2521 #' \dontrun{ 2522 #' # From GitHub 2523 #' install_dev("dplyr") 2524 #' 2525 #' # From GitLab 2526 #' install_dev("iemiscdata") 2527 #' 2528 #' # From Bitbucket 2529 #' install_dev("argparser") 2530 #' } 2531 install_dev <- function(package, cran_url = getOption("repos")[["CRAN"]], ...) { 2532 if (is.null(cran_url) || identical(cran_url, "@CRAN@")) { 2533 cran_url <- "https://cloud.r-project.org" 2534 } 2535 2536 refs <- dev_split_ref(package) 2537 url <- build_url(cran_url, "web", "packages", refs[["pkg"]], "DESCRIPTION") 2538 2539 f <- tempfile() 2540 on.exit(unlink(f)) 2541 2542 download(f, url) 2543 desc <- read_dcf(f) 2544 2545 url_fields <- c(desc$URL, desc$BugReports) 2546 2547 if (length(url_fields) == 0) { 2548 stop("Could not determine development repository", call. = FALSE) 2549 } 2550 2551 pkg_urls <- unlist(strsplit(url_fields, "[[:space:]]*,[[:space:]]*")) 2552 2553 # Remove trailing "/issues" from the BugReports URL 2554 pkg_urls <- sub("/issues$", "", pkg_urls) 2555 2556 valid_domains <- c("github[.]com", "gitlab[.]com", "bitbucket[.]org") 2557 2558 parts <- 2559 re_match(pkg_urls, 2560 sprintf("^https?://(?<domain>%s)/(?<username>%s)/(?<repo>%s)(?:/(?<subdir>%s))?", 2561 domain = paste0(valid_domains, collapse = "|"), 2562 username = "[^/]+", 2563 repo = "[^/@#]+", 2564 subdir = "[^/@$ ]+" 2565 ) 2566 )[c("domain", "username", "repo", "subdir")] 2567 2568 # Remove cases which don't match and duplicates 2569 2570 parts <- unique(stats::na.omit(parts)) 2571 2572 if (nrow(parts) != 1) { 2573 stop("Could not determine development repository", call. = FALSE) 2574 } 2575 2576 full_ref <- paste0( 2577 paste0(c(parts$username, parts$repo, if (nzchar(parts$subdir)) parts$subdir), collapse = "/"), 2578 refs[["ref"]] 2579 ) 2580 2581 switch(parts$domain, 2582 github.com = install_github(full_ref, ...), 2583 gitlab.com = install_gitlab(full_ref, ...), 2584 bitbucket.org = install_bitbucket(full_ref, ...) 2585 ) 2586 } 2587 # Contents of R/install-git.R 2588 2589 #' Install a package from a git repository 2590 #' 2591 #' It is vectorised so you can install multiple packages with 2592 #' a single command. You do not need to have the `git2r` package, 2593 #' or an external git client installed. 2594 #' 2595 #' If you need to set git credentials for use in the `Remotes` field you can do 2596 #' so by placing the credentials in the `remotes.git_credentials` global 2597 #' option. 2598 #' 2599 #' @param url Location of package. The url should point to a public or 2600 #' private repository. 2601 #' @param ref Name of branch, tag or SHA reference to use, if not HEAD. 2602 #' @param branch Deprecated, synonym for ref. 2603 #' @param subdir A sub-directory within a git repository that may 2604 #' contain the package we are interested in installing. 2605 #' @param credentials A git2r credentials object passed through to clone. 2606 #' Supplying this argument implies using `git2r` with `git`. 2607 #' @param git Whether to use the `git2r` package, or an external 2608 #' git client via system. Default is `git2r` if it is installed, 2609 #' otherwise an external git installation. 2610 #' @param ... Other arguments passed on to [utils::install.packages()]. 2611 #' @inheritParams install_github 2612 #' @family package installation 2613 #' @export 2614 #' @examples 2615 #' \dontrun{ 2616 #' install_git("https://github.com/hadley/stringr.git") 2617 #' install_git("https://github.com/hadley/stringr.git", ref = "stringr-0.2") 2618 #' } 2619 install_git <- function(url, subdir = NULL, ref = NULL, branch = NULL, 2620 credentials = git_credentials(), 2621 git = c("auto", "git2r", "external"), 2622 dependencies = NA, 2623 upgrade = c("default", "ask", "always", "never"), 2624 force = FALSE, 2625 quiet = FALSE, 2626 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 2627 build_manual = FALSE, build_vignettes = FALSE, 2628 repos = getOption("repos"), 2629 type = getOption("pkgType"), 2630 ...) { 2631 if (!missing(branch)) { 2632 warning("`branch` is deprecated, please use `ref`") 2633 ref <- branch 2634 } 2635 2636 remotes <- lapply(url, git_remote, 2637 subdir = subdir, ref = ref, 2638 credentials = credentials, git = match.arg(git) 2639 ) 2640 2641 install_remotes(remotes, 2642 credentials = credentials, 2643 dependencies = dependencies, 2644 upgrade = upgrade, 2645 force = force, 2646 quiet = quiet, 2647 build = build, 2648 build_opts = build_opts, 2649 build_manual = build_manual, 2650 build_vignettes = build_vignettes, 2651 repos = repos, 2652 type = type, 2653 ... 2654 ) 2655 } 2656 2657 2658 git_remote <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials(), 2659 git = c("auto", "git2r", "external"), ...) { 2660 git <- match.arg(git) 2661 if (git == "auto") { 2662 git <- if (!is_standalone() && pkg_installed("git2r")) "git2r" else "external" 2663 } 2664 2665 if (!is.null(credentials) && git != "git2r") { 2666 stop("`credentials` can only be used with `git = \"git2r\"`", call. = FALSE) 2667 } 2668 2669 url_parts = re_match( url, 2670 "(?<protocol>[^/]*://)?(?<authhost>[^/]+)(?<path>[^@]*)(@(?<ref>.*))?") 2671 2672 ref <- ref %||% (if (url_parts$ref == "") NULL else url_parts$ref) 2673 2674 url = paste0(url_parts$protocol, url_parts$authhost, url_parts$path) 2675 2676 list(git2r = git_remote_git2r, external = git_remote_xgit)[[git]](url, subdir, ref, credentials) 2677 } 2678 2679 2680 git_remote_git2r <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials()) { 2681 remote("git2r", 2682 url = url, 2683 subdir = subdir, 2684 ref = ref, 2685 credentials = credentials 2686 ) 2687 } 2688 2689 2690 git_remote_xgit <- function(url, subdir = NULL, ref = NULL, credentials = git_credentials()) { 2691 remote("xgit", 2692 url = url, 2693 subdir = subdir, 2694 ref = ref 2695 ) 2696 } 2697 2698 #' @export 2699 remote_download.git2r_remote <- function(x, quiet = FALSE) { 2700 if (!quiet) { 2701 message("Downloading git repo ", x$url) 2702 } 2703 2704 bundle <- tempfile() 2705 git2r::clone(x$url, bundle, credentials = x$credentials, progress = FALSE) 2706 2707 if (!is.null(x$ref)) { 2708 r <- git2r::repository(bundle) 2709 git2r::checkout(r, x$ref) 2710 } 2711 2712 bundle 2713 } 2714 2715 #' @export 2716 remote_metadata.git2r_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 2717 if (!is.null(bundle)) { 2718 r <- git2r::repository(bundle) 2719 sha <- git2r::commits(r)[[1]]$sha 2720 } else { 2721 sha <- NULL 2722 } 2723 2724 list( 2725 RemoteType = "git2r", 2726 RemoteUrl = x$url, 2727 RemoteSubdir = x$subdir, 2728 RemoteRef = x$ref, 2729 RemoteSha = sha 2730 ) 2731 } 2732 2733 #' @export 2734 remote_package_name.git2r_remote <- function(remote, ...) { 2735 tmp <- tempfile() 2736 on.exit(unlink(tmp)) 2737 description_path <- paste0(collapse = "/", c(remote$subdir, "DESCRIPTION")) 2738 2739 if (grepl("^https?://", remote$url)) { 2740 # assumes GitHub-style "<repo>/raw/<ref>/<path>" url 2741 url <- build_url(sub("\\.git$", "", remote$url), "raw", remote_sha(remote, ...), description_path) 2742 download_args <- list(path = tmp, url = url) 2743 if (!is.null(remote$credentials)) { 2744 if (inherits(remote$credentials, "cred_user_pass")) { 2745 download_args$basic_auth <- list( 2746 user = remote$credentials$username, 2747 password = remote$credentials$password 2748 ) 2749 } else if (inherits(remote$credentials, "cred_env")) { 2750 if (Sys.getenv(remote$credentials$username) == "") { 2751 stop(paste0("Environment variable `", remote$credentials$username, "` is unset."), .call = FALSE) 2752 } 2753 if (Sys.getenv(remote$credentials$password) == "") { 2754 stop(paste0("Environment variable `", remote$credentials$password, "` is unset."), .call = FALSE) 2755 } 2756 download_args$basic_auth <- list( 2757 user = Sys.getenv(remote$credentials$username), 2758 password = Sys.getenv(remote$credentials$username) 2759 ) 2760 } else if (inherits(remote$credentials, "cred_token")) { 2761 if (Sys.getenv(remote$credentials$token) == "") { 2762 stop(paste0("Environment variable `", remote$credentials$token, "` is unset."), .call = FALSE) 2763 } 2764 download_args$auth_token <- Sys.getenv(remote$credentials$token) 2765 } else if (inherits(remote$credentials, "cred_ssh_key")) { 2766 stop(paste( 2767 "Unable to fetch the package DESCRIPTION file using SSH key authentication.", 2768 "Try using `git2r::cred_user_pass`, `git2r::cred_env`, or `git2r::cred_token` instead of `git2r::cred_ssh_key` for authentication." 2769 ), .call = FALSE) 2770 } else { 2771 stop(paste( 2772 "`remote$credentials` is not NULL and it does not inherit from a recognized class.", 2773 "Recognized classes for `remote$credentials` are `cred_user_pass`, `cred_env`, `cred_token`, and `cred_ssh_key`." 2774 ), .call = FALSE) 2775 } 2776 } 2777 tryCatch({ 2778 do.call(download, args = download_args) 2779 read_dcf(tmp)$Package 2780 }, error = function(e) { 2781 NA_character_ 2782 }) 2783 } else { 2784 # Try using git archive --remote to retrieve the DESCRIPTION, if the protocol 2785 # or server doesn't support that return NA 2786 res <- try( 2787 silent = TRUE, 2788 system_check(git_path(), 2789 args = c( 2790 "archive", "-o", tmp, "--remote", remote$url, 2791 if (is.null(remote$ref)) "HEAD" else remote$ref, 2792 description_path 2793 ), 2794 quiet = TRUE 2795 ) 2796 ) 2797 2798 if (inherits(res, "try-error")) { 2799 return(NA_character_) 2800 } 2801 2802 # git archive returns a tar file, so extract it to tempdir and read the DCF 2803 utils::untar(tmp, files = description_path, exdir = tempdir()) 2804 2805 read_dcf(file.path(tempdir(), description_path))$Package 2806 } 2807 } 2808 2809 #' @export 2810 remote_sha.git2r_remote <- function(remote, ...) { 2811 tryCatch( 2812 { 2813 # set suppressWarnings in git2r 0.23.0+ 2814 res <- suppressWarnings(git2r::remote_ls(remote$url, credentials = remote$credentials)) 2815 2816 ref <- remote$ref %||% "HEAD" 2817 2818 if (ref != "HEAD") ref <- paste0("/", ref) 2819 2820 found <- grep(pattern = paste0(ref, "$"), x = names(res)) 2821 2822 # If none found, it is either a SHA, so return the pinned sha or NA 2823 if (length(found) == 0) { 2824 return(remote$ref %||% NA_character_) 2825 } 2826 2827 unname(res[found[1]]) 2828 }, 2829 error = function(e) { 2830 warning(e) 2831 NA_character_ 2832 } 2833 ) 2834 } 2835 2836 #' @export 2837 format.xgit_remote <- function(x, ...) { 2838 "Git" 2839 } 2840 2841 #' @export 2842 format.git2r_remote <- function(x, ...) { 2843 "Git" 2844 } 2845 2846 #' @export 2847 remote_download.xgit_remote <- function(x, quiet = FALSE) { 2848 if (!quiet) { 2849 message("Downloading git repo ", x$url) 2850 } 2851 2852 bundle <- tempfile() 2853 2854 args <- c("clone", "--depth", "1", "--no-hardlinks") 2855 args <- c(args, x$args, x$url, bundle) 2856 git(paste0(args, collapse = " "), quiet = quiet) 2857 2858 if (!is.null(x$ref)) { 2859 git(paste0(c("fetch", "origin", x$ref), collapse = " "), quiet = quiet, path = bundle) 2860 git(paste0(c("checkout", "FETCH_HEAD"), collapse = " "), quiet = quiet, path = bundle) 2861 } 2862 2863 bundle 2864 } 2865 2866 #' @export 2867 remote_metadata.xgit_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 2868 if (is_na(sha)) { 2869 sha <- NULL 2870 } 2871 2872 list( 2873 RemoteType = "xgit", 2874 RemoteUrl = x$url, 2875 RemoteSubdir = x$subdir, 2876 RemoteRef = x$ref, 2877 RemoteSha = sha, 2878 RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " ") 2879 ) 2880 } 2881 2882 #' @importFrom utils read.delim 2883 2884 #' @export 2885 remote_package_name.xgit_remote <- remote_package_name.git2r_remote 2886 2887 #' @export 2888 remote_sha.xgit_remote <- function(remote, ...) { 2889 url <- remote$url 2890 ref <- remote$ref 2891 2892 refs <- git(paste("ls-remote", url, ref)) 2893 2894 # If none found, it is either a SHA, so return the pinned SHA or NA 2895 if (length(refs) == 0) { 2896 return(remote$ref %||% NA_character_) 2897 } 2898 2899 refs_df <- read.delim( 2900 text = refs, stringsAsFactors = FALSE, sep = "\t", 2901 header = FALSE 2902 ) 2903 names(refs_df) <- c("sha", "ref") 2904 2905 refs_df$sha[[1]] 2906 } 2907 2908 #' Specify git credentials to use 2909 #' 2910 #' The global option `remotes.git_credentials` is used to set the git 2911 #' credentials. 2912 #' @export 2913 #' @keywords internal 2914 git_credentials <- function() { 2915 getOption("remotes.git_credentials", NULL) 2916 } 2917 # Contents of R/install-github.R 2918 #' Attempts to install a package directly from GitHub. 2919 #' 2920 #' This function is vectorised on `repo` so you can install multiple 2921 #' packages in a single command. 2922 #' 2923 #' @param repo Repository address in the format 2924 #' `username/repo[/subdir][@@ref|#pull|@@*release]`. Alternatively, you can 2925 #' specify `subdir` and/or `ref` using the respective parameters 2926 #' (see below); if both are specified, the values in `repo` take 2927 #' precedence. 2928 #' @param ref Desired git reference. Could be a commit, tag, or branch 2929 #' name, or a call to [github_pull()] or [github_release()]. Defaults to 2930 #' `"HEAD"`, which means the default branch on GitHub and for git remotes. 2931 #' See [setting-the-default-branch](https://help.github.com/en/github/administering-a-repository/setting-the-default-branch) 2932 #' for more details. 2933 #' @param subdir Subdirectory within repo that contains the R package. 2934 #' @param auth_token To install from a private repo, generate a personal 2935 #' access token (PAT) with at least repo scope in 2936 #' \url{https://github.com/settings/tokens} and 2937 #' supply to this argument. This is safer than using a password because 2938 #' you can easily delete a PAT without affecting any others. Defaults to 2939 #' the `GITHUB_PAT` environment variable. 2940 #' @param host GitHub API host to use. Override with your GitHub enterprise 2941 #' hostname, for example, `"github.hostname.com/api/v3"`. 2942 #' @param force Force installation, even if the remote state has not changed 2943 #' since the previous install. 2944 #' @inheritParams install_deps 2945 #' @param ... Other arguments passed on to [utils::install.packages()]. 2946 #' @details 2947 #' If the repository uses submodules a command-line git client is required to 2948 #' clone the submodules. 2949 #' @family package installation 2950 #' @export 2951 #' @seealso [github_pull()] 2952 #' @examples 2953 #' \dontrun{ 2954 #' install_github("klutometis/roxygen") 2955 #' install_github("wch/ggplot2", ref = github_pull("142")) 2956 #' install_github(c("rstudio/httpuv", "rstudio/shiny")) 2957 #' install_github(c("hadley/httr@@v0.4", "klutometis/roxygen#142", 2958 #' "r-lib/roxygen2@@*release", "mfrasca/r-logging/pkg")) 2959 #' 2960 #' # To install from a private repo, use auth_token with a token 2961 #' # from https://github.com/settings/tokens. You only need the 2962 #' # repo scope. Best practice is to save your PAT in env var called 2963 #' # GITHUB_PAT. 2964 #' install_github("hadley/private", auth_token = "abc") 2965 #' 2966 #' # To pass option arguments to `R CMD INSTALL` use `INSTALL_opts`. e.g. to 2967 #' install a package with source references and tests 2968 #' install_github("rstudio/shiny", INSTALL_opts = c("--with-keep.source", "--install-tests")) 2969 #' } 2970 install_github <- function(repo, 2971 ref = "HEAD", 2972 subdir = NULL, 2973 auth_token = github_pat(quiet), 2974 host = "api.github.com", 2975 dependencies = NA, 2976 upgrade = c("default", "ask", "always", "never"), 2977 force = FALSE, 2978 quiet = FALSE, 2979 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 2980 build_manual = FALSE, build_vignettes = FALSE, 2981 repos = getOption("repos"), 2982 type = getOption("pkgType"), 2983 ...) { 2984 2985 remotes <- lapply(repo, github_remote, ref = ref, 2986 subdir = subdir, auth_token = auth_token, host = host) 2987 2988 install_remotes(remotes, auth_token = auth_token, host = host, 2989 dependencies = dependencies, 2990 upgrade = upgrade, 2991 force = force, 2992 quiet = quiet, 2993 build = build, 2994 build_opts = build_opts, 2995 build_manual = build_manual, 2996 build_vignettes = build_vignettes, 2997 repos = repos, 2998 type = type, 2999 ...) 3000 } 3001 3002 #' Create a new github_remote 3003 #' 3004 #' This is an internal function to create a new github_remote, users should 3005 #' generally have no need for it. 3006 #' @inheritParams install_github 3007 #' @export 3008 #' @keywords internal 3009 github_remote <- function(repo, ref = "HEAD", subdir = NULL, 3010 auth_token = github_pat(), sha = NULL, 3011 host = "api.github.com", ...) { 3012 3013 meta <- parse_git_repo(repo) 3014 meta <- github_resolve_ref(meta$ref %||% ref, meta, host = host, auth_token = auth_token) 3015 3016 remote("github", 3017 host = host, 3018 package = meta$package, 3019 repo = meta$repo, 3020 subdir = meta$subdir %||% subdir, 3021 username = meta$username, 3022 ref = meta$ref, 3023 sha = sha, 3024 auth_token = auth_token 3025 ) 3026 } 3027 3028 #' @export 3029 remote_download.github_remote <- function(x, quiet = FALSE) { 3030 if (!quiet) { 3031 message("Downloading GitHub repo ", x$username, "/", x$repo, "@", x$ref) 3032 } 3033 3034 dest <- tempfile(fileext = paste0(".tar.gz")) 3035 src_root <- build_url(x$host, "repos", x$username, x$repo) 3036 src <- paste0(src_root, "/tarball/", utils::URLencode(x$ref, reserved = TRUE)) 3037 3038 download(dest, src, auth_token = x$auth_token) 3039 } 3040 3041 #' @export 3042 remote_metadata.github_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 3043 3044 if (!is.null(bundle)) { 3045 # Might be able to get from archive 3046 sha <- git_extract_sha1_tar(bundle) 3047 } else if (is_na(sha)) { 3048 sha <- NULL 3049 } 3050 3051 list( 3052 RemoteType = "github", 3053 RemoteHost = x$host, 3054 RemotePackage = x$package, 3055 RemoteRepo = x$repo, 3056 RemoteUsername = x$username, 3057 RemoteRef = x$ref, 3058 RemoteSha = sha, 3059 RemoteSubdir = x$subdir, 3060 # Backward compatibility for packrat etc. 3061 GithubRepo = x$repo, 3062 GithubUsername = x$username, 3063 GithubRef = x$ref, 3064 GithubSHA1 = sha, 3065 GithubSubdir = x$subdir 3066 ) 3067 } 3068 3069 #' GitHub references 3070 #' 3071 #' Use as `ref` parameter to [install_github()]. 3072 #' Allows installing a specific pull request or the latest release. 3073 #' 3074 #' @param pull Character string specifying the pull request to install 3075 #' @seealso [install_github()] 3076 #' @examples 3077 #' github_pull("42") 3078 #' @rdname github_refs 3079 #' @export 3080 github_pull <- function(pull) structure(pull, class = "github_pull") 3081 3082 #' @rdname github_refs 3083 #' @export 3084 github_release <- function() structure(NA_integer_, class = "github_release") 3085 3086 github_resolve_ref <- function(x, params, ...) UseMethod("github_resolve_ref") 3087 3088 #' @export 3089 github_resolve_ref.default <- function(x, params, ...) { 3090 params$ref <- x 3091 params 3092 } 3093 3094 #' @export 3095 github_resolve_ref.NULL <- function(x, params, ...) { 3096 params$ref <- "HEAD" 3097 params 3098 } 3099 3100 #' @export 3101 github_resolve_ref.github_pull <- function(x, params, ..., host, auth_token = github_pat()) { 3102 # GET /repos/:user/:repo/pulls/:number 3103 path <- file.path("repos", params$username, params$repo, "pulls", x) 3104 response <- tryCatch( 3105 github_GET(path, host = host, pat = auth_token), 3106 error = function(e) e 3107 ) 3108 3109 ## Just because libcurl might download the error page... 3110 if (methods::is(response, "error") || is.null(response$head)) { 3111 stop("Cannot find GitHub pull request ", params$username, "/", 3112 params$repo, "#", x, "\n", 3113 response$message) 3114 } 3115 3116 params$username <- response$head$user$login 3117 params$ref <- response$head$ref 3118 params 3119 } 3120 3121 # Retrieve the ref for the latest release 3122 #' @export 3123 github_resolve_ref.github_release <- function(x, params, ..., host, auth_token = github_pat()) { 3124 # GET /repos/:user/:repo/releases 3125 path <- paste("repos", params$username, params$repo, "releases", sep = "/") 3126 response <- tryCatch( 3127 github_GET(path, host = host, pat = auth_token), 3128 error = function(e) e 3129 ) 3130 3131 if (methods::is(response, "error") || !is.null(response$message)) { 3132 stop("Cannot find repo ", params$username, "/", params$repo, ".", "\n", 3133 response$message) 3134 } 3135 3136 if (length(response) == 0L) 3137 stop("No releases found for repo ", params$username, "/", params$repo, ".") 3138 3139 params$ref <- response[[1L]]$tag_name 3140 params 3141 } 3142 3143 #' @export 3144 remote_package_name.github_remote <- function(remote, ..., use_local = TRUE, 3145 use_curl = !is_standalone() && pkg_installed("curl")) { 3146 3147 # If the package name was explicitly specified, use that 3148 if (!is.null(remote$package)) { 3149 return(remote$package) 3150 } 3151 3152 # Otherwise if the repo is an already installed package assume that. 3153 if (isTRUE(use_local)) { 3154 local_name <- suppressWarnings(utils::packageDescription(remote$repo, fields = "Package")) 3155 if (!is.na(local_name)) { 3156 return(local_name) 3157 } 3158 } 3159 3160 # Otherwise lookup the package name from the remote DESCRIPTION file 3161 desc <- github_DESCRIPTION(username = remote$username, repo = remote$repo, 3162 subdir = remote$subdir, host = remote$host, ref = remote$ref, 3163 pat = remote$auth_token %||% github_pat(), use_curl = use_curl) 3164 3165 if (is.null(desc)) { 3166 return(NA_character_) 3167 } 3168 3169 tmp <- tempfile() 3170 writeChar(desc, tmp) 3171 on.exit(unlink(tmp)) 3172 3173 read_dcf(tmp)$Package 3174 } 3175 3176 #' @export 3177 remote_sha.github_remote <- function(remote, ..., use_curl = !is_standalone() && pkg_installed("curl")) { 3178 tryCatch( 3179 github_commit(username = remote$username, repo = remote$repo, 3180 host = remote$host, ref = remote$ref, pat = remote$auth_token %||% github_pat(), use_curl = use_curl), 3181 3182 # 422 errors most often occur when a branch or PR has been deleted, so we 3183 # ignore the error in this case 3184 http_422 = function(e) NA_character_ 3185 ) 3186 } 3187 3188 #' @export 3189 format.github_remote <- function(x, ...) { 3190 "GitHub" 3191 } 3192 # Contents of R/install-gitlab.R 3193 #' Install a package from GitLab 3194 #' 3195 #' This function is vectorised on `repo` so you can install multiple 3196 #' packages in a single command. Like other remotes the repository will skip 3197 #' installation if `force == FALSE` (the default) and the remote state has 3198 #' not changed since the previous installation. 3199 #' 3200 #' @inheritParams install_github 3201 #' @param repo Repository address in the format 3202 #' `username/repo[@@ref]`. 3203 #' @param host GitLab API host to use. Override with your GitLab enterprise 3204 #' hostname, for example, `"<PROTOCOL://>gitlab.hostname.com"`. 3205 #' The PROTOCOL is required by packrat during RStudio Connect deployment. While 3206 #' \link{install_gitlab} may work without, omitting it generally 3207 #' leads to package restoration errors. 3208 #' @param auth_token To install from a private repo, generate a personal access 3209 #' token (PAT) with at least read_api scope in 3210 #' \url{https://docs.gitlab.com/ee/user/profile/personal_access_tokens.html} and 3211 #' supply to this argument. This is safer than using a password because you 3212 #' can easily delete a PAT without affecting any others. Defaults to the 3213 #' GITLAB_PAT environment variable. 3214 #' @inheritParams install_github 3215 #' @export 3216 #' @family package installation 3217 #' @examples 3218 #' \dontrun{ 3219 #' install_gitlab("jimhester/covr") 3220 #' } 3221 install_gitlab <- function(repo, 3222 subdir = NULL, 3223 auth_token = gitlab_pat(quiet), 3224 host = "gitlab.com", 3225 dependencies = NA, 3226 upgrade = c("default", "ask", "always", "never"), 3227 force = FALSE, 3228 quiet = FALSE, 3229 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 3230 build_manual = FALSE, build_vignettes = FALSE, 3231 repos = getOption("repos"), 3232 type = getOption("pkgType"), 3233 ...) { 3234 3235 remotes <- lapply(repo, gitlab_remote, subdir = subdir, auth_token = auth_token, host = host) 3236 3237 install_remotes(remotes, auth_token = auth_token, host = host, 3238 dependencies = dependencies, 3239 upgrade = upgrade, 3240 force = force, 3241 quiet = quiet, 3242 build = build, 3243 build_opts = build_opts, 3244 build_manual = build_manual, 3245 build_vignettes = build_vignettes, 3246 repos = repos, 3247 type = type, 3248 ...) 3249 } 3250 3251 gitlab_remote <- function(repo, subdir = NULL, 3252 auth_token = gitlab_pat(), sha = NULL, 3253 host = "gitlab.com", ...) { 3254 3255 meta <- parse_git_repo(repo) 3256 meta$ref <- meta$ref %||% "HEAD" 3257 3258 remote("gitlab", 3259 host = host, 3260 repo = paste(c(meta$repo, meta$subdir), collapse = "/"), 3261 subdir = subdir, 3262 username = meta$username, 3263 ref = meta$ref, 3264 sha = sha, 3265 auth_token = auth_token 3266 ) 3267 } 3268 3269 #' @export 3270 remote_download.gitlab_remote <- function(x, quiet = FALSE) { 3271 dest <- tempfile(fileext = paste0(".tar.gz")) 3272 3273 project_id <- gitlab_project_id(x$username, x$repo, x$ref, x$host, x$auth_token) 3274 3275 src_root <- build_url(x$host, "api", "v4", "projects", project_id) 3276 src <- paste0(src_root, "/repository/archive.tar.gz?sha=", utils::URLencode(x$ref, reserved = TRUE)) 3277 3278 if (!quiet) { 3279 message("Downloading GitLab repo ", x$username, "/", x$repo, "@", x$ref, 3280 "\nfrom URL ", src) 3281 } 3282 3283 download(dest, src, headers = c("Private-Token" = x$auth_token)) 3284 } 3285 3286 #' @export 3287 remote_metadata.gitlab_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 3288 3289 if (!is.null(bundle)) { 3290 # Might be able to get from archive 3291 sha <- git_extract_sha1_tar(bundle) 3292 } else if (is_na(sha)) { 3293 sha <- NULL 3294 } 3295 3296 list( 3297 RemoteType = "gitlab", 3298 RemoteHost = x$host, 3299 RemoteRepo = x$repo, 3300 RemoteUsername = x$username, 3301 RemoteRef = x$ref, 3302 RemoteSha = sha, 3303 RemoteSubdir = x$subdir 3304 ) 3305 } 3306 3307 #' @export 3308 remote_package_name.gitlab_remote <- function(remote, ...) { 3309 3310 tmp <- tempfile() 3311 3312 src_root <- build_url( 3313 remote$host, "api", "v4", "projects", 3314 utils::URLencode(paste0(remote$username, "/", remote$repo), 3315 reserved = TRUE), 3316 "repository") 3317 3318 src <- paste0( 3319 src_root, "/files/", 3320 ifelse( 3321 is.null(remote$subdir), 3322 "DESCRIPTION", 3323 utils::URLencode(paste0(remote$subdir, "/DESCRIPTION"), reserved = TRUE)), 3324 "/raw?ref=", utils::URLencode(remote$ref, reserved = TRUE)) 3325 3326 dest <- tempfile() 3327 res <- download(dest, src, headers = c("Private-Token" = remote$auth_token)) 3328 3329 tryCatch( 3330 read_dcf(dest)$Package, 3331 error = function(e) remote$repo) 3332 } 3333 3334 #' @export 3335 remote_sha.gitlab_remote <- function(remote, ...) { 3336 gitlab_commit(username = remote$username, repo = remote$repo, 3337 host = remote$host, ref = remote$ref, pat = remote$auth_token) 3338 } 3339 3340 #' @export 3341 format.gitlab_remote <- function(x, ...) { 3342 "GitLab" 3343 } 3344 3345 gitlab_commit <- function(username, repo, ref = "HEAD", 3346 host = "gitlab.com", pat = gitlab_pat()) { 3347 3348 url <- build_url(host, "api", "v4", "projects", utils::URLencode(paste0(username, "/", repo), reserved = TRUE), "repository", "commits", utils::URLencode(ref, reserved = TRUE)) 3349 3350 tmp <- tempfile() 3351 download(tmp, url, headers = c("Private-Token" = pat)) 3352 3353 json$parse_file(tmp)$id 3354 } 3355 3356 #' Retrieve GitLab personal access token. 3357 #' 3358 #' A GitLab personal access token 3359 #' Looks in env var `GITLAB_PAT` 3360 #' 3361 #' @keywords internal 3362 #' @export 3363 gitlab_pat <- function(quiet = TRUE) { 3364 pat <- Sys.getenv("GITLAB_PAT") 3365 if (nzchar(pat)) { 3366 if (!quiet) { 3367 message("Using GitLab PAT from envvar GITLAB_PAT") 3368 } 3369 return(pat) 3370 } 3371 return(NULL) 3372 } 3373 3374 gitlab_project_id <- function(username, repo, ref = "HEAD", 3375 host = "gitlab.com", pat = gitlab_pat()) { 3376 3377 url <- build_url(host, "api", "v4", "projects", utils::URLencode(paste0(username, "/", repo), reserved = TRUE), "repository", "commits", utils::URLencode(ref, reserved = TRUE)) 3378 3379 tmp <- tempfile() 3380 download(tmp, url, headers = c("Private-Token" = pat)) 3381 3382 json$parse_file(tmp)$project_id 3383 } 3384 # Contents of R/install-local.R 3385 3386 #' Install a package from a local file 3387 #' 3388 #' This function is vectorised so you can install multiple packages in 3389 #' a single command. 3390 #' 3391 #' @param path path to local directory, or compressed file (tar, zip, tar.gz 3392 #' tar.bz2, tgz2 or tbz) 3393 #' @inheritParams install_url 3394 #' @inheritParams install_github 3395 #' @export 3396 #' @family package installation 3397 #' @examples 3398 #' \dontrun{ 3399 #' dir <- tempfile() 3400 #' dir.create(dir) 3401 #' pkg <- download.packages("testthat", dir, type = "source") 3402 #' install_local(pkg[, 2]) 3403 #' } 3404 3405 install_local <- function(path = ".", subdir = NULL, 3406 dependencies = NA, 3407 upgrade = c("default", "ask", "always", "never"), 3408 force = FALSE, 3409 quiet = FALSE, 3410 build = !is_binary_pkg(path), 3411 build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 3412 build_manual = FALSE, build_vignettes = FALSE, 3413 repos = getOption("repos"), 3414 type = getOption("pkgType"), 3415 ...) { 3416 3417 remotes <- lapply(path, local_remote, subdir = subdir) 3418 install_remotes(remotes, 3419 dependencies = dependencies, 3420 upgrade = upgrade, 3421 force = force, 3422 quiet = quiet, 3423 build = build, 3424 build_opts = build_opts, 3425 build_manual = build_manual, 3426 build_vignettes = build_vignettes, 3427 repos = repos, 3428 type = type, 3429 ...) 3430 } 3431 3432 local_remote <- function(path, subdir = NULL, branch = NULL, args = character(0), ...) { 3433 remote("local", 3434 path = normalizePath(path), 3435 subdir = subdir 3436 ) 3437 } 3438 3439 #' @export 3440 remote_download.local_remote <- function(x, quiet = FALSE) { 3441 # Already downloaded - just need to copy to tempdir() 3442 bundle <- tempfile() 3443 dir.create(bundle) 3444 suppressWarnings( 3445 res <- file.copy(x$path, bundle, recursive = TRUE) 3446 ) 3447 if (!all(res)) { 3448 stop("Could not copy `", x$path, "` to `", bundle, "`", call. = FALSE) 3449 } 3450 3451 # file.copy() creates directory inside of bundle 3452 dir(bundle, full.names = TRUE)[1] 3453 } 3454 3455 #' @export 3456 remote_metadata.local_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 3457 list( 3458 RemoteType = "local", 3459 RemoteUrl = x$path, 3460 RemoteSubdir = x$subdir 3461 ) 3462 } 3463 3464 #' @export 3465 remote_package_name.local_remote <- function(remote, ...) { 3466 is_tarball <- !dir.exists(remote$path) 3467 if (is_tarball) { 3468 # Assume the name is the name of the tarball 3469 return(sub("_.*$", "", basename(remote$path))) 3470 } 3471 description_path <- file.path(remote$path, "DESCRIPTION") 3472 3473 read_dcf(description_path)$Package 3474 } 3475 3476 #' @export 3477 remote_sha.local_remote <- function(remote, ...) { 3478 is_tarball <- !dir.exists(remote$path) 3479 if (is_tarball) { 3480 return(NA_character_) 3481 } 3482 3483 read_dcf(file.path(remote$path, "DESCRIPTION"))$Version 3484 } 3485 3486 #' @export 3487 format.local_remote <- function(x, ...) { 3488 "local" 3489 } 3490 # Contents of R/install-remote.R 3491 #' Install a remote package. 3492 #' 3493 #' This: 3494 #' \enumerate{ 3495 #' \item downloads source bundle 3496 #' \item decompresses & checks that it's a package 3497 #' \item adds metadata to DESCRIPTION 3498 #' \item calls install 3499 #' } 3500 #' 3501 #' It uses the additional S3 generic functions to work. Writing methods for 3502 #' these functions would allow 3rd party packages to define custom remotes. 3503 #' @inheritParams install_github 3504 #' @keywords internal 3505 #' @export 3506 install_remote <- function(remote, 3507 dependencies, 3508 upgrade, 3509 force, 3510 quiet, 3511 build, 3512 build_opts, 3513 build_manual, 3514 build_vignettes, 3515 repos, 3516 type, 3517 ...) { 3518 3519 stopifnot(is.remote(remote)) 3520 3521 package_name <- remote_package_name(remote) 3522 local_sha <- local_sha(package_name) 3523 remote_sha <- remote_sha(remote, local_sha) 3524 3525 if (!isTRUE(force) && 3526 !different_sha(remote_sha = remote_sha, local_sha = local_sha)) { 3527 3528 if (!quiet) { 3529 message( 3530 "Skipping install of '", package_name, "' from a ", sub("_remote", "", class(remote)[1L]), " remote,", 3531 " the SHA1 (", substr(remote_sha, 1L, 8L), ") has not changed since last install.\n", 3532 " Use `force = TRUE` to force installation") 3533 } 3534 return(invisible(package_name)) 3535 } 3536 3537 if (inherits(remote, "cran_remote")) { 3538 install_packages( 3539 package_name, repos = remote$repos, type = remote$pkg_type, 3540 dependencies = dependencies, 3541 quiet = quiet, 3542 ...) 3543 return(invisible(package_name)) 3544 } 3545 3546 res <- try(bundle <- remote_download(remote, quiet = quiet), silent = quiet) 3547 if (inherits(res, "try-error")) { 3548 return(NA_character_) 3549 } 3550 3551 on.exit(unlink(bundle), add = TRUE) 3552 3553 source <- source_pkg(bundle, subdir = remote$subdir) 3554 on.exit(unlink(source, recursive = TRUE), add = TRUE) 3555 3556 update_submodules(source, remote$subdir, quiet) 3557 3558 add_metadata(source, remote_metadata(remote, bundle, source, remote_sha)) 3559 3560 # Because we've modified DESCRIPTION, its original MD5 value is wrong 3561 clear_description_md5(source) 3562 3563 install(source, 3564 dependencies = dependencies, 3565 upgrade = upgrade, 3566 force = force, 3567 quiet = quiet, 3568 build = build, 3569 build_opts = build_opts, 3570 build_manual = build_manual, 3571 build_vignettes = build_vignettes, 3572 repos = repos, 3573 type = type, 3574 ...) 3575 } 3576 3577 install_remotes <- function(remotes, ...) { 3578 res <- character(length(remotes)) 3579 for (i in seq_along(remotes)) { 3580 tryCatch( 3581 res[[i]] <- install_remote(remotes[[i]], ...), 3582 error = function(e) { 3583 stop(remote_install_error(remotes[[i]], e)) 3584 }) 3585 } 3586 invisible(res) 3587 } 3588 3589 remote_install_error <- function(remote, error) { 3590 msg <- sprintf( 3591 "Failed to install '%s' from %s:\n %s", remote_name_or_unknown(remote), format(remote), conditionMessage(error) 3592 ) 3593 3594 structure(list(message = msg, call = NULL, error = error, remote = remote), class = c("install_error", "error", "condition")) 3595 } 3596 3597 remote_name_or_unknown <- function(remote) { 3598 res <- tryCatch( 3599 res <- remote_package_name(remote), 3600 error = function(e) NA_character_) 3601 3602 if (is.na(res)) { 3603 return("unknown package") 3604 } 3605 3606 res 3607 } 3608 3609 #' @rdname install_remote 3610 #' @export 3611 #' @keywords internal 3612 add_metadata <- function(pkg_path, meta) { 3613 3614 # During installation, the DESCRIPTION file is read and an package.rds file 3615 # created with most of the information from the DESCRIPTION file. Functions 3616 # that read package metadata may use either the DESCRIPTION file or the 3617 # package.rds file, therefore we attempt to modify both of them 3618 source_desc <- file.path(pkg_path, "DESCRIPTION") 3619 binary_desc <- file.path(pkg_path, "Meta", "package.rds") 3620 if (file.exists(source_desc)) { 3621 desc <- read_dcf(source_desc) 3622 3623 desc <- utils::modifyList(desc, meta) 3624 3625 write_dcf(source_desc, desc) 3626 } 3627 3628 if (file.exists(binary_desc)) { 3629 pkg_desc <- base::readRDS(binary_desc) 3630 desc <- as.list(pkg_desc$DESCRIPTION) 3631 desc <- utils::modifyList(desc, meta) 3632 pkg_desc$DESCRIPTION <- stats::setNames(as.character(desc), names(desc)) 3633 base::saveRDS(pkg_desc, binary_desc) 3634 } 3635 } 3636 3637 # Modify the MD5 file - remove the line for DESCRIPTION 3638 clear_description_md5 <- function(pkg_path) { 3639 path <- file.path(pkg_path, "MD5") 3640 3641 if (file.exists(path)) { 3642 text <- readLines(path) 3643 text <- text[!grepl(".*\\*DESCRIPTION$", text)] 3644 3645 writeLines(text, path) 3646 } 3647 } 3648 3649 remote <- function(type, ...) { 3650 structure(list(...), class = c(paste0(type, "_remote"), "remote")) 3651 } 3652 3653 is.remote <- function(x) inherits(x, "remote") 3654 3655 #' @rdname install_remote 3656 #' @keywords internal 3657 #' @export 3658 remote_download <- function(x, quiet = FALSE) UseMethod("remote_download") 3659 3660 #' @rdname install_remote 3661 #' @keywords internal 3662 #' @export 3663 remote_metadata <- function(x, bundle = NULL, source = NULL, sha = NULL) UseMethod("remote_metadata") 3664 3665 #' @rdname install_remote 3666 #' @keywords internal 3667 #' @export 3668 remote_package_name <- function(remote, ...) UseMethod("remote_package_name") 3669 3670 #' @rdname install_remote 3671 #' @keywords internal 3672 #' @export 3673 remote_sha <- function(remote, ...) UseMethod("remote_sha") 3674 3675 remote_package_name.default <- function(remote, ...) remote$repo 3676 remote_sha.default <- function(remote, ...) NA_character_ 3677 3678 different_sha <- function(remote_sha, local_sha) { 3679 3680 same <- remote_sha == local_sha 3681 same <- isTRUE(same) && !is.na(same) 3682 !same 3683 } 3684 3685 local_sha <- function(name) { 3686 package2remote(name)$sha %||% NA_character_ 3687 } 3688 3689 # Convert an installed package to its equivalent remote. This constructs the 3690 # remote from metadata stored in the package's DESCRIPTION file; the metadata 3691 # is added to the package when it is installed by remotes. If the package is 3692 # installed some other way, such as by `install.packages()` there will be no 3693 # meta-data, so there we construct a generic CRAN remote. 3694 package2remote <- function(name, lib = .libPaths(), repos = getOption("repos"), type = getOption("pkgType")) { 3695 3696 x <- tryCatch(utils::packageDescription(name, lib.loc = lib), error = function(e) NA, warning = function(e) NA) 3697 3698 # will be NA if not installed 3699 if (identical(x, NA)) { 3700 return(remote("cran", 3701 name = name, 3702 repos = repos, 3703 pkg_type = type, 3704 sha = NA_character_)) 3705 } 3706 3707 if (is.null(x$RemoteType) || x$RemoteType == "cran") { 3708 3709 # Packages installed with install.packages() or locally without remotes 3710 return(remote("cran", 3711 name = x$Package, 3712 repos = repos, 3713 pkg_type = type, 3714 sha = x$Version)) 3715 } 3716 3717 switch(x$RemoteType, 3718 standard = remote("cran", 3719 name = x$Package, 3720 repos = x$RemoteRepos %||% repos, 3721 pkg_type = x$RemotePkgType %||% type, 3722 sha = x$RemoteSha), 3723 github = remote("github", 3724 host = x$RemoteHost, 3725 package = x$RemotePackage, 3726 repo = x$RemoteRepo, 3727 subdir = x$RemoteSubdir, 3728 username = x$RemoteUsername, 3729 ref = x$RemoteRef, 3730 sha = x$RemoteSha, 3731 auth_token = github_pat()), 3732 gitlab = remote("gitlab", 3733 host = x$RemoteHost, 3734 repo = x$RemoteRepo, 3735 subdir = x$RemoteSubdir, 3736 username = x$RemoteUsername, 3737 ref = x$RemoteRef, 3738 sha = x$RemoteSha, 3739 auth_token = gitlab_pat()), 3740 xgit = remote("xgit", 3741 url = trim_ws(x$RemoteUrl), 3742 ref = x$RemoteRef %||% x$RemoteBranch, 3743 sha = x$RemoteSha, 3744 subdir = x$RemoteSubdir, 3745 args = x$RemoteArgs), 3746 git2r = remote("git2r", 3747 url = trim_ws(x$RemoteUrl), 3748 ref = x$RemoteRef %||% x$RemoteBranch, 3749 sha = x$RemoteSha, 3750 subdir = x$RemoteSubdir, 3751 credentials = git_credentials()), 3752 bitbucket = remote("bitbucket", 3753 host = x$RemoteHost, 3754 repo = x$RemoteRepo, 3755 username = x$RemoteUsername, 3756 ref = x$RemoteRef, 3757 sha = x$RemoteSha, 3758 subdir = x$RemoteSubdir, 3759 auth_user = bitbucket_user(), 3760 password = bitbucket_password()), 3761 svn = remote("svn", 3762 url = trim_ws(x$RemoteUrl), 3763 svn_subdir = x$RemoteSubdir, 3764 revision = x$RemoteSha, 3765 args = x$RemoteArgs), 3766 local = remote("local", 3767 path = { 3768 path <- trim_ws(x$RemoteUrl) 3769 if (length(path) == 0) { 3770 path <- parse_pkg_ref(x$RemotePkgRef)$ref 3771 } 3772 path 3773 }, 3774 subdir = x$RemoteSubdir, 3775 sha = { 3776 # Packages installed locally might have RemoteSha == NA_character_ 3777 x$RemoteSha %||% x$Version 3778 }), 3779 url = remote("url", 3780 url = trim_ws(x$RemoteUrl), 3781 subdir = x$RemoteSubdir, 3782 config = x$RemoteConfig, 3783 pkg_type = x$RemotePkgType %||% type), 3784 bioc_git2r = remote("bioc_git2r", 3785 mirror = x$RemoteMirror, 3786 repo = x$RemoteRepo, 3787 release = x$RemoteRelease, 3788 sha = x$RemoteSha, 3789 branch = x$RemoteBranch), 3790 bioc_xgit = remote("bioc_xgit", 3791 mirror = x$RemoteMirror, 3792 repo = x$RemoteRepo, 3793 release = x$RemoteRelease, 3794 sha = x$RemoteSha, 3795 branch = x$RemoteBranch), 3796 stop(sprintf("can't convert package %s with RemoteType '%s' to remote", name, x$RemoteType)) 3797 ) 3798 } 3799 3800 parse_pkg_ref <- function(x) { 3801 res <- re_match(x, "(?<type>[^:]+)::(?<ref>.*)") 3802 if (is.na(res$ref)) { 3803 stop("Invalid package reference:\n ", x, call. = FALSE) 3804 } 3805 res 3806 } 3807 3808 #' @export 3809 format.remotes <- function(x, ...) { 3810 vapply(x, format, character(1)) 3811 } 3812 # Contents of R/install-svn.R 3813 3814 #' Install a package from a SVN repository 3815 #' 3816 #' This function requires \command{svn} to be installed on your system in order to 3817 #' be used. 3818 #' 3819 #' It is vectorised so you can install multiple packages with 3820 #' a single command. 3821 #' 3822 #' @inheritParams install_git 3823 #' @param subdir A sub-directory within a svn repository that contains the 3824 #' package we are interested in installing. 3825 #' @param args A character vector providing extra options to pass on to 3826 #' \command{svn}. 3827 #' @param revision svn revision, if omitted updates to latest 3828 #' @param ... Other arguments passed on to [utils::install.packages()]. 3829 #' @inheritParams install_github 3830 #' @family package installation 3831 #' @export 3832 #' 3833 #' @examples 3834 #' \dontrun{ 3835 #' install_svn("https://github.com/hadley/stringr/trunk") 3836 #' install_svn("https://github.com/hadley/httr/branches/oauth") 3837 #'} 3838 install_svn <- function(url, subdir = NULL, args = character(0), 3839 revision = NULL, 3840 dependencies = NA, 3841 upgrade = c("default", "ask", "always", "never"), 3842 force = FALSE, 3843 quiet = FALSE, 3844 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 3845 build_manual = FALSE, build_vignettes = FALSE, 3846 repos = getOption("repos"), 3847 type = getOption("pkgType"), 3848 ...) { 3849 3850 remotes <- lapply(url, svn_remote, svn_subdir = subdir, 3851 revision = revision, args = args) 3852 3853 install_remotes(remotes, args = args, 3854 dependencies = dependencies, 3855 upgrade = upgrade, 3856 force = force, 3857 quiet = quiet, 3858 build = build, 3859 build_opts = build_opts, 3860 build_manual = build_manual, 3861 build_vignettes = build_vignettes, 3862 repos = repos, 3863 type = type, 3864 ...) 3865 } 3866 3867 svn_remote <- function(url, svn_subdir = NULL, revision = NULL, 3868 args = character(0), ...) { 3869 remote("svn", 3870 url = url, 3871 svn_subdir = svn_subdir, 3872 revision = revision, 3873 args = args 3874 ) 3875 } 3876 3877 #' @export 3878 remote_download.svn_remote <- function(x, quiet = FALSE) { 3879 if (!quiet) { 3880 message("Downloading svn repo ", x$url) 3881 } 3882 3883 bundle <- tempfile() 3884 svn_binary_path <- svn_path() 3885 url <- x$url 3886 3887 args <- "co" 3888 if (!is.null(x$revision)) { 3889 args <- c(args, "-r", x$revision) 3890 } 3891 args <- c(args, x$args, full_svn_url(x), bundle) 3892 3893 if (!quiet) { message(shQuote(svn_binary_path), " ", paste0(args, collapse = " ")) } 3894 request <- system2(svn_binary_path, args, stdout = FALSE, stderr = FALSE) 3895 3896 # This is only looking for an error code above 0-success 3897 if (request > 0) { 3898 stop("There seems to be a problem retrieving this SVN-URL.", call. = FALSE) 3899 } 3900 3901 in_dir(bundle, { 3902 if (!is.null(x$revision)) { 3903 request <- system2(svn_binary_path, paste("update -r", x$revision), stdout = FALSE, stderr = FALSE) 3904 if (request > 0) { 3905 stop("There was a problem switching to the requested SVN revision", call. = FALSE) 3906 } 3907 } 3908 }) 3909 bundle 3910 } 3911 3912 #' @export 3913 remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 3914 3915 if (!is.null(bundle)) { 3916 in_dir(bundle, { 3917 revision <- svn_revision() 3918 }) 3919 } else { 3920 revision <- sha 3921 } 3922 3923 list( 3924 RemoteType = "svn", 3925 RemoteUrl = x$url, 3926 RemoteSubdir = x$svn_subdir, 3927 RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " "), 3928 RemoteSha = revision # for compatibility with other remotes 3929 ) 3930 } 3931 3932 svn_path <- function(svn_binary_name = NULL) { 3933 # Use user supplied path 3934 if (!is.null(svn_binary_name)) { 3935 if (!file.exists(svn_binary_name)) { 3936 stop("Path ", svn_binary_name, " does not exist", .call = FALSE) 3937 } 3938 return(svn_binary_name) 3939 } 3940 3941 # Look on path 3942 svn_path <- Sys.which("svn")[[1]] 3943 if (svn_path != "") return(svn_path) 3944 3945 # On Windows, look in common locations 3946 if (os_type() == "windows") { 3947 look_in <- c( 3948 "C:/Program Files/Svn/bin/svn.exe", 3949 "C:/Program Files (x86)/Svn/bin/svn.exe" 3950 ) 3951 found <- file.exists(look_in) 3952 if (any(found)) return(look_in[found][1]) 3953 } 3954 3955 stop("SVN does not seem to be installed on your system.", call. = FALSE) 3956 } 3957 3958 #' @export 3959 remote_package_name.svn_remote <- function(remote, ...) { 3960 description_url <- file.path(full_svn_url(remote), "DESCRIPTION") 3961 tmp_file <- tempfile() 3962 on.exit(rm(tmp_file)) 3963 response <- system2(svn_path(), paste("cat", description_url), stdout = tmp_file) 3964 if (!identical(response, 0L)) { 3965 return(NA_character_) 3966 } 3967 read_dcf(tmp_file)$Package 3968 } 3969 3970 #' @export 3971 remote_sha.svn_remote <- function(remote, ...) { 3972 svn_revision(full_svn_url(remote)) 3973 } 3974 3975 svn_revision <- function(url = NULL, svn_binary_path = svn_path()) { 3976 request <- system2(svn_binary_path, paste("info --xml", url), stdout = TRUE) 3977 if (!is.null(attr(request, "status")) && !identical(attr(request, "status"), 0L)) { 3978 stop("There was a problem retrieving the current SVN revision", call. = FALSE) 3979 } 3980 gsub(".*<commit[[:space:]]+revision=\"([[:digit:]]+)\">.*", "\\1", paste(collapse = "\n", request)) 3981 } 3982 3983 full_svn_url <- function(x) { 3984 url <- x$url 3985 if (!is.null(x$svn_subdir)) { 3986 url <- file.path(url, x$svn_subdir) 3987 } 3988 3989 url 3990 } 3991 3992 format.svn_remote <- function(x, ...) { 3993 "SVN" 3994 } 3995 # Contents of R/install-url.R 3996 3997 #' Install a package from a url 3998 #' 3999 #' This function is vectorised so you can install multiple packages in 4000 #' a single command. 4001 #' 4002 #' @param url location of package on internet. The url should point to a 4003 #' zip file, a tar file or a bzipped/gzipped tar file. 4004 #' @param subdir subdirectory within url bundle that contains the R package. 4005 #' @param ... Other arguments passed on to [utils::install.packages()]. 4006 #' @inheritParams install_github 4007 #' @export 4008 #' 4009 #' @family package installation 4010 #' @examples 4011 #' \dontrun{ 4012 #' install_url("https://github.com/hadley/stringr/archive/HEAD.zip") 4013 #' } 4014 4015 install_url <- function(url, subdir = NULL, 4016 dependencies = NA, 4017 upgrade = c("default", "ask", "always", "never"), 4018 force = FALSE, 4019 quiet = FALSE, 4020 build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 4021 build_manual = FALSE, build_vignettes = FALSE, 4022 repos = getOption("repos"), 4023 type = getOption("pkgType"), 4024 ...) { 4025 remotes <- lapply(url, url_remote, subdir = subdir) 4026 install_remotes(remotes, 4027 dependencies = dependencies, 4028 upgrade = upgrade, 4029 force = force, 4030 quiet = quiet, 4031 build = build, 4032 build_opts = build_opts, 4033 build_manual = build_manual, 4034 build_vignettes = build_vignettes, 4035 repos = repos, 4036 type = type, 4037 ...) 4038 } 4039 4040 url_remote <- function(url, subdir = NULL, ...) { 4041 remote("url", 4042 url = url, 4043 subdir = subdir 4044 ) 4045 } 4046 4047 #' @importFrom tools file_ext 4048 #' @export 4049 remote_download.url_remote <- function(x, quiet = FALSE) { 4050 if (!quiet) { 4051 message("Downloading package from url: ", x$url) # nocov 4052 } 4053 4054 ext <- if (grepl("\\.tar\\.gz$", x$url)) "tar.gz" else file_ext(x$url) 4055 4056 bundle <- tempfile(fileext = paste0(".", ext)) 4057 download(bundle, x$url) 4058 } 4059 4060 #' @export 4061 remote_metadata.url_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) { 4062 list( 4063 RemoteType = "url", 4064 RemoteUrl = x$url, 4065 RemoteSubdir = x$subdir 4066 ) 4067 } 4068 4069 #' @export 4070 remote_package_name.url_remote <- function(remote, ...) { 4071 NA_character_ 4072 } 4073 4074 #' @export 4075 remote_sha.url_remote <- function(remote, ...) { 4076 NA_character_ 4077 } 4078 4079 #' @export 4080 format.url_remote <- function(x, ...) { 4081 "URL" 4082 } 4083 # Contents of R/install-version.R 4084 4085 #' Install specific version of a package. 4086 #' 4087 #' This function knows how to look in multiple CRAN-like package repositories, and in their 4088 #' \code{archive} directories, in order to find specific versions of the requested package. 4089 #' 4090 #' The repositories are searched in the order specified by the \code{repos} argument. This enables 4091 #' teams to maintain multiple in-house repositories with different policies - for instance, one repo 4092 #' for development snapshots and one for official releases. A common setup would be to first search 4093 #' the official release repo, then the dev snapshot repo, then a public CRAN mirror. 4094 #' 4095 #' Older versions of packages on CRAN are usually only available in source form. If your requested 4096 #' package contains compiled code, you will need to have an R development environment installed. You 4097 #' can check if you do by running `devtools::has_devel` (you need the `devtools` package for this). 4098 #' 4099 #' @export 4100 #' @family package installation 4101 #' @param package Name of the package to install. 4102 #' @param version Version of the package to install. Can either be a string giving the exact 4103 #' version required, or a specification in the same format as the parenthesized expressions used 4104 #' in package dependencies. One of the following formats: 4105 #' - An exact version required, as a string, e.g. `"0.1.13"` 4106 #' - A comparison operator and a version, e.g. `">= 0.1.12"` 4107 #' - Several criteria to satisfy, as a comma-separated string, e.g. `">= 1.12.0, < 1.14"` 4108 #' - Several criteria to satisfy, as elements of a character vector, e.g. `c(">= 1.12.0", "< 1.14")` 4109 #' @param ... Other arguments passed on to [utils::install.packages()]. 4110 #' @inheritParams utils::install.packages 4111 #' @inheritParams install_github 4112 #' @examples 4113 #' \dontrun{ 4114 #' install_version("devtools", "1.11.0") 4115 #' install_version("devtools", ">= 1.12.0, < 1.14") 4116 #' 4117 #' ## Specify search order (e.g. in ~/.Rprofile) 4118 #' options(repos = c( 4119 #' prod = "http://mycompany.example.com/r-repo", 4120 #' dev = "http://mycompany.example.com/r-repo-dev", 4121 #' CRAN = "https://cran.revolutionanalytics.com" 4122 #' )) 4123 #' install_version("mypackage", "1.15") # finds in 'prod' 4124 #' install_version("mypackage", "1.16-39487") # finds in 'dev' 4125 #' } 4126 #' @importFrom utils available.packages contrib.url install.packages 4127 4128 install_version <- function(package, version = NULL, 4129 dependencies = NA, 4130 upgrade = c("default", "ask", "always", "never"), 4131 force = FALSE, 4132 quiet = FALSE, 4133 build = FALSE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 4134 build_manual = FALSE, build_vignettes = FALSE, 4135 repos = getOption("repos"), 4136 type = "source", 4137 ...) { 4138 4139 # TODO would it make sense to vectorize this, e.g. `install_version(c("foo", "bar"), c("1.1", "2.2"))`? 4140 if (length(package) < 1) { 4141 return() 4142 } 4143 if (length(package) > 1) { 4144 stop("install_version() must be called with a single 'package' argument - multiple packages given") 4145 } 4146 4147 if (!identical(type, "source")) { 4148 stop("`type` must be 'source' for `install_version()`", call. = FALSE) 4149 } 4150 4151 url <- download_version_url(package, version, repos, type) 4152 res <- install_url(url, 4153 dependencies = dependencies, 4154 upgrade = upgrade, 4155 force = force, 4156 quiet = quiet, 4157 build = build, 4158 build_opts = build_opts, 4159 build_manual = build_manual, 4160 build_vignettes = build_vignettes, 4161 repos = repos, 4162 type = type, 4163 ... 4164 ) 4165 4166 lib <- list(...)$lib %||% .libPaths() 4167 4168 # Remove Metadata from installed package 4169 add_metadata( 4170 system.file(package = package, lib.loc = lib), 4171 list(RemoteType = NULL, RemoteUrl = NULL, RemoteSubdir = NULL) 4172 ) 4173 4174 invisible(res) 4175 } 4176 4177 version_from_tarball <- function(tarball_name) { 4178 package_ver_regex <- paste0(".+_(", .standard_regexps()$valid_package_version, ")\\.tar\\.gz$") 4179 ifelse(grepl(package_ver_regex, tarball_name), sub(package_ver_regex, "\\1", tarball_name), NULL) 4180 } 4181 4182 version_satisfies_criteria <- function(to_check, criteria) { 4183 to_check <- package_version(to_check) 4184 result <- apply(version_criteria(criteria), 1, function(r) { 4185 if (is.na(r["compare"])) { 4186 TRUE 4187 } else { 4188 get(r["compare"], mode = "function")(to_check, r["version"]) 4189 } 4190 }) 4191 all(result) 4192 } 4193 4194 package_installed <- function(pkg, criteria) { 4195 v <- suppressWarnings(utils::packageDescription(pkg, fields = "Version")) 4196 !is.na(v) && version_satisfies_criteria(v, criteria) 4197 } 4198 4199 version_criteria <- function(criteria) { 4200 if (is.character(criteria) && length(criteria) == 1) { 4201 criteria <- strsplit(criteria, ",")[[1]] 4202 } 4203 4204 numeric_ver <- .standard_regexps()$valid_numeric_version 4205 4206 package <- "p" # dummy package name, required by parse_deps() 4207 4208 spec <- if (is.null(criteria) || (length(criteria) == 1 && is.na(criteria[[1L]]))) { 4209 package 4210 } else { 4211 ifelse(grepl(paste0("^", numeric_ver, "$"), criteria), 4212 paste0(package, "(== ", criteria, ")"), 4213 paste0(package, "(", criteria, ")") 4214 ) 4215 } 4216 4217 parse_deps(paste(spec, collapse = ", "))[c("compare", "version")] 4218 } 4219 4220 # Find a given package record in the `archive.rds` file of a repository 4221 package_find_archives <- function(package, repo, verbose = FALSE) { 4222 if (verbose) { 4223 message("Trying ", repo) 4224 } 4225 4226 # TODO it would be nice to cache these downloaded files like `available.packages` does 4227 archive <- 4228 tryCatch( 4229 { 4230 tf <- tempfile(fileext = ".gz") 4231 on.exit(unlink(tf), add = TRUE) 4232 download(tf, sprintf("%s/src/contrib/Meta/archive.rds", repo)) 4233 con <- gzfile(tf, "rb") 4234 on.exit(close(con), add = TRUE) 4235 readRDS(con) 4236 }, 4237 warning = function(e) list(), 4238 error = function(e) list() 4239 ) 4240 4241 info <- archive[[package]] 4242 if (!is.null(info)) { 4243 info$repo <- repo 4244 return(info) 4245 } 4246 4247 NULL 4248 } 4249 4250 4251 #' Download a specified version of a CRAN package 4252 #' 4253 #' It downloads the package to a temporary file, and 4254 #' returns the name of the file. 4255 #' 4256 #' @inheritParams install_version 4257 #' @return Name of the downloaded file. 4258 #' 4259 #' @export 4260 4261 download_version <- function(package, version = NULL, 4262 repos = getOption("repos"), 4263 type = getOption("pkgType"), ...) { 4264 url <- download_version_url(package, version, repos, type) 4265 download(path = tempfile(), url = url) 4266 } 4267 4268 download_version_url <- function(package, version, repos, type, available, verbose = length(repos) > 1) { 4269 4270 ## TODO should we do for(r in repos) { for (t in c('published','archive')) {...}}, or 4271 ## for (t in c('published','archive')) { for(r in repos) {...}} ? Right now it's the latter. It 4272 ## only matters if required version is satisfied by both an early repo in archive/ and a late repo 4273 4274 if (missing(available)) { 4275 contriburl <- contrib.url(repos, type) 4276 available <- available.packages(contriburl, filters = c("R_version", "OS_type", "subarch")) 4277 } 4278 4279 package_exists <- FALSE 4280 4281 # available.packages() returns a matrix with entries in the same order as the repositories in 4282 # `repos`, so the first packages we encounter should be preferred. 4283 for (ix in which(available[, "Package"] == package)) { 4284 package_exists <- TRUE 4285 row <- available[ix, ] 4286 if (version_satisfies_criteria(row["Version"], version)) { 4287 return(paste0( 4288 row["Repository"], 4289 "/", 4290 row["Package"], 4291 "_", 4292 row["Version"], 4293 ".tar.gz" 4294 )) 4295 } 4296 } 4297 4298 for (repo in repos) { 4299 info <- package_find_archives(package, repo, verbose = verbose) 4300 if (is.null(info)) { 4301 next 4302 } 4303 4304 package_exists <- TRUE 4305 4306 for (i in rev(seq_len(nrow(info)))) { 4307 package_path <- row.names(info)[i] 4308 if (version_satisfies_criteria(version_from_tarball(package_path), version)) { 4309 return(file.path(repo, "src", "contrib", "Archive", package_path)) 4310 } 4311 } 4312 } 4313 4314 if (!package_exists) { 4315 stop(sprintf("couldn't find package '%s'", package)) 4316 } 4317 4318 stop(sprintf("version '%s' is invalid for package '%s'", version, package)) 4319 } 4320 # Contents of R/install.R 4321 install <- function(pkgdir, dependencies, quiet, build, build_opts, build_manual, build_vignettes, 4322 upgrade, repos, type, ...) { 4323 warn_for_potential_errors() 4324 4325 if (file.exists(file.path(pkgdir, "src"))) { 4326 if (!is_standalone() && has_package("pkgbuild")) { 4327 pkgbuild::local_build_tools(required = TRUE) 4328 } else if (!has_devel()) { 4329 missing_devel_warning(pkgdir) 4330 } 4331 } 4332 4333 pkg_name <- load_pkg_description(pkgdir)$package 4334 4335 ## Check for circular dependencies. We need to know about the root 4336 ## of the install process. 4337 if (is_root_install()) on.exit(exit_from_root_install(), add = TRUE) 4338 if (check_for_circular_dependencies(pkgdir, quiet)) { 4339 return(invisible(pkg_name)) 4340 } 4341 4342 install_deps(pkgdir, dependencies = dependencies, quiet = quiet, 4343 build = build, build_opts = build_opts, build_manual = build_manual, 4344 build_vignettes = build_vignettes, upgrade = upgrade, repos = repos, 4345 type = type, ...) 4346 4347 if (isTRUE(build)) { 4348 dir <- tempfile() 4349 dir.create(dir) 4350 on.exit(unlink(dir), add = TRUE) 4351 4352 pkgdir <- safe_build_package(pkgdir, build_opts, build_manual, build_vignettes, dir, quiet) 4353 } 4354 4355 safe_install_packages( 4356 pkgdir, 4357 repos = NULL, 4358 quiet = quiet, 4359 type = "source", 4360 ... 4361 ) 4362 4363 invisible(pkg_name) 4364 } 4365 4366 4367 safe_install_packages <- function(...) { 4368 4369 lib <- paste(.libPaths(), collapse = .Platform$path.sep) 4370 4371 if (!is_standalone() && 4372 has_package("crancache") && has_package("callr")) { 4373 i.p <- "crancache" %::% "install_packages" 4374 } else { 4375 i.p <- utils::install.packages 4376 } 4377 4378 with_options(list(install.lock = getOption("install.lock", TRUE)), { 4379 with_envvar( 4380 c(R_LIBS = lib, 4381 R_LIBS_USER = lib, 4382 R_LIBS_SITE = lib, 4383 RGL_USE_NULL = "TRUE"), 4384 4385 # Set options(warn = 2) for this process and child processes, so that 4386 # warnings from `install.packages()` are converted to errors. 4387 if (should_error_for_warnings()) { 4388 with_options(list(warn = 2), 4389 with_rprofile_user("options(warn = 2)", 4390 i.p(...) 4391 ) 4392 ) 4393 } else { 4394 i.p(...) 4395 } 4396 ) 4397 }) 4398 } 4399 4400 normalize_build_opts <- function(build_opts, build_manual, build_vignettes) { 4401 if (!isTRUE(build_manual)) { 4402 build_opts <- union(build_opts, "--no-manual") 4403 } else { 4404 build_opts <- setdiff(build_opts, "--no-manual") 4405 } 4406 4407 if (!isTRUE(build_vignettes)) { 4408 build_opts <- union(build_opts, "--no-build-vignettes") 4409 } else { 4410 build_opts <- setdiff(build_opts, "--no-build-vignettes") 4411 } 4412 4413 build_opts 4414 } 4415 4416 safe_build_package <- function(pkgdir, build_opts, build_manual, build_vignettes, dest_path, quiet, use_pkgbuild = !is_standalone() && pkg_installed("pkgbuild")) { 4417 build_opts <- normalize_build_opts(build_opts, build_manual, build_vignettes) 4418 4419 if (use_pkgbuild) { 4420 vignettes <- TRUE 4421 manual <- FALSE 4422 has_no_vignettes <- grepl("--no-build-vignettes", build_opts) 4423 if (any(has_no_vignettes)) { 4424 vignettes <- FALSE 4425 } 4426 has_no_manual <- grepl("--no-manual", build_opts) 4427 if (!any(has_no_manual)) { 4428 manual <- TRUE 4429 } 4430 build_opts <- build_opts[!(has_no_vignettes | has_no_manual)] 4431 pkgbuild::build(pkgdir, dest_path = dest_path, binary = FALSE, 4432 vignettes = vignettes, manual = manual, args = build_opts, quiet = quiet) 4433 } else { 4434 # No pkgbuild, so we need to call R CMD build ourselves 4435 4436 lib <- paste(.libPaths(), collapse = .Platform$path.sep) 4437 env <- c(R_LIBS = lib, 4438 R_LIBS_USER = lib, 4439 R_LIBS_SITE = lib, 4440 R_PROFILE_USER = tempfile()) 4441 4442 pkgdir <- normalizePath(pkgdir) 4443 4444 message("Running `R CMD build`...") 4445 in_dir(dest_path, { 4446 with_envvar(env, { 4447 output <- rcmd("build", c(build_opts, shQuote(pkgdir)), quiet = quiet, 4448 fail_on_status = FALSE) 4449 }) 4450 }) 4451 4452 if (output$status != 0) { 4453 cat("STDOUT:\n") 4454 cat(output$stdout, sep = "\n") 4455 cat("STDERR:\n") 4456 cat(output$stderr, sep = "\n") 4457 msg_for_long_paths(output) 4458 stop(sprintf("Failed to `R CMD build` package, try `build = FALSE`."), 4459 call. = FALSE) 4460 } 4461 4462 building_regex <- paste0( 4463 "^[*] building[^[:alnum:]]+", # prefix, "* building '" 4464 "([-[:alnum:]_.]+)", # package file name, e.g. xy_1.0-2.tar.gz 4465 "[^[:alnum:]]+$" # trailing quote 4466 ) 4467 4468 pkgfile <- sub(building_regex, "\\1", output$stdout[length(output$stdout)]) 4469 file.path(dest_path, pkgfile) 4470 } 4471 } 4472 4473 msg_for_long_paths <- function(output) { 4474 if (sys_type() == "windows" && 4475 (r_error_matches("over-long path", output$stderr) || 4476 r_error_matches("over-long path length", output$stderr))) { 4477 message( 4478 "\nIt seems that this package contains files with very long paths.\n", 4479 "This is not supported on most Windows versions. Please contact the\n", 4480 "package authors and tell them about this. See this GitHub issue\n", 4481 "for more details: https://github.com/r-lib/remotes/issues/84\n") 4482 } 4483 } 4484 4485 r_error_matches <- function(msg, str) { 4486 any(grepl(msg, str)) || 4487 any(grepl(gettext(msg, domain = "R"), str)) 4488 } 4489 4490 #' Install package dependencies if needed. 4491 #' 4492 #' @inheritParams package_deps 4493 #' @param ... additional arguments passed to [utils::install.packages()]. 4494 #' @param build If `TRUE` build the package before installing. 4495 #' @param build_opts Options to pass to `R CMD build`, only used when `build` is `TRUE`. 4496 #' @param build_manual If `FALSE`, don't build PDF manual ('--no-manual'). 4497 #' @param build_vignettes If `FALSE`, don't build package vignettes ('--no-build-vignettes'). 4498 #' @export 4499 #' @examples 4500 #' \dontrun{install_deps(".")} 4501 4502 install_deps <- function(pkgdir = ".", dependencies = NA, 4503 repos = getOption("repos"), 4504 type = getOption("pkgType"), 4505 upgrade = c("default", "ask", "always", "never"), 4506 quiet = FALSE, 4507 build = TRUE, 4508 build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"), 4509 build_manual = FALSE, build_vignettes = FALSE, 4510 ...) { 4511 packages <- dev_package_deps( 4512 pkgdir, 4513 repos = repos, 4514 dependencies = dependencies, 4515 type = type 4516 ) 4517 4518 dep_deps <- if (isTRUE(dependencies)) NA else dependencies 4519 4520 update( 4521 packages, 4522 dependencies = dep_deps, 4523 quiet = quiet, 4524 upgrade = upgrade, 4525 build = build, 4526 build_opts = build_opts, 4527 build_manual = build_manual, 4528 build_vignettes = build_vignettes, 4529 type = type, 4530 repos = repos, 4531 ... 4532 ) 4533 } 4534 4535 should_error_for_warnings <- function() { 4536 4537 no_errors <- Sys.getenv("R_REMOTES_NO_ERRORS_FROM_WARNINGS", "true") 4538 4539 !config_val_to_logical(no_errors) 4540 } 4541 # Contents of R/json.R 4542 4543 # Standalone JSON parser 4544 # 4545 # The purpose of this file is to provide a standalone JSON parser. 4546 # It is quite slow and bare. If you need a proper parser please use the 4547 # jsonlite package. 4548 # 4549 # The canonical location of this file is in the remotes package: 4550 # https://github.com/r-lib/remotes/blob/HEAD/R/json.R 4551 # 4552 # API: 4553 # parse(text) 4554 # parse_file(filename) 4555 # 4556 # NEWS: 4557 # - 2019/05/15 First standalone version 4558 4559 json <- local({ 4560 4561 tokenize_json <- function(text) { 4562 text <- paste(text, collapse = "\n") 4563 4564 ESCAPE <- '(\\\\[^u[:cntrl:]]|\\\\u[0-9a-fA-F]{4})' 4565 CHAR <- '[^[:cntrl:]"\\\\]' 4566 4567 STRING <- paste0('"', CHAR, '*(', ESCAPE, CHAR, '*)*"') 4568 NUMBER <- "-?(0|[1-9][0-9]*)([.][0-9]*)?([eE][+-]?[0-9]*)?" 4569 KEYWORD <- 'null|false|true' 4570 SPACE <- '[[:space:]]+' 4571 4572 match <- gregexpr( 4573 pattern = paste0( 4574 STRING, "|", NUMBER, "|", KEYWORD, "|", SPACE, "|", "." 4575 ), 4576 text = text, 4577 perl = TRUE 4578 ) 4579 4580 grep("^\\s+$", regmatches(text, match)[[1]], value = TRUE, invert = TRUE) 4581 } 4582 4583 throw <- function(...) { 4584 stop("JSON: ", ..., call. = FALSE) 4585 } 4586 4587 # Parse a JSON file 4588 # 4589 # @param filename Path to the JSON file. 4590 # @return R objects corresponding to the JSON file. 4591 4592 parse_file <- function(filename) { 4593 parse(readLines(filename, warn = FALSE)) 4594 } 4595 4596 # Parse a JSON string 4597 # 4598 # @param text JSON string. 4599 # @return R object corresponding to the JSON string. 4600 4601 parse <- function(text) { 4602 4603 tokens <- tokenize_json(text) 4604 token <- NULL 4605 ptr <- 1 4606 4607 read_token <- function() { 4608 if (ptr <= length(tokens)) { 4609 token <<- tokens[ptr] 4610 ptr <<- ptr + 1 4611 } else { 4612 token <<- 'EOF' 4613 } 4614 } 4615 4616 parse_value <- function(name = "") { 4617 if (token == "{") { 4618 parse_object() 4619 } else if (token == "[") { 4620 parse_array() 4621 } else if (token == "EOF" || (nchar(token) == 1 && ! token %in% 0:9)) { 4622 throw("EXPECTED value GOT ", token) 4623 } else { 4624 j2r(token) 4625 } 4626 } 4627 4628 parse_object <- function() { 4629 res <- structure(list(), names = character()) 4630 4631 read_token() 4632 4633 ## Invariant: we are at the beginning of an element 4634 while (token != "}") { 4635 4636 ## "key" 4637 if (grepl('^".*"$', token)) { 4638 key <- j2r(token) 4639 } else { 4640 throw("EXPECTED string GOT ", token) 4641 } 4642 4643 ## : 4644 read_token() 4645 if (token != ":") { throw("EXPECTED : GOT ", token) } 4646 4647 ## value 4648 read_token() 4649 res[key] <- list(parse_value()) 4650 4651 ## } or , 4652 read_token() 4653 if (token == "}") { 4654 break 4655 } else if (token != ",") { 4656 throw("EXPECTED , or } GOT ", token) 4657 } 4658 read_token() 4659 } 4660 4661 res 4662 } 4663 4664 parse_array <- function() { 4665 res <- list() 4666 4667 read_token() 4668 4669 ## Invariant: we are at the beginning of an element 4670 while (token != "]") { 4671 ## value 4672 res <- c(res, list(parse_value())) 4673 4674 ## ] or , 4675 read_token() 4676 if (token == "]") { 4677 break 4678 } else if (token != ",") { 4679 throw("EXPECTED , GOT ", token) 4680 } 4681 read_token() 4682 } 4683 4684 res 4685 } 4686 4687 read_token() 4688 parse_value(tokens) 4689 } 4690 4691 j2r <- function(token) { 4692 if (token == "null") { 4693 NULL 4694 } else if (token == "true") { 4695 TRUE 4696 } else if (token == "false") { 4697 FALSE 4698 } else if (grepl('^".*"$', token)) { 4699 trimq(token) 4700 } else { 4701 as.numeric(token) 4702 } 4703 } 4704 4705 trimq <- function(x) { 4706 sub('^"(.*)"$', "\\1", x) 4707 } 4708 4709 structure( 4710 list( 4711 .internal = environment(), 4712 parse = parse, 4713 parse_file = parse_file 4714 ), 4715 class = c("standalone_json", "standalone")) 4716 }) 4717 # Contents of R/package-deps.R 4718 4719 parse_deps <- function(string) { 4720 if (is.null(string)) return() 4721 stopifnot(is.character(string), length(string) == 1) 4722 if (grepl("^\\s*$", string)) return() 4723 4724 # Split by commas with surrounding whitespace removed 4725 pieces <- strsplit(string, "[[:space:]]*,[[:space:]]*")[[1]] 4726 4727 # Get the names 4728 names <- gsub("\\s*\\(.*?\\)", "", pieces) 4729 names <- gsub("^\\s+|\\s+$", "", names) 4730 4731 # Get the versions and comparison operators 4732 versions_str <- pieces 4733 have_version <- grepl("\\(.*\\)", versions_str) 4734 versions_str[!have_version] <- NA 4735 4736 compare <- sub(".*\\(\\s*(\\S+)\\s+.*\\s*\\).*", "\\1", versions_str) 4737 versions <- sub(".*\\(\\s*\\S+\\s+(\\S*)\\s*\\).*", "\\1", versions_str) 4738 4739 # Check that non-NA comparison operators are valid 4740 compare_nna <- compare[!is.na(compare)] 4741 compare_valid <- compare_nna %in% c(">", ">=", "==", "<=", "<") 4742 if(!all(compare_valid)) { 4743 stop("Invalid comparison operator in dependency: ", 4744 paste(compare_nna[!compare_valid], collapse = ", ")) 4745 } 4746 4747 deps <- data.frame(name = names, compare = compare, 4748 version = versions, stringsAsFactors = FALSE) 4749 4750 # Remove R dependency 4751 deps[names != "R", ] 4752 } 4753 # Contents of R/package.R 4754 4755 load_pkg_description <- function(path) { 4756 4757 path <- normalizePath(path) 4758 4759 if (!is_dir(path)) { 4760 dir <- tempfile() 4761 path_desc <- untar_description(path, dir = dir) 4762 on.exit(unlink(dir, recursive = TRUE)) 4763 4764 } else { 4765 path_desc <- file.path(path, "DESCRIPTION") 4766 } 4767 4768 desc <- read_dcf(path_desc) 4769 names(desc) <- tolower(names(desc)) 4770 desc$path <- path 4771 4772 desc 4773 } 4774 # Contents of R/parse-git.R 4775 #' Parse a remote git repo specification 4776 #' 4777 #' A remote repo can be specified in two ways: 4778 #' \describe{ 4779 #' \item{as a URL}{`parse_github_url()` handles HTTPS and SSH remote URLs 4780 #' and various GitHub browser URLs} 4781 #' \item{via a shorthand}{`parse_repo_spec()` handles this concise form: 4782 #' `[username/]repo[/subdir][#pull|@ref|@*release]`} 4783 #' } 4784 #' 4785 #' @param repo Character scalar, the repo specification. 4786 #' @return List with members: `username`, `repo`, `subdir` 4787 #' `ref`, `pull`, `release`, some which will be empty. 4788 #' 4789 #' @name parse-git-repo 4790 #' @examples 4791 #' parse_repo_spec("metacran/crandb") 4792 #' parse_repo_spec("jimhester/covr#47") ## pull request 4793 #' parse_repo_spec("jeroen/curl@v0.9.3") ## specific tag 4794 #' parse_repo_spec("tidyverse/dplyr@*release") ## shorthand for latest release 4795 #' parse_repo_spec("r-lib/remotes@550a3c7d3f9e1493a2ba") ## commit SHA 4796 #' parse_repo_spec("igraph=igraph/rigraph") ## Different package name from repo name 4797 #' 4798 #' parse_github_url("https://github.com/jeroen/curl.git") 4799 #' parse_github_url("git@github.com:metacran/crandb.git") 4800 #' parse_github_url("https://github.com/jimhester/covr") 4801 #' parse_github_url("https://github.example.com/user/repo.git") 4802 #' parse_github_url("git@github.example.com:user/repo.git") 4803 #' 4804 #' parse_github_url("https://github.com/r-lib/remotes/pull/108") 4805 #' parse_github_url("https://github.com/r-lib/remotes/tree/name-of-branch") 4806 #' parse_github_url("https://github.com/r-lib/remotes/commit/1234567") 4807 #' parse_github_url("https://github.com/r-lib/remotes/releases/latest") 4808 #' parse_github_url("https://github.com/r-lib/remotes/releases/tag/1.0.0") 4809 NULL 4810 4811 #' @export 4812 #' @rdname parse-git-repo 4813 parse_repo_spec <- function(repo) { 4814 package_name_rx <- "(?:(?<package>[[:alpha:]][[:alnum:].]*[[:alnum:]])=)?" 4815 username_rx <- "(?:(?<username>[^/]+)/)" 4816 repo_rx <- "(?<repo>[^/@#]+)" 4817 subdir_rx <- "(?:/(?<subdir>[^@#]*[^@#/])/?)?" 4818 ref_rx <- "(?:@(?<ref>[^*].*))" 4819 pull_rx <- "(?:#(?<pull>[0-9]+))" 4820 release_rx <- "(?:@(?<release>[*]release))" 4821 ref_or_pull_or_release_rx <- sprintf( 4822 "(?:%s|%s|%s)?", ref_rx, pull_rx, release_rx 4823 ) 4824 spec_rx <- sprintf( 4825 "^%s%s%s%s%s$", package_name_rx, username_rx, repo_rx, subdir_rx, ref_or_pull_or_release_rx 4826 ) 4827 params <- as.list(re_match(text = repo, pattern = spec_rx)) 4828 4829 if (is.na(params$.match)) { 4830 stop(sprintf("Invalid git repo specification: '%s'", repo)) 4831 } 4832 4833 params[grepl("^[^\\.]", names(params))] 4834 } 4835 4836 #' @export 4837 #' @rdname parse-git-repo 4838 parse_github_repo_spec <- parse_repo_spec 4839 4840 #' @export 4841 #' @rdname parse-git-repo 4842 parse_github_url <- function(repo) { 4843 prefix_rx <- "(?:github[^/:]+[/:])" 4844 username_rx <- "(?:(?<username>[^/]+)/)" 4845 repo_rx <- "(?<repo>[^/@#]+)" 4846 ref_rx <- "(?:(?:tree|commit|releases/tag)/(?<ref>.+$))" 4847 pull_rx <- "(?:pull/(?<pull>.+$))" 4848 release_rx <- "(?:releases/)(?<release>.+$)" 4849 ref_or_pull_or_release_rx <- sprintf( 4850 "(?:/(%s|%s|%s))?", ref_rx, pull_rx, release_rx 4851 ) 4852 url_rx <- sprintf( 4853 "%s%s%s%s", 4854 prefix_rx, username_rx, repo_rx, ref_or_pull_or_release_rx 4855 ) 4856 params <- as.list(re_match(text = repo, pattern = url_rx)) 4857 4858 if (is.na(params$.match)) { 4859 stop(sprintf("Invalid GitHub URL: '%s'", repo)) 4860 } 4861 if (params$ref == "" && params$pull == "" && params$release == "") { 4862 params$repo <- gsub("\\.git$", "", params$repo) 4863 } 4864 if (params$release == "latest") { 4865 params$release <- "*release" 4866 } 4867 4868 params[grepl("^[^\\.]", names(params))] 4869 } 4870 4871 parse_git_repo <- function(repo) { 4872 4873 if (grepl("^https://github|^git@github", repo)) { 4874 params <- parse_github_url(repo) 4875 } else { 4876 params <- parse_repo_spec(repo) 4877 } 4878 params <- params[viapply(params, nchar) > 0] 4879 4880 if (!is.null(params$pull)) { 4881 params$ref <- github_pull(params$pull) 4882 params$pull <- NULL 4883 } 4884 4885 if (!is.null(params$release)) { 4886 params$ref <- github_release() 4887 params$release <- NULL 4888 } 4889 4890 params 4891 } 4892 4893 # Contents of R/submodule.R 4894 parse_submodules <- function(file) { 4895 if (grepl("\n", file)) { 4896 x <- strsplit(file, "\n")[[1]] 4897 } else { 4898 x <- readLines(file) 4899 } 4900 4901 # https://git-scm.com/docs/git-config#_syntax 4902 # Subsection names are case sensitive and can contain any characters except 4903 # newline and the null byte. Doublequote " and backslash can be included by 4904 # escaping them as \" and \\ 4905 double_quoted_string_with_escapes <- '(?:\\\\.|[^"])*' 4906 4907 # Otherwise extract section names 4908 section_names <- re_match( 4909 x, 4910 sprintf('^[[:space:]]*\\[submodule "(?<submodule>%s)"\\][[:space:]]*$', double_quoted_string_with_escapes) 4911 )$submodule 4912 4913 # If no sections found return the empty list 4914 if (all(is.na(section_names))) { 4915 return(list()) 4916 } 4917 4918 # Extract name = value 4919 # The variable names are case-insensitive, allow only alphanumeric characters 4920 # and -, and must start with an alphabetic character. 4921 variable_name <- "[[:alpha:]][[:alnum:]\\-]*" 4922 mapping_values <- re_match( 4923 x, 4924 sprintf('^[[:space:]]*(?<name>%s)[[:space:]]*=[[:space:]]*(?<value>.*)[[:space:]]*$', variable_name), 4925 ) 4926 4927 values <- cbind(submodule = fill(section_names), mapping_values[c("name", "value")], stringsAsFactors = FALSE) 4928 values <- values[!is.na(mapping_values$.match), ] 4929 4930 # path and valid url are required 4931 if (!all(c("path", "url") %in% values$name)) { 4932 warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE) 4933 return(list()) 4934 } 4935 4936 # Roughly equivalent to tidyr::spread(values, name, value) 4937 res <- stats::reshape(values, idvar = "submodule", timevar = "name", v.name = "value", direction = "wide") 4938 4939 # Set the column names, reshape prepends `value.` to path, url and branch 4940 colnames(res) <- gsub("value[.]", "", colnames(res)) 4941 4942 # path and valid url are required 4943 if (any(is.na(res$url), is.na(res$path))) { 4944 warning("Invalid submodule definition, skipping submodule installation", immediate. = TRUE, call. = FALSE) 4945 return(list()) 4946 } 4947 4948 # branch is optional 4949 if (!exists("branch", res)) { 4950 res$branch <- NA_character_ 4951 } 4952 4953 # Remove unneeded attribute 4954 attr(res, "reshapeWide") <- NULL 4955 4956 # Remove rownames 4957 rownames(res) <- NULL 4958 4959 res 4960 } 4961 4962 # Adapted from https://stackoverflow.com/a/9517731/2055486 4963 fill <- function(x) { 4964 not_missing <- !is.na(x) 4965 4966 res <- x[not_missing] 4967 res[cumsum(not_missing)] 4968 } 4969 4970 update_submodule <- function(url, path, branch, quiet) { 4971 args <- c('clone', '--depth', '1', '--no-hardlinks --recurse-submodules') 4972 if (length(branch) > 0 && !is.na(branch) && branch != 'HEAD') { 4973 args <- c(args, "--branch", branch) 4974 } 4975 args <- c(args, url, path) 4976 4977 git(paste0(args, collapse = " "), quiet = quiet) 4978 } 4979 4980 update_submodules <- function(source, subdir, quiet) { 4981 file <- file.path(source, ".gitmodules") 4982 4983 if (!file.exists(file)) { 4984 4985 if (!is.null(subdir)) { 4986 nb_sub_folders <- lengths(strsplit(subdir, "/")) 4987 source <- do.call(file.path, as.list(c(source, rep("..", nb_sub_folders)))) 4988 } 4989 4990 file <- file.path(source, ".gitmodules") 4991 if (!file.exists(file)) { 4992 return() 4993 } 4994 } 4995 info <- parse_submodules(file) 4996 4997 # Fixes #234 4998 if (length(info) == 0) { 4999 return() 5000 } 5001 to_ignore <- in_r_build_ignore(info$path, file.path(source, ".Rbuildignore")) 5002 if (!(length(info) > 0)) { 5003 return() 5004 } 5005 info <- info[!to_ignore, ] 5006 5007 for (i in seq_len(NROW(info))) { 5008 update_submodule(info$url[[i]], file.path(source, info$path[[i]]), info$branch[[i]], quiet) 5009 } 5010 } 5011 # Contents of R/system.R 5012 5013 system_check <- function(command, args = character(), quiet = TRUE, 5014 error = TRUE, path = ".") { 5015 5016 out <- tempfile() 5017 err <- tempfile() 5018 on.exit(unlink(out), add = TRUE) 5019 on.exit(unlink(err), add = TRUE) 5020 5021 ## We suppress warnings, they are given if the command 5022 ## exits with a non-zero status 5023 res <- in_dir( 5024 path, 5025 suppressWarnings( 5026 system2(command, args = args, stdout = out, stderr = err) 5027 ) 5028 ) 5029 5030 res <- list( 5031 stdout = tryCatch( 5032 suppressWarnings(win2unix(read_char(out))), 5033 error = function(e) "" 5034 ), 5035 stderr = tryCatch( 5036 suppressWarnings(win2unix(read_char(err))), 5037 error = function(e) "" 5038 ), 5039 status = res 5040 ) 5041 5042 if (error && res$status != 0) { 5043 stop("Command ", command, " failed ", res$stderr) 5044 } 5045 5046 if (! quiet) { 5047 if (! identical(res$stdout, NA_character_)) cat(res$stdout) 5048 if (! identical(res$stderr, NA_character_)) cat(res$stderr) 5049 } 5050 5051 res 5052 } 5053 5054 win2unix <- function(str) { 5055 gsub("\r\n", "\n", str, fixed = TRUE) 5056 } 5057 5058 read_char <- function(path, ...) { 5059 readChar(path, nchars = file.info(path)$size, ...) 5060 } 5061 # Contents of R/system_requirements.R 5062 DEFAULT_RSPM_REPO_ID <- "1" # cran 5063 DEFAULT_RSPM <- "https://packagemanager.rstudio.com" 5064 5065 #' Query the system requirements for a package (and its dependencies) 5066 #' 5067 #' Returns a character vector of commands to run that will install system 5068 #' requirements for the queried operating system. 5069 #' 5070 #' @param os,os_release The operating system and operating system release version, see 5071 #' <https://github.com/rstudio/r-system-requirements#operating-systems> for the 5072 #' list of supported operating systems. 5073 #' 5074 #' If `os_release` is `NULL`, `os` must consist of the operating system 5075 #' and the version separated by a dash, e.g. `"ubuntu-18.04"`. 5076 #' @param path The path to the dev package's root directory. 5077 #' @param package CRAN package name(s) to lookup system requirements for. If not 5078 #' `NULL`, this is used and `path` is ignored. 5079 #' @param curl The location of the curl binary on your system. 5080 #' @return A character vector of commands needed to install the system requirements for the package. 5081 #' @export 5082 system_requirements <- function(os, os_release = NULL, path = ".", package = NULL, curl = Sys.which("curl")) { 5083 if (is.null(os_release)) { 5084 os_release <- strsplit(os, "-", fixed = TRUE)[[1]] 5085 if (length(os_release) != 2) { 5086 stop("If os_release is missing, os must consist of name and release.", call. = FALSE) 5087 } 5088 5089 os <- os_release[[1]] 5090 os_release <- os_release[[2]] 5091 } 5092 5093 os_versions <- supported_os_versions() 5094 5095 os <- match.arg(os, names(os_versions)) 5096 5097 os_release <- match.arg(os_release, os_versions[[os]]) 5098 5099 if (!nzchar(curl)) { 5100 stop("`curl` must be on the `PATH`.", call. = FALSE) 5101 } 5102 5103 rspm <- Sys.getenv("RSPM_ROOT", DEFAULT_RSPM) 5104 rspm_repo_id <- Sys.getenv("RSPM_REPO_ID", DEFAULT_RSPM_REPO_ID) 5105 rspm_repo_url <- sprintf("%s/__api__/repos/%s", rspm, rspm_repo_id) 5106 5107 if (!is.null(package)) { 5108 res <- system2( 5109 curl, 5110 args = c( 5111 "--silent", 5112 shQuote(sprintf("%s/sysreqs?all=false&pkgname=%s&distribution=%s&release=%s", 5113 rspm_repo_url, 5114 paste(package, collapse = "&pkgname="), 5115 os, 5116 os_release) 5117 )), 5118 stdout = TRUE 5119 ) 5120 res <- json$parse(res) 5121 if (!is.null(res$error)) { 5122 stop(res$error) 5123 } 5124 pre_install <- unique(unlist(c(res[["pre_install"]], lapply(res[["requirements"]], `[[`, c("requirements", "pre_install"))))) 5125 install_scripts <- unique(unlist(c(res[["install_scripts"]], lapply(res[["requirements"]], `[[`, c("requirements", "install_scripts"))))) 5126 } else { 5127 desc_file <- normalizePath(file.path(path, "DESCRIPTION"), mustWork = FALSE) 5128 if (!file.exists(desc_file)) { 5129 stop("`", path, "` must contain a package.", call. = FALSE) 5130 } 5131 5132 res <- system2( 5133 curl, 5134 args = c( 5135 "--silent", 5136 "--data-binary", 5137 shQuote(paste0("@", desc_file)), 5138 shQuote(sprintf("%s/sysreqs?distribution=%s&release=%s&suggests=true", 5139 rspm_repo_url, 5140 os, 5141 os_release) 5142 ) 5143 ), 5144 stdout = TRUE 5145 ) 5146 res <- json$parse(res) 5147 if (!is.null(res$error)) { 5148 stop(res$error) 5149 } 5150 5151 pre_install <- unique(unlist(c(res[["pre_install"]], lapply(res[["dependencies"]], `[[`, "pre_install")))) 5152 install_scripts <- unique(unlist(c(res[["install_scripts"]], lapply(res[["dependencies"]], `[[`, "install_scripts")))) 5153 } 5154 5155 as.character(c(pre_install, install_scripts)) 5156 } 5157 5158 # Adapted from https://github.com/rstudio/r-system-requirements/blob/master/systems.json 5159 # OSs commented out are not currently supported by the API 5160 supported_os_versions <- function() { 5161 list( 5162 #"debian" = c("8", "9"), 5163 "ubuntu" = c("14.04", "16.04", "18.04", "20.04"), 5164 "centos" = c("6", "7", "8"), 5165 "redhat" = c("6", "7", "8"), 5166 "opensuse" = c("42.3", "15.0"), 5167 "sle" = c("12.3", "15.0") 5168 #"windows" = c("") 5169 ) 5170 } 5171 # Contents of R/utils.R 5172 5173 `%||%` <- function (a, b) if (!is.null(a)) a else b 5174 5175 `%:::%` <- function (p, f) get(f, envir = asNamespace(p)) 5176 5177 `%::%` <- function (p, f) get(f, envir = asNamespace(p)) 5178 5179 viapply <- function(X, FUN, ..., USE.NAMES = TRUE) { 5180 vapply(X, FUN, integer(1L), ..., USE.NAMES = USE.NAMES) 5181 } 5182 5183 vlapply <- function(X, FUN, ..., USE.NAMES = TRUE) { 5184 vapply(X, FUN, logical(1L), ..., USE.NAMES = USE.NAMES) 5185 } 5186 5187 rcmd <- function(cmd, args, path = R.home("bin"), quiet, fail_on_status = TRUE) { 5188 if (os_type() == "windows") { 5189 real_cmd <- file.path(path, "Rcmd.exe") 5190 args <- c(cmd, args) 5191 } else { 5192 real_cmd <- file.path(path, "R") 5193 args <- c("CMD", cmd, args) 5194 } 5195 5196 stdoutfile <- tempfile() 5197 stderrfile <- tempfile() 5198 on.exit(unlink(c(stdoutfile, stderrfile), recursive = TRUE), add = TRUE) 5199 status <- system2(real_cmd, args, stderr = stderrfile, stdout = stdoutfile) 5200 out <- tryCatch(readLines(stdoutfile, warn = FALSE), error = function(x) "") 5201 err <- tryCatch(readLines(stderrfile, warn = FALSE), error = function(x) "") 5202 5203 if (fail_on_status && status != 0) { 5204 cat("STDOUT:\n") 5205 cat(out, sep = "\n") 5206 cat("STDERR:\n") 5207 cat(err, sep = "\n") 5208 stop(sprintf("Error running '%s' (status '%i')", cmd, status), call. = FALSE) 5209 } 5210 if (!quiet) { 5211 cat(out, sep = "\n") 5212 } 5213 5214 list(stdout = out, stderr = err, status = status) 5215 } 5216 5217 is_bioconductor <- function(x) { 5218 !is.null(x$biocviews) 5219 } 5220 5221 trim_ws <- function(x) { 5222 gsub("^[[:space:]]+|[[:space:]]+$", "", x) 5223 } 5224 5225 set_envvar <- function(envs) { 5226 if (length(envs) == 0) return() 5227 5228 stopifnot(is.named(envs)) 5229 5230 old <- Sys.getenv(names(envs), names = TRUE, unset = NA) 5231 set <- !is.na(envs) 5232 5233 both_set <- set & !is.na(old) 5234 5235 if (any(set)) do.call("Sys.setenv", as.list(envs[set])) 5236 if (any(!set)) Sys.unsetenv(names(envs)[!set]) 5237 5238 invisible(old) 5239 } 5240 5241 with_envvar <- function(new, code) { 5242 old <- set_envvar(new) 5243 on.exit(set_envvar(old)) 5244 force(code) 5245 } 5246 5247 is.named <- function(x) { 5248 !is.null(names(x)) && all(names(x) != "") 5249 } 5250 5251 pkg_installed <- function(pkg) { 5252 5253 if (pkg %in% loadedNamespaces()) { 5254 TRUE 5255 } else if (requireNamespace(pkg, quietly = TRUE)) { 5256 try(unloadNamespace(pkg)) 5257 TRUE 5258 } else { 5259 FALSE 5260 } 5261 } 5262 5263 has_package <- function(pkg) { 5264 if (pkg %in% loadedNamespaces()) { 5265 TRUE 5266 } else { 5267 requireNamespace(pkg, quietly = TRUE) 5268 } 5269 } 5270 5271 with_something <- function(set, reset = set) { 5272 function(new, code) { 5273 old <- set(new) 5274 on.exit(reset(old)) 5275 force(code) 5276 } 5277 } 5278 5279 in_dir <- with_something(setwd) 5280 5281 get_r_version <- function() { 5282 paste(R.version$major, sep = ".", R.version$minor) 5283 } 5284 5285 set_options <- function(x) { 5286 do.call(options, as.list(x)) 5287 } 5288 5289 with_options <- with_something(set_options) 5290 5291 # Read the current user .Rprofile. Here is the order it is searched, from 5292 # ?Startup 5293 # 5294 # 'R_PROFILE_USER’ environment variable (and tilde expansion 5295 # will be performed). If this is unset, a file called ‘.Rprofile’ 5296 # is searched for in the current directory or in the user's home 5297 # directory (in that order). The user profile file is sourced into 5298 # the workspace. 5299 read_rprofile_user <- function() { 5300 f <- normalizePath(Sys.getenv("R_PROFILE_USER", ""), mustWork = FALSE) 5301 if (file.exists(f)) { 5302 return(readLines(f)) 5303 } 5304 5305 f <- normalizePath("~/.Rprofile", mustWork = FALSE) 5306 if (file.exists(f)) { 5307 return(readLines(f)) 5308 } 5309 5310 character() 5311 } 5312 5313 with_rprofile_user <- function(new, code) { 5314 temp_rprofile <- tempfile() 5315 on.exit(unlink(temp_rprofile), add = TRUE) 5316 5317 writeLines(c(read_rprofile_user(), new), temp_rprofile) 5318 with_envvar(c("R_PROFILE_USER" = temp_rprofile), { 5319 force(code) 5320 }) 5321 } 5322 5323 ## There are two kinds of tar on windows, one needs --force-local 5324 ## not to interpret : characters, the other does not. We try both ways. 5325 5326 untar <- function(tarfile, ...) { 5327 if (os_type() == "windows") { 5328 5329 tarhelp <- tryCatch( 5330 system2("tar", "--help", stdout = TRUE, stderr = TRUE), 5331 error = function(x) "") 5332 5333 if (any(grepl("--force-local", tarhelp))) { 5334 status <- try( 5335 suppressWarnings(utils::untar(tarfile, extras = "--force-local", ...)), 5336 silent = TRUE) 5337 if (! is_tar_error(status)) { 5338 return(status) 5339 5340 } else { 5341 message("External tar failed with `--force-local`, trying without") 5342 } 5343 } 5344 } 5345 5346 utils::untar(tarfile, ...) 5347 } 5348 5349 is_tar_error <- function(status) { 5350 inherits(status, "try-error") || 5351 is_error_status(status) || 5352 is_error_status(attr(status, "status")) 5353 } 5354 5355 is_error_status <- function(x) { 5356 is.numeric(x) && length(x) > 0 && !is.na(x) && x != 0 5357 } 5358 5359 os_type <- function() { 5360 .Platform$OS.type 5361 } 5362 5363 sys_type <- function() { 5364 if (.Platform$OS.type == "windows") { 5365 "windows" 5366 } else if (Sys.info()["sysname"] == "Darwin") { 5367 "macos" 5368 } else if (Sys.info()["sysname"] == "Linux") { 5369 "linux" 5370 } else if (.Platform$OS.type == "unix") { 5371 "unix" 5372 } else { 5373 stop("Unknown OS") 5374 } 5375 } 5376 5377 is_dir <- function(path) { 5378 file.info(path)$isdir 5379 } 5380 5381 untar_description <- function(tarball, dir = tempfile()) { 5382 files <- untar(tarball, list = TRUE) 5383 desc <- grep("^[^/]+/DESCRIPTION$", files, value = TRUE) 5384 if (length(desc) < 1) stop("No 'DESCRIPTION' file in package") 5385 untar(tarball, desc, exdir = dir) 5386 file.path(dir, desc) 5387 } 5388 5389 ## copied from rematch2@180fb61 5390 re_match <- function(text, pattern, perl = TRUE, ...) { 5391 5392 stopifnot(is.character(pattern), length(pattern) == 1, !is.na(pattern)) 5393 text <- as.character(text) 5394 5395 match <- regexpr(pattern, text, perl = perl, ...) 5396 5397 start <- as.vector(match) 5398 length <- attr(match, "match.length") 5399 end <- start + length - 1L 5400 5401 matchstr <- substring(text, start, end) 5402 matchstr[ start == -1 ] <- NA_character_ 5403 5404 res <- data.frame( 5405 stringsAsFactors = FALSE, 5406 .text = text, 5407 .match = matchstr 5408 ) 5409 5410 if (!is.null(attr(match, "capture.start"))) { 5411 5412 gstart <- attr(match, "capture.start") 5413 glength <- attr(match, "capture.length") 5414 gend <- gstart + glength - 1L 5415 5416 groupstr <- substring(text, gstart, gend) 5417 groupstr[ gstart == -1 ] <- NA_character_ 5418 dim(groupstr) <- dim(gstart) 5419 5420 res <- cbind(groupstr, res, stringsAsFactors = FALSE) 5421 } 5422 5423 names(res) <- c(attr(match, "capture.names"), ".text", ".match") 5424 class(res) <- c("tbl_df", "tbl", class(res)) 5425 res 5426 } 5427 5428 is_standalone <- function() { 5429 isTRUE(config_val_to_logical(Sys.getenv("R_REMOTES_STANDALONE", "false"))) 5430 } 5431 5432 # This code is adapted from the perl MIME::Base64 module https://perldoc.perl.org/MIME/Base64.html 5433 # https://github.com/gisle/mime-base64/blob/cf23d49e517c6ed8f4b24295f63721e8c9935010/Base64.xs#L197 5434 5435 XX <- 255L 5436 EQ <- 254L 5437 INVALID <- XX 5438 5439 index_64 <- as.integer(c( 5440 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5441 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5442 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,62, XX,XX,XX,63, 5443 52,53,54,55, 56,57,58,59, 60,61,XX,XX, XX,EQ,XX,XX, 5444 XX, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,10, 11,12,13,14, 5445 15,16,17,18, 19,20,21,22, 23,24,25,XX, XX,XX,XX,XX, 5446 XX,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40, 5447 41,42,43,44, 45,46,47,48, 49,50,51,XX, XX,XX,XX,XX, 5448 5449 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5450 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5451 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5452 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5453 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5454 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5455 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, 5456 XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX 5457 )) 5458 5459 base64_decode <- function(x) { 5460 if (is.character(x)) { 5461 x <- charToRaw(x) 5462 } 5463 5464 len <- length(x) 5465 idx <- 1 5466 c <- integer(4) 5467 out <- raw() 5468 while(idx <= len) { 5469 i <- 1 5470 while(i <= 4) { 5471 uc <- index_64[[as.integer(x[[idx]]) + 1L]] 5472 idx <- idx + 1 5473 if (uc != INVALID) { 5474 c[[i]] <- uc 5475 i <- i + 1 5476 } 5477 if (idx > len) { 5478 if (i <= 4) { 5479 if (i <= 2) return(rawToChar(out)) 5480 if (i == 3) { 5481 c[[3]] <- EQ 5482 c[[4]] <- EQ 5483 } 5484 break 5485 } 5486 } 5487 } 5488 5489 if (c[[1]] == EQ || c[[2]] == EQ) { 5490 break 5491 } 5492 5493 #print(sprintf("c1=%d,c2=%d,c3=%d,c4=%d\n", c[1],c[2],c[3],c[4])) 5494 5495 out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(c[[1]], 2L), bitwShiftR(bitwAnd(c[[2]], 0x30), 4L))) 5496 5497 if (c[[3]] == EQ) { 5498 break 5499 } 5500 5501 out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[2]], 0x0F), 4L), bitwShiftR(bitwAnd(c[[3]], 0x3C), 2L))) 5502 5503 if (c[[4]] == EQ) { 5504 break 5505 } 5506 5507 out[[length(out) + 1]] <- as.raw(bitwOr(bitwShiftL(bitwAnd(c[[3]], 0x03), 6L), c[[4]])) 5508 } 5509 rawToChar(out) 5510 } 5511 5512 basis64 <- charToRaw(paste(c(LETTERS, letters, 0:9, "+", "/"), 5513 collapse = "")) 5514 5515 base64_encode <- function(x) { 5516 if (is.character(x)) { 5517 x <- charToRaw(x) 5518 } 5519 5520 len <- length(x) 5521 rlen <- floor((len + 2L) / 3L) * 4L 5522 out <- raw(rlen) 5523 ip <- op <- 1L 5524 c <- integer(4) 5525 5526 while (len > 0L) { 5527 c[[1]] <- as.integer(x[[ip]]) 5528 ip <- ip + 1L 5529 if (len > 1L) { 5530 c[[2]] <- as.integer(x[ip]) 5531 ip <- ip + 1L 5532 } else { 5533 c[[2]] <- 0L 5534 } 5535 out[op] <- basis64[1 + bitwShiftR(c[[1]], 2L)] 5536 op <- op + 1L 5537 out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[1]], 3L), 4L), 5538 bitwShiftR(bitwAnd(c[[2]], 240L), 4L))] 5539 op <- op + 1L 5540 5541 if (len > 2) { 5542 c[[3]] <- as.integer(x[ip]) 5543 ip <- ip + 1L 5544 out[op] <- basis64[1 + bitwOr(bitwShiftL(bitwAnd(c[[2]], 15L), 2L), 5545 bitwShiftR(bitwAnd(c[[3]], 192L), 6L))] 5546 op <- op + 1L 5547 out[op] <- basis64[1 + bitwAnd(c[[3]], 63)] 5548 op <- op + 1L 5549 5550 } else if (len == 2) { 5551 out[op] <- basis64[1 + bitwShiftL(bitwAnd(c[[2]], 15L), 2L)] 5552 op <- op + 1L 5553 out[op] <- charToRaw("=") 5554 op <- op + 1L 5555 5556 } else { ## len == 1 5557 out[op] <- charToRaw("=") 5558 op <- op + 1L 5559 out[op] <- charToRaw("=") 5560 op <- op + 1L 5561 5562 } 5563 len <- len - 3L 5564 } 5565 5566 rawToChar(out) 5567 } 5568 5569 build_url <- function(host, ...) { 5570 download_url(do.call(file.path, as.list(c(host, ...)))) 5571 } 5572 5573 download_url <- function(url) { 5574 if (!grepl("^[[:alpha:]]+://", url)) { 5575 scheme <- if (download_method_secure()) "https://" else "http://" 5576 return(paste0(scheme, url)) 5577 } 5578 url 5579 } 5580 5581 is_na <- function(x) { 5582 length(x) == 1 && is.na(x) 5583 } 5584 5585 dir.exists <- function(paths) { 5586 if (getRversion() < "3.2") { 5587 x <- base::file.info(paths)$isdir 5588 !is.na(x) & x 5589 } else { 5590 ("base" %::% "dir.exists")(paths) 5591 } 5592 } 5593 5594 is_binary_pkg <- function(x) { 5595 file_ext(x) %in% c("tgz", "zip") 5596 } 5597 5598 format_str <- function(x, width = Inf, trim = TRUE, justify = "none", ...) { 5599 x <- format(x, trim = trim, justify = justify, ...) 5600 5601 if (width < Inf) { 5602 x_width <- nchar(x, "width") 5603 too_wide <- x_width > width 5604 if (any(too_wide)) { 5605 x[too_wide] <- paste0(substr(x[too_wide], 1, width - 3), "...") 5606 } 5607 } 5608 x 5609 } 5610 5611 warn_for_potential_errors <- function() { 5612 if (sys_type() == "windows" && grepl(" ", R.home()) && 5613 getRversion() <= "3.4.2") { 5614 warning(immediate. = TRUE, 5615 "\n!!! Installation will probably fail!\n", 5616 "This version of R has trouble with building and installing packages if\n", 5617 "the R HOME directory (currently '", R.home(), "')\n", 5618 "has space characters. Possible workarounds include:\n", 5619 "- installing R to the C: drive,\n", 5620 "- installing it into a path without a space, or\n", 5621 "- creating a drive letter for R HOME via the `subst` windows command, and\n", 5622 " starting R from the new drive.\n", 5623 "See also https://github.com/r-lib/remotes/issues/98\n") 5624 } 5625 } 5626 5627 # Return all directories in the input paths 5628 directories <- function(paths) { 5629 dirs <- unique(dirname(paths)) 5630 out <- dirs[dirs != "."] 5631 while(length(dirs) > 0 && any(dirs != ".")) { 5632 out <- unique(c(out, dirs[dirs != "."])) 5633 dirs <- unique(dirname(dirs)) 5634 } 5635 sort(out) 5636 } 5637 5638 in_r_build_ignore <- function(paths, ignore_file) { 5639 ignore <- ("tools" %:::% "get_exclude_patterns")() 5640 5641 if (file.exists(ignore_file)) { 5642 ignore <- c(ignore, readLines(ignore_file, warn = FALSE)) 5643 } 5644 5645 matches_ignores <- function(x) { 5646 any(vlapply(ignore, grepl, x, perl = TRUE, ignore.case = TRUE)) 5647 } 5648 5649 # We need to search for the paths as well as directories in the path, so 5650 # `^foo$` matches `foo/bar` 5651 should_ignore <- function(path) { 5652 any(vlapply(c(path, directories(path)), matches_ignores)) 5653 } 5654 5655 vlapply(paths, should_ignore) 5656 } 5657 5658 dev_split_ref <- function(x) { 5659 re_match(x, "^(?<pkg>[^@#]+)(?<ref>[@#].*)?$") 5660 } 5661 5662 get_json_sha <- function(text) { 5663 m <- regexpr(paste0('"sha"\\s*:\\s*"(\\w+)"'), text, perl = TRUE) 5664 if (all(m == -1)) { 5665 return(json$parse(text)$sha %||% NA_character_) 5666 } 5667 5668 start <- attr(m, "capture.start") 5669 end <- start + attr(m, "capture.length") - 1L 5670 substring(text, start, end) 5671 } 5672 5673 5674 # from tools:::config_val_to_logical 5675 config_val_to_logical <- function (val) { 5676 v <- tolower(val) 5677 if (v %in% c("1", "yes", "true")) 5678 TRUE 5679 else if (v %in% c("0", "no", "false")) 5680 FALSE 5681 else { 5682 NA 5683 } 5684 } 5685 5686 raw_to_char_utf8 <- function(x) { 5687 res <- rawToChar(x) 5688 Encoding(res) <- "UTF-8" 5689 res 5690 } 5691 5692 5693 ## Standalone mode, make sure that we restore the env var on exit 5694 old <- Sys.getenv("R_REMOTES_STANDALONE", NA_character_) 5695 Sys.setenv("R_REMOTES_STANDALONE" = "true") 5696 if (is.na(old)) { 5697 on.exit(Sys.unsetenv("R_REMOTES_STANDALONE"), add = TRUE) 5698 } else { 5699 on.exit(Sys.setenv("R_REMOTES_STANDALONE" = old), add = TRUE) 5700 } 5701 5702 install_github(...) 5703 5704} 5705