| # File src/library/utils/R/packages.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2018 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| available.packages <- |
| function(contriburl = contrib.url(repos, type), method, |
| fields = NULL, type = getOption("pkgType"), |
| filters = NULL, repos = getOption("repos"), |
| ignore_repo_cache = FALSE, max_repo_cache_age, |
| ...) |
| { |
| requiredFields <- |
| c(tools:::.get_standard_repository_db_fields(), "File") |
| if (is.null(fields)) |
| fields <- requiredFields |
| else { |
| stopifnot(is.character(fields)) |
| fields <- unique(c(requiredFields, fields)) |
| } |
| |
| if(missing(max_repo_cache_age)) |
| max_repo_cache_age <- as.numeric(Sys.getenv("R_AVAILABLE_PACKAGES_CACHE_CONTROL_MAX_AGE", "3600")) |
| |
| timestamp <- Sys.time() |
| |
| res <- matrix(NA_character_, 0L, length(fields) + 1L, |
| dimnames = list(NULL, c(fields, "Repository"))) |
| |
| for(repos in contriburl) { |
| localcran <- startsWith(repos, "file:") |
| if(localcran) { |
| ## see note in download.packages |
| if(startsWith(repos, "file:///")) { |
| tmpf <- paste0(substring(repos, 8L), "/PACKAGES") |
| if(.Platform$OS.type == "windows") { |
| if(length(grep("^/[A-Za-z]:", tmpf))) |
| tmpf <- substring(tmpf, 2L) |
| } |
| } else { |
| tmpf <- paste0(substring(repos, 6L), "/PACKAGES") |
| } |
| res0 <- if(file.exists(dest <- paste0(tmpf, ".rds"))) |
| readRDS(dest) |
| else |
| read.dcf(file = tmpf) |
| if(length(res0)) |
| rownames(res0) <- res0[, "Package"] |
| } else { |
| used_dest <- FALSE |
| if(ignore_repo_cache) { |
| dest <- tempfile() |
| } else { |
| dest <- file.path(tempdir(), |
| paste0("repos_", URLencode(repos, TRUE), ".rds")) |
| if(file.exists(dest)) { |
| age <- difftime(timestamp, file.mtime(dest), units = "secs") |
| if(isTRUE(age < max_repo_cache_age)) { |
| res0 <- readRDS(dest) |
| used_dest <- TRUE |
| ## Be defensive ... |
| if(length(res0)) |
| rownames(res0) <- res0[, "Package"] |
| } |
| else |
| unlink(dest) # Cache too old. |
| } |
| } |
| if(!used_dest) { |
| ## Try .rds and readRDS(), and then .gz or plain DCF and |
| ## read.dcf(), catching problems from both missing or |
| ## invalid files. |
| need_dest <- FALSE |
| op <- options(warn = -1L) |
| z <- tryCatch({ |
| download.file(url = paste0(repos, "/PACKAGES.rds"), |
| destfile = dest, method = method, |
| cacheOK = FALSE, quiet = TRUE, mode = "wb") |
| }, error = identity) |
| options(op) |
| if(!inherits(z, "error")) { |
| z <- res0 <- tryCatch(readRDS(dest), error = identity) |
| if(ignore_repo_cache) unlink(dest) |
| } |
| |
| if(inherits(z, "error")) { |
| ## Downloading or reading .rds failed, so try the |
| ## DCF variants. |
| if(!ignore_repo_cache) need_dest <- TRUE |
| tmpf <- tempfile() |
| on.exit(unlink(tmpf)) |
| op <- options(warn = -1L) |
| ## FIXME: this should check the return value == 0L |
| z <- tryCatch({ |
| ## This is a binary file |
| download.file(url = paste0(repos, "/PACKAGES.gz"), |
| destfile = tmpf, method = method, |
| cacheOK = FALSE, quiet = TRUE, mode = "wb") |
| }, error = identity) |
| if(inherits(z, "error")) |
| z <- tryCatch({ |
| ## read.dcf is going to interpret CRLF as |
| ## LF, so use binary mode to avoid CRLF. |
| download.file(url = paste0(repos, "/PACKAGES"), |
| destfile = tmpf, method = method, |
| cacheOK = FALSE, quiet = TRUE, mode = "wb") |
| }, error = identity) |
| options(op) |
| |
| if (!inherits(z, "error")) |
| z <- res0 <- tryCatch(read.dcf(file = tmpf), |
| error = identity) |
| |
| unlink(tmpf) |
| on.exit() |
| } |
| |
| if(inherits(z, "error")) { |
| warning(gettextf("unable to access index for repository %s", |
| repos), |
| ":\n ", conditionMessage(z), |
| call. = FALSE, immediate. = TRUE, domain = NA) |
| next |
| } |
| |
| if(length(res0)) { |
| rownames(res0) <- res0[, "Package"] |
| if(need_dest) |
| saveRDS(res0, dest, compress = TRUE) |
| } else if(!need_dest) { |
| ## download.file() gave an empty .rds |
| ## Do not cache empty results. |
| unlink(dest) |
| } |
| } # end of download vs cached |
| } # end of localcran vs online |
| if (length(res0)) { |
| missingFields <- fields[!(fields %in% colnames(res0))] |
| if (length(missingFields)) { |
| toadd <- matrix(NA_character_, nrow = nrow(res0), |
| ncol = length(missingFields), |
| dimnames = list(NULL, missingFields)) |
| res0 <- cbind(res0, toadd) |
| } |
| if ("Path" %in% colnames(res0)) { |
| rp <- rep.int(repos, nrow(res0)) |
| path <- res0[, "Path"] |
| rp[!is.na(path)] <- paste(repos, path[!is.na(path)], sep = "/") |
| } else rp <- repos |
| res0 <- cbind(res0[, fields, drop = FALSE], Repository = rp) |
| res <- rbind(res, res0, deparse.level = 0L) |
| } |
| } |
| |
| if(!length(res)) return(res) |
| |
| if(is.null(filters)) { |
| filters <- getOption("available_packages_filters") |
| if(is.null(filters)) |
| filters <- available_packages_filters_default |
| } |
| if(is.list(filters)) { |
| ## If filters is a list with an add = TRUE element, add the |
| ## given filters to the default ones. |
| if(isTRUE(filters$add)) { |
| filters$add <- NULL |
| filters <- c(available_packages_filters_default, filters) |
| } |
| } |
| for(f in filters) { |
| if(!length(res)) break |
| if(is.character(f)) { |
| ## Look up the filters db. |
| ## Could be nice and allow abbrevs or ignore case. |
| f <- available_packages_filters_db[[f[1L]]] |
| } |
| if(!is.function(f)) |
| stop("invalid 'filters' argument.") |
| res <- f(res) |
| } |
| |
| res |
| } |
| |
| available_packages_filters_default <- |
| c("R_version", "OS_type", "subarch", "duplicates") |
| |
| available_packages_filters_db <- new.env(hash = FALSE) # small |
| |
| available_packages_filters_db$R_version <- |
| function(db) |
| { |
| ## Ignore packages which don't fit our version of R. |
| depends <- db[, "Depends"] |
| depends[is.na(depends)] <- "" |
| ## Collect the (versioned) R depends entries. |
| x <- lapply(strsplit(sub("^[[:space:]]*", "", depends), |
| "[[:space:]]*,[[:space:]]*"), |
| function(s) s[grepl("^R[[:space:]]*\\(", s)]) |
| lens <- lengths(x) |
| pos <- which(lens > 0L) |
| if(!length(pos)) return(db) |
| lens <- lens[pos] |
| ## Unlist. |
| x <- unlist(x) |
| pat <- "^R[[:space:]]*\\(([[<>=!]+)[[:space:]]+(.*)\\)[[:space:]]*" |
| ## Extract ops. |
| ops <- sub(pat, "\\1", x) |
| ## Split target versions accordings to ops. |
| v_t <- split(sub(pat, "\\2", x), ops) |
| ## Current R version. |
| v_c <- getRversion() |
| ## Compare current to target grouped by op. |
| res <- logical(length(x)) |
| for(op in names(v_t)) |
| res[ops == op] <- do.call(op, list(v_c, v_t[[op]])) |
| ## And assemble test results according to the rows of db. |
| ind <- rep.int(TRUE, NROW(db)) |
| ind[pos] <- sapply(split(res, rep.int(seq_along(lens), lens)), all) |
| db[ind, , drop = FALSE] |
| } |
| |
| available_packages_filters_db$OS_type <- |
| function(db) |
| { |
| ## Ignore packages that do not fit our OS. |
| OS_type <- db[, "OS_type"] |
| db[is.na(OS_type) | (OS_type == .Platform$OS.type), , drop = FALSE] |
| } |
| |
| available_packages_filters_db$subarch <- |
| function(db) |
| { |
| ## Ignore packages that do not fit our sub-architecture. |
| ## Applies only to Mac and Windows binary repositories. |
| current <- .Platform$r_arch |
| if(!nzchar(current)) return(db) |
| archs <- db[, "Archs"] |
| if(all(is.na(archs))) return(db) |
| OK <- unlist(lapply(archs, function(x) { |
| if(is.na(x)) return(TRUE) |
| this <- strsplit(x, "[[:space:]]*,[[:space:]]*")[[1L]] |
| current %in% this |
| })) |
| db[OK, , drop = FALSE] |
| } |
| |
| available_packages_filters_db$duplicates <- |
| function(db) |
| tools:::.remove_stale_dups(db) |
| |
| filter_packages_by_depends_predicates <- |
| function(db, predicate, recursive = TRUE) |
| { |
| ## Could also add a 'which' argument to specify which dependencies |
| ## are taken. |
| |
| ## Drop all packages for which any (recursive) dependency does not |
| ## satisfy the given predicate (implemented as a function computing |
| ## TRUE or FALSE for each rows of the package db). |
| |
| ## Somewhat tricky because there may be depends missing from the db, |
| ## which are taken not to satisfy the predicate unless they are |
| ## standard packages. |
| |
| ## Determine all depends missing from the db. |
| db1 <- data.frame(Package = db[, "Package"], |
| stringsAsFactors = FALSE) |
| fields <- c("Depends", "Imports", "LinkingTo") |
| for(f in fields) |
| db1[[f]] <- |
| lapply(db[, f], tools:::.extract_dependency_package_names) |
| all_packages <- unique(unlist(db1[fields], use.names = FALSE)) |
| bad_packages <- |
| all_packages[is.na(match(all_packages, db1$Package))] |
| ## Drop the standard packages from these. |
| bad_packages <- |
| setdiff(bad_packages, |
| unlist(tools:::.get_standard_package_names())) |
| |
| ## Packages in the db which do not satisfy the predicate. |
| ind <- !predicate(db) |
| ## Now find the recursive reverse dependencies of these and the |
| ## non-standard packages missing from the db. |
| rdepends <- |
| tools::package_dependencies(db1$Package[ind], db = db1, |
| reverse = TRUE, |
| recursive = recursive) |
| rdepends <- unique(unlist(rdepends)) |
| ind[match(rdepends, db1$Package, nomatch = 0L)] <- TRUE |
| |
| ## And drop these from the db. |
| db[!ind, , drop = FALSE] |
| } |
| |
| available_packages_filters_db$`license/FOSS` <- |
| function(db) { |
| predicate <- function(db) |
| tools:::analyze_licenses(db[, "License"], db)$is_verified |
| filter_packages_by_depends_predicates(db, predicate) |
| } |
| |
| available_packages_filters_db$`license/restricts_use` <- |
| function(db) { |
| predicate <- function(db) { |
| ru <- tools:::analyze_licenses(db[, "License"], db)$restricts_use |
| !is.na(ru) & !ru |
| } |
| filter_packages_by_depends_predicates(db, predicate) |
| } |
| |
| available_packages_filters_db$CRAN <- |
| function(db) |
| { |
| packages <- db[, "Package"] |
| dups <- packages[duplicated(packages)] |
| drop <- integer() |
| CRAN <- getOption("repos")["CRAN"] |
| ## do nothing if there is no CRAN repos on the list |
| if(is.na(CRAN)) return(db) |
| for(d in dups) { |
| pos <- which(packages == d) |
| ind <- !startsWith(db[pos, "Repository"], CRAN) |
| if(!all(ind)) drop <- c(drop, pos[ind]) |
| } |
| if(length(drop)) db[-drop, , drop = FALSE] else db |
| } |
| |
| |
| ## unexported helper function |
| simplifyRepos <- function(repos, type) |
| { |
| tail <- substring(contrib.url("---", type), 4L) |
| ind <- regexpr(tail, repos, fixed=TRUE) |
| ind <- ifelse(ind > 0L, ind-1L, nchar(repos, type="c")) |
| substr(repos, 1L, ind) |
| } |
| |
| update.packages <- function(lib.loc = NULL, repos = getOption("repos"), |
| contriburl = contrib.url(repos, type), |
| method, instlib = NULL, ask = TRUE, |
| available = NULL, oldPkgs = NULL, ..., |
| checkBuilt = FALSE, type = getOption("pkgType")) |
| { |
| force(ask) # just a check that it is valid before we start work |
| text.select <- function(old) |
| { |
| update <- NULL |
| for(k in seq_len(nrow(old))) { |
| cat(old[k, "Package"], ":\n", |
| "Version", old[k, "Installed"], |
| "installed in", old[k, "LibPath"], |
| if(checkBuilt) paste("built under R", old[k, "Built"]), |
| "\n", |
| "Version", old[k, "ReposVer"], "available at", |
| simplifyRepos(old[k, "Repository"], type)) |
| cat("\n") |
| answer <- askYesNo("Update?") |
| if(is.na(answer)) { |
| cat("cancelled by user\n") |
| return(invisible()) |
| } |
| if(isTRUE(answer)) |
| update <- rbind(update, old[k,]) |
| } |
| update |
| } |
| |
| if(is.null(lib.loc)) |
| lib.loc <- .libPaths() |
| |
| |
| if(type == "both" && (!missing(contriburl) || !is.null(available))) { |
| stop("specifying 'contriburl' or 'available' requires a single type, not type = \"both\"") |
| } |
| if(is.null(available)) { |
| available <- available.packages(contriburl = contriburl, |
| method = method, ...) |
| if (missing(repos)) repos <- getOption("repos") # May have changed |
| } |
| if(!is.matrix(oldPkgs) && is.character(oldPkgs)) { |
| subset <- oldPkgs |
| oldPkgs <- NULL |
| } else |
| subset <- NULL |
| |
| if(is.null(oldPkgs)) { |
| ## since 'available' is supplied, 'contriburl' and 'method' are unused |
| oldPkgs <- old.packages(lib.loc = lib.loc, |
| contriburl = contriburl, method = method, |
| available = available, checkBuilt = checkBuilt) |
| if (missing(repos)) repos <- getOption("repos") # May have changed |
| ## prune package versions which are invisible to require() |
| if(!is.null(oldPkgs)) { |
| pkg <- 0L |
| while(pkg < nrow(oldPkgs)) { |
| pkg <- pkg + 1L |
| if(find.package(oldPkgs[pkg], lib.loc = lib.loc) != |
| find.package(oldPkgs[pkg], lib.loc = oldPkgs[pkg,2])) { |
| warning(sprintf("package '%s' in library '%s' will not be updated", |
| oldPkgs[pkg], oldPkgs[pkg, 2]), |
| call. = FALSE, immediate. = TRUE) |
| oldPkgs <- oldPkgs[-pkg, , drop = FALSE] |
| pkg <- pkg - 1L |
| } |
| } |
| } |
| if(is.null(oldPkgs)) |
| return(invisible()) |
| } else if (!(is.matrix(oldPkgs) && is.character(oldPkgs))) |
| stop("invalid 'oldPkgs'; must be a character vector or a result from old.packages()") |
| |
| if(!is.null(subset)) { |
| oldPkgs <- oldPkgs[ rownames(oldPkgs) %in% subset, ,drop=FALSE] |
| if (nrow(oldPkgs) == 0) |
| return(invisible()) |
| } |
| |
| update <- if(is.character(ask) && ask == "graphics") { |
| if(.Platform$OS.type == "windows" || .Platform$GUI == "AQUA" |
| || (capabilities("tcltk") && capabilities("X11"))) { |
| k <- select.list(oldPkgs[,1L], oldPkgs[,1L], multiple = TRUE, |
| title = "Packages to be updated", graphics = TRUE) |
| oldPkgs[match(k, oldPkgs[,1L]), , drop=FALSE] |
| } else text.select(oldPkgs) |
| } else if(isTRUE(ask)) text.select(oldPkgs) |
| else oldPkgs |
| |
| |
| if(length(update)) { |
| if(is.null(instlib)) instlib <- update[, "LibPath"] |
| ## do this a library at a time, to handle dependencies correctly. |
| libs <- unique(instlib) |
| for(l in libs) |
| if (type == 'both') |
| install.packages(update[instlib == l , "Package"], l, |
| repos = repos, method = method, |
| ..., type = type) |
| else |
| install.packages(update[instlib == l , "Package"], l, |
| contriburl = contriburl, method = method, |
| available = available, ..., type = type) |
| } |
| } |
| |
| old.packages <- function(lib.loc = NULL, repos = getOption("repos"), |
| contriburl = contrib.url(repos, type), |
| instPkgs = installed.packages(lib.loc = lib.loc, ...), |
| method, available = NULL, checkBuilt = FALSE, |
| ..., type = getOption("pkgType")) |
| { |
| if(is.null(lib.loc)) |
| lib.loc <- .libPaths() |
| if(!missing(instPkgs)) { |
| ## actually we need rather more than this |
| if(!is.matrix(instPkgs) || !is.character(instPkgs[, "Package"])) |
| stop("ill-formed 'instPkgs' matrix") |
| } |
| if(NROW(instPkgs) == 0L) return(NULL) |
| |
| available <- if(is.null(available)) |
| available.packages(contriburl = contriburl, method = method, ...) |
| else tools:::.remove_stale_dups(available) |
| |
| update <- NULL |
| |
| currentR <- minorR <- getRversion() |
| minorR[[c(1L, 3L)]] <- 0L # set patchlevel to 0 |
| for(k in 1L:nrow(instPkgs)) { |
| if (instPkgs[k, "Priority"] %in% "base") next |
| z <- match(instPkgs[k, "Package"], available[, "Package"]) |
| if(is.na(z)) next |
| onRepos <- available[z, ] |
| ## works OK if Built: is missing (which it should not be) |
| if((!checkBuilt || package_version(instPkgs[k, "Built"]) >= minorR) && |
| package_version(onRepos["Version"]) <= |
| package_version(instPkgs[k, "Version"])) next |
| deps <- onRepos["Depends"] |
| if(!is.na(deps)) { |
| Rdeps <- tools:::.split_dependencies(deps)[["R", exact=TRUE]] |
| if(length(Rdeps) > 1L) { |
| target <- Rdeps$version |
| res <- do.call(Rdeps$op, list(currentR, target)) |
| ## res <- eval(parse(text=paste("currentR", Rdeps$op, "target"))) |
| if(!res) next |
| } |
| } |
| update <- rbind(update, |
| c(instPkgs[k, c("Package", "LibPath", "Version", "Built")], |
| onRepos["Version"], onRepos["Repository"])) |
| } |
| if(!is.null(update)) |
| colnames(update) <- c("Package", "LibPath", "Installed", "Built", |
| "ReposVer", "Repository") |
| rownames(update) <- update[, "Package"] |
| ## finally, remove any duplicate rows |
| update[!duplicated(update), , drop = FALSE] |
| } |
| |
| new.packages <- function(lib.loc = NULL, repos = getOption("repos"), |
| contriburl = contrib.url(repos, type), |
| instPkgs = installed.packages(lib.loc = lib.loc, ...), |
| method, available = NULL, ask = FALSE, |
| ..., type = getOption("pkgType")) |
| { |
| ask # just a check that it is valid before we start work |
| if(type == "both" && (!missing(contriburl) || !is.null(available))) { |
| stop("specifying 'contriburl' or 'available' requires a single type, not type = \"both\"") |
| } |
| if(is.null(lib.loc)) lib.loc <- .libPaths() |
| if(!is.matrix(instPkgs)) |
| stop(gettextf("no installed packages for (invalid?) 'lib.loc=%s'", |
| lib.loc), domain = NA) |
| if(is.null(available)) |
| available <- available.packages(contriburl = contriburl, |
| method = method, ...) |
| |
| installed <- unique(instPkgs[, "Package"]) |
| |
| poss <- sort(unique(available[ ,"Package"])) # sort in local locale |
| res <- setdiff(poss, installed) |
| |
| update <- character() |
| graphics <- FALSE |
| if(is.character(ask) && ask == "graphics") { |
| ask <- TRUE |
| if(.Platform$OS.type == "windows" || .Platform$GUI == "AQUA" |
| || (capabilities("tcltk") && capabilities("X11"))) |
| graphics <- TRUE |
| } |
| if(isTRUE(ask)) { |
| if(length(res)) |
| update <- res[match(select.list(res, multiple = TRUE, |
| title = "New packages to be installed", |
| graphics = graphics) |
| , res)] |
| else message("no new packages are available") |
| } |
| if(length(update)) { |
| if(type == "both") |
| install.packages(update, lib = lib.loc[1L], method = method, |
| type = type, ...) |
| else |
| install.packages(update, lib = lib.loc[1L], contriburl = contriburl, |
| method = method, available = available, |
| type = type, ...) |
| # Now check if they were installed and update 'res' |
| dirs <- list.files(lib.loc[1L]) |
| updated <- update[update %in% dirs] |
| res <- res[!res %in% updated] |
| } |
| res |
| } |
| |
| .instPkgFields <- function(fields) { |
| ## to be used in installed.packages() and similar |
| requiredFields <- |
| c(tools:::.get_standard_repository_db_fields(), "Built") |
| if (is.null(fields)) |
| fields <- requiredFields |
| else { |
| stopifnot(is.character(fields)) |
| fields <- unique(c(requiredFields, fields)) |
| } |
| ## Don't retain 'Package' and 'LibPath' fields as these are used to |
| ## record name and path of installed packages. |
| fields[! fields %in% c("Package", "LibPath")] |
| } |
| |
| |
| ## Read packages' Description and aggregate 'fields' into a character matrix |
| ## NB: this does not handle encodings, so only suitable for ASCII-only fields. |
| .readPkgDesc <- function(lib, fields, pkgs = list.files(lib)) |
| { |
| ## to be used in installed.packages() and similar |
| ## As from 2.13.0 only look at metadata. |
| ret <- matrix(NA_character_, length(pkgs), 2L+length(fields)) |
| for(i in seq_along(pkgs)) { |
| pkgpath <- file.path(lib, pkgs[i]) |
| if(file.access(pkgpath, 5L)) next |
| if (file.exists(file <- file.path(pkgpath, "Meta", "package.rds"))) { |
| ## this is vulnerable to installs going on in parallel |
| md <- try(readRDS(file)) |
| if(inherits(md, "try-error")) next |
| desc <- md$DESCRIPTION[fields] |
| if (!length(desc)) { |
| warning(gettextf("metadata of %s is corrupt", sQuote(pkgpath)), |
| domain = NA) |
| next |
| } |
| if("Built" %in% fields) { |
| ## This should not be missing. |
| if(is.null(md$Built$R) || !("Built" %in% names(desc))) { |
| warning(gettextf("metadata of %s is corrupt", |
| sQuote(pkgpath)), domain = NA) |
| next |
| } |
| desc["Built"] <- as.character(md$Built$R) |
| } |
| ret[i, ] <- c(pkgs[i], lib, desc) |
| } |
| } |
| ret[!is.na(ret[, 1L]), ] |
| } |
| |
| installed.packages <- |
| function(lib.loc = NULL, priority = NULL, noCache = FALSE, |
| fields = NULL, subarch = .Platform$r_arch, ...) |
| { |
| if(is.null(lib.loc)) |
| lib.loc <- .libPaths() |
| if(!is.null(priority)) { |
| if(!is.character(priority)) |
| stop("'priority' must be character or NULL") |
| if(any(b <- priority %in% "high")) |
| priority <- c(priority[!b], "recommended","base") |
| } |
| |
| fields <- .instPkgFields(fields) |
| retval <- matrix(character(), 0L, 2L + length(fields)) |
| for(lib in lib.loc) { |
| if(noCache) { |
| ret0 <- .readPkgDesc(lib, fields) |
| if(length(ret0)) retval <- rbind(retval, ret0, deparse.level = 0L) |
| } else { |
| ## Previously used URLencode for e.g. Windows paths with drives |
| ## This version works for very long file names. |
| base <- paste(c(lib, fields), collapse = ",") |
| ## add length and 64-bit CRC in hex (in theory, seems |
| ## it is actually 32-bit on some systems) |
| enc <- sprintf("%d_%s", nchar(base), .Call(C_crc64, base)) |
| dest <- file.path(tempdir(), paste0("libloc_", enc, ".rds")) |
| test <- file.exists(dest) && |
| file.mtime(dest) > file.mtime(lib) && |
| (val <- readRDS(dest))$base == base |
| if(isTRUE(as.vector(test))) |
| ## use the cache file |
| retval <- rbind(retval, val$value) |
| else { |
| ret0 <- .readPkgDesc(lib, fields) |
| if(length(ret0)) { |
| retval <- rbind(retval, ret0, deparse.level = 0L) |
| ## save the cache file |
| saveRDS(list(base = base, value = ret0), dest) |
| } else unlink(dest) |
| } |
| } |
| } |
| |
| .fixupPkgMat(retval, fields, priority, subarch) |
| } |
| |
| .fixupPkgMat <- function(mat, fields, priority, subarch=NULL) |
| { |
| ## to be used in installed.packages() and similar |
| colnames(mat) <- c("Package", "LibPath", fields) |
| if (length(mat) && !is.null(priority)) { |
| keep <- !is.na(pmatch(mat[,"Priority"], priority, |
| duplicates.ok = TRUE)) |
| mat <- mat[keep, , drop = FALSE] |
| } |
| if (length(mat) && !is.null(subarch) && nzchar(subarch)) { |
| archs <- strsplit(mat[, "Archs"], ", ", fixed = TRUE) |
| keep <- unlist(lapply(archs, |
| function(x) is.na(x[1L]) || subarch %in% x)) |
| mat <- mat[keep, , drop = FALSE] |
| } |
| if (length(mat)) mat <- mat[, colnames(mat) != "Archs", drop = FALSE] |
| if (length(mat)) rownames(mat) <- mat[, "Package"] |
| mat |
| } |
| |
| |
| remove.packages <- function(pkgs, lib) |
| { |
| updateIndices <- function(lib) { |
| ## This matches what install.packages() does |
| if(lib == .Library && .Platform$OS.type == "unix") { |
| message("Updating HTML index of packages in '.Library'") |
| make.packages.html(.Library) |
| } |
| ## FIXME: only needed for packages installed < 2.13.0, |
| ## so remove eventually |
| ## is this the lib now empty? |
| Rcss <- file.path(lib, "R.css") |
| if (file.exists(Rcss)) { |
| pkgs <- Sys.glob(file.path(lib, "*", "Meta", "package.rds")) |
| if (!length(pkgs)) unlink(Rcss) |
| } |
| } |
| |
| if(!length(pkgs)) return(invisible()) |
| |
| if(missing(lib) || is.null(lib)) { |
| lib <- .libPaths()[1L] |
| message(sprintf(ngettext(length(pkgs), |
| "Removing package from %s\n(as %s is unspecified)", |
| "Removing packages from %s\n(as %s is unspecified)"), |
| sQuote(lib), sQuote("lib")), domain = NA) |
| } |
| |
| paths <- find.package(pkgs, lib) |
| if(length(paths)) { |
| unlink(paths, TRUE) |
| for(lib in unique(dirname(paths))) updateIndices(lib) |
| } |
| invisible() |
| } |
| |
| download.packages <- function(pkgs, destdir, available = NULL, |
| repos = getOption("repos"), |
| contriburl = contrib.url(repos, type), |
| method, type = getOption("pkgType"), ...) |
| { |
| nonlocalcran <- !all(startsWith(contriburl, "file:")) |
| if(nonlocalcran && !dir.exists(destdir)) |
| stop("'destdir' is not a directory") |
| |
| type <- resolvePkgType(type) |
| |
| if(is.null(available)) |
| available <- |
| available.packages(contriburl = contriburl, method = method, ...) |
| |
| retval <- matrix(character(), 0L, 2L) |
| for(p in unique(pkgs)) |
| { |
| ok <- (available[,"Package"] == p) |
| ok <- ok & !is.na(ok) |
| if(!any(ok)) |
| warning(gettextf("no package %s at the repositories", sQuote(p)), |
| domain = NA, immediate. = TRUE) |
| else { |
| if(sum(ok) > 1L) { # have multiple copies |
| vers <- package_version(available[ok, "Version"]) |
| keep <- vers == max(vers) |
| keep[duplicated(keep)] <- FALSE |
| ok[ok][!keep] <- FALSE |
| } |
| if (startsWith(type, "mac.binary")) type <- "mac.binary" |
| ## in Oct 2009 we introduced file names in PACKAGES files |
| File <- available[ok, "File"] |
| fn <- paste0(p, "_", available[ok, "Version"], |
| switch(type, |
| "source" = ".tar.gz", |
| "mac.binary" = ".tgz", |
| "win.binary" = ".zip")) |
| have_fn <- !is.na(File) |
| fn[have_fn] <- File[have_fn] |
| repos <- available[ok, "Repository"] |
| if(startsWith(repos, "file:")) { # local repository |
| ## This could be file: + file path or a file:/// URL. |
| if(startsWith(repos, "file:///")) { |
| ## We need to derive the file name from the URL |
| ## This is tricky as so many forms have been allowed, |
| ## and indeed external methods may do even more. |
| fn <- paste(substring(repos, 8L), fn, sep = "/") |
| ## This leaves a path beginning with / |
| if(.Platform$OS.type == "windows") { |
| if(length(grep("^/[A-Za-z]:", fn))) |
| fn <- substring(fn, 2L) |
| } |
| } else { |
| fn <- paste(substring(repos, 6L), fn, sep = "/") |
| } |
| if(file.exists(fn)) |
| retval <- rbind(retval, c(p, fn)) |
| else |
| warning(gettextf("package %s does not exist on the local repository", sQuote(p)), |
| domain = NA, immediate. = TRUE) |
| } else { |
| url <- paste(repos, fn, sep = "/") |
| destfile <- file.path(destdir, fn) |
| |
| res <- try(download.file(url, destfile, method, mode = "wb", |
| ...)) |
| if(!inherits(res, "try-error") && res == 0L) |
| retval <- rbind(retval, c(p, destfile)) |
| else |
| warning(gettextf("download of package %s failed", sQuote(p)), |
| domain = NA, immediate. = TRUE) |
| } |
| } |
| } |
| |
| retval |
| } |
| |
| resolvePkgType <- function(type) { |
| ## Not entirely clear this is optimal |
| if(type == "both") type <- "source" |
| else if(type == "binary") type <- .Platform$pkgType |
| type |
| } |
| |
| contrib.url <- function(repos, type = getOption("pkgType")) |
| { |
| type <- resolvePkgType(type) |
| if(is.null(repos)) return(NULL) |
| if("@CRAN@" %in% repos && interactive()) { |
| cat(gettext("--- Please select a CRAN mirror for use in this session ---"), |
| "\n", sep = "") |
| flush.console() |
| chooseCRANmirror() |
| m <- match("@CRAN@", repos) |
| nm <- names(repos) |
| repos[m] <- getOption("repos")["CRAN"] |
| if(is.null(nm)) nm <- rep.int("", length(repos)) |
| nm[m] <- "CRAN" |
| names(repos) <- nm |
| } |
| if("@CRAN@" %in% repos) stop("trying to use CRAN without setting a mirror") |
| |
| ver <- paste(R.version$major, |
| strsplit(R.version$minor, ".", fixed=TRUE)[[1L]][1L], sep = ".") |
| mac.path <- "macosx" |
| if (substr(type, 1L, 11L) == "mac.binary.") { |
| mac.path <- paste(mac.path, substring(type, 12L), sep = "/") |
| type <- "mac.binary" |
| } |
| res <- switch(type, |
| "source" = paste(gsub("/$", "", repos), "src", "contrib", sep = "/"), |
| "mac.binary" = paste(gsub("/$", "", repos), "bin", mac.path, "contrib", ver, sep = "/"), |
| "win.binary" = paste(gsub("/$", "", repos), "bin", "windows", "contrib", ver, sep = "/") |
| ) |
| res |
| } |
| |
| .getMirrors <- function(url, local.file, all, local.only) |
| { |
| m <- NULL |
| if(!local.only) { |
| ## Try to handle explicitly failure to connect to CRAN. |
| f <- tempfile() |
| on.exit(unlink(f)) |
| m <- tryCatch({ |
| m <- download.file(url, destfile = f, quiet = TRUE) |
| if(m != 0L) |
| stop(gettextf("'download.file()' error code '%d'", m)) |
| read.csv(f, as.is = TRUE, encoding = "UTF-8") |
| }, error=function(err) { |
| warning(gettextf("failed to download mirrors file (%s); using local file '%s'", |
| conditionMessage(err), local.file), |
| call.=FALSE, immediate.=TRUE) |
| NULL |
| }) |
| } |
| if(is.null(m)) |
| m <- read.csv(local.file, as.is = TRUE, encoding = "UTF-8") |
| if(!all) m <- m[as.logical(m$OK), ] |
| m |
| } |
| |
| getCRANmirrors <- function(all = FALSE, local.only = FALSE) |
| { |
| .getMirrors("https://cran.r-project.org/CRAN_mirrors.csv", |
| file.path(R.home("doc"), "CRAN_mirrors.csv"), |
| all = all, local.only = local.only) |
| } |
| |
| .chooseMirror <- function(m, label, graphics, ind) |
| { |
| if(is.null(ind) && !interactive()) |
| stop("cannot choose a ", label, " mirror non-interactively") |
| if (length(ind)) |
| res <- as.integer(ind)[1L] |
| else { |
| isHTTPS <- (startsWith(m[, "URL"], "https") & |
| grepl("secure_mirror_from_master", |
| m[, "Comment"], |
| fixed = TRUE)) |
| mHTTPS <- m[isHTTPS,] |
| mHTTP <- m[!isHTTPS,] |
| httpsLabel <- paste("Secure", label, "mirrors") |
| httpLabel <- paste("Other", label, "mirrors") |
| m <- mHTTPS |
| res <- menu(c(m[, 1L], "(other mirrors)"), graphics, httpsLabel) |
| if (res > nrow(m)) { |
| m <- mHTTP |
| res <- menu(m[, 1L], graphics, httpLabel) |
| } |
| } |
| if (res > 0L) { |
| URL <- m[res, "URL"] |
| names(URL) <- m[res, "Name"] |
| sub("/$", "", URL[1L]) |
| } else character() |
| } |
| |
| chooseCRANmirror <- function(graphics = getOption("menu.graphics"), ind = NULL, |
| local.only = FALSE) |
| { |
| m <- getCRANmirrors(all = FALSE, local.only = local.only) |
| url <- .chooseMirror(m, "CRAN", graphics, ind) |
| if (length(url)) { |
| repos <- getOption("repos") |
| repos["CRAN"] <- url |
| options(repos = repos) |
| } |
| invisible() |
| } |
| |
| chooseBioCmirror <- function(graphics = getOption("menu.graphics"), ind = NULL, |
| local.only = FALSE) |
| { |
| m <- .getMirrors("https://bioconductor.org/BioC_mirrors.csv", |
| file.path(R.home("doc"), "BioC_mirrors.csv"), |
| all = FALSE, local.only = local.only) |
| url <- .chooseMirror(m, "BioC", graphics, ind) |
| if (length(url)) |
| options(BioC_mirror = url) |
| invisible() |
| } |
| |
| setRepositories <- |
| function(graphics = getOption("menu.graphics"), ind = NULL, |
| addURLs = character()) |
| { |
| if(is.null(ind) && !interactive()) |
| stop("cannot set repositories non-interactively") |
| a <- tools:::.get_repositories() |
| pkgType <- getOption("pkgType") |
| if (pkgType == "both") pkgType <- "source" #.Platform$pkgType |
| if (pkgType == "binary") pkgType <- .Platform$pkgType |
| if(startsWith(pkgType, "mac.binary")) pkgType <- "mac.binary" |
| thisType <- a[[pkgType]] |
| a <- a[thisType, 1L:3L] |
| repos <- getOption("repos") |
| ## Now look for CRAN and any others in getOptions("repos") |
| if("CRAN" %in% row.names(a) && !is.na(CRAN <- repos["CRAN"])) |
| a["CRAN", "URL"] <- CRAN |
| ## Set as default any already in the option. |
| a[(a[["URL"]] %in% repos), "default"] <- TRUE |
| new <- !(repos %in% a[["URL"]]) |
| if(any(new)) { |
| aa <- names(repos[new]) |
| if(is.null(aa)) aa <- rep.int("", length(repos[new])) |
| aa[aa == ""] <- repos[new][aa == ""] |
| newa <- data.frame(menu_name=aa, URL=repos[new], default=TRUE) |
| row.names(newa) <- aa |
| a <- rbind(a, newa, deparse.level = 0L) |
| } |
| |
| default <- a[["default"]] |
| |
| res <- if(length(ind)) as.integer(ind) |
| else { |
| title <- if(graphics) "Repositories" else gettext("--- Please select repositories for use in this session ---\n") |
| match(select.list(a[, 1L], a[default, 1L], multiple = TRUE, title, |
| graphics = graphics), a[, 1L]) |
| } |
| if(length(res) || length(addURLs)) { |
| repos <- a[["URL"]] |
| names(repos) <- row.names(a) |
| repos <- c(repos[res], addURLs) |
| options(repos = repos) |
| } |
| } |
| |
| |
| |
| ## used in some BioC packages and their support in tools. |
| compareVersion <- function(a, b) |
| { |
| if(is.na(a)) return(-1L) |
| if(is.na(b)) return(1L) |
| a <- as.integer(strsplit(a, "[.-]")[[1L]]) |
| b <- as.integer(strsplit(b, "[.-]")[[1L]]) |
| for(k in seq_along(a)) |
| if(k <= length(b)) { |
| if(a[k] > b[k]) return(1) else if(a[k] < b[k]) return(-1L) |
| } else return(1L) |
| if(length(b) > length(a)) return(-1L) else return(0L) |
| } |
| |
| ## ------------- private functions -------------------- |
| .clean_up_dependencies <- function(x, available = NULL) |
| { |
| ## x is a character vector of Depends / Suggests / Imports entries |
| ## returns a character vector of all the package dependencies mentioned |
| x <- x[!is.na(x)] |
| if(!length(x)) return(x) |
| x <- unlist(strsplit(x, ",")) |
| unique(sub("^[[:space:]]*([[:alnum:].]+).*$", "\\1" , x)) |
| } |
| |
| .clean_up_dependencies2 <- function(x, installed, available) |
| { |
| ## x is a character vector of Depends / Suggests / Imports entries. |
| ## Returns a list of length 2, a character vector of the names of |
| ## all the package dependencies mentioned that are not already |
| ## satisfied and one of those which cannot be satisfied (possibly |
| ## of the form "pkg (>= ver)') |
| |
| .split_dependencies <- function(x) { |
| .split2 <- function(x) { |
| ## some have had space before , |
| x <- sub('[[:space:]]+$', '', x) |
| x <- unique(sub("^[[:space:]]*(.*)", "\\1" , x)) |
| names(x) <- sub("^([[:alnum:].]+).*$", "\\1" , x) |
| x <- x[names(x) != "R"] |
| x <- x[nzchar(x)] |
| ## FIXME: a better way to handle duplicates. |
| ## However, there should not be any, and if there are |
| ## Depends: should be the first. |
| x <- x[!duplicated(names(x))] |
| lapply(x, tools:::.split_op_version) |
| } |
| ## given one of more concatenations of Depends/Imports/Suggests fields, |
| ## return a named list of list(name, [op, version]) |
| if(!any(nzchar(x))) return(list()) |
| unlist(lapply(strsplit(x, ","), .split2), FALSE, FALSE) |
| } |
| x <- x[!is.na(x)] |
| if(!length(x)) return(list(character(), character())) |
| xx <- .split_dependencies(x) |
| if(!length(xx)) return(list(character(), character())) |
| ## Then check for those we already have installed |
| pkgs <- installed[, "Package"] |
| have <- sapply(xx, function(x) { |
| if(length(x) == 3L) { |
| if (! x[[1L]] %in% pkgs ) return(FALSE) |
| if(x[[2L]] != ">=") return(TRUE) |
| ## We may have the package installed more than once |
| ## which we get will depend on the .libPaths() order, |
| ## so for now just see if any installed version will do. |
| current <- as.package_version(installed[pkgs == x[[1L]], "Version"]) |
| target <- as.package_version(x[[3L]]) |
| any(do.call(x$op, list(current, target))) |
| ## eval(parse(text = paste("any(current", x$op, "target)"))) |
| } else x[[1L]] %in% pkgs |
| }) |
| xx <- xx[!have] |
| if(!length(xx)) return(list(character(), character())) |
| ## now check if we can satisfy the missing dependencies |
| pkgs <- row.names(available) |
| canget <- miss <- character() |
| for (i in seq_along(xx)) { |
| x <- xx[[i]] |
| if(length(x) == 3L) { |
| if (! x[[1L]] %in% pkgs ) { miss <- c(miss, x[[1L]]); next } |
| if(x[[2L]] != ">=") { canget <- c(canget, x[[1L]]); next } |
| ## we may have the package available more than once |
| ## install.packages() will find the highest version. |
| current <- as.package_version(available[pkgs == x[[1L]], "Version"]) |
| target <- as.package_version(x[[3L]]) |
| res <- any(do.call(x$op, list(current, target))) |
| ## res <- eval(parse(text = paste("any(current", x$op, "target)"))) |
| if(res) canget <- c(canget, x[[1L]]) |
| else miss <- c(miss, paste0(x[[1L]], " (>= ", x[[3L]], ")")) |
| } else if(x[[1L]] %in% pkgs) canget <- c(canget, x[[1L]]) |
| else miss <- c(miss, x[[1L]]) |
| } |
| list(canget, miss) |
| } |
| |
| .make_dependency_list <- |
| function(pkgs, available, |
| dependencies = c("Depends", "Imports", "LinkingTo"), |
| recursive = FALSE) |
| { |
| ## given a character vector of packages, |
| ## return a named list of character vectors of their dependencies. |
| ## If recursive = TRUE, do this recursively. |
| if(!length(pkgs)) return(NULL) |
| if(is.null(available)) |
| stop(gettextf("%s must be supplied", sQuote("available")), domain = NA) |
| info <- available[pkgs, dependencies, drop = FALSE] |
| x <- vector("list", length(pkgs)); names(x) <- pkgs |
| if(recursive) { |
| known <- row.names(available) |
| xx <- vector("list", length(known)); names(xx) <- known |
| info2 <- available[, dependencies, drop = FALSE] |
| for (i in seq_along(known)) |
| xx[[i]] <- .clean_up_dependencies(info2[i, ]) |
| for (i in pkgs) { |
| p <- xx[[i]] |
| p <- p[p %in% known]; p1 <- p |
| repeat { |
| extra <- unlist(xx[p1]) |
| extra <- extra[extra != i] |
| extra <- extra[extra %in% known] |
| deps <- unique(c(p, extra)) |
| if (length(deps) <= length(p)) break |
| p1 <- deps[!deps %in% p] |
| p <- deps |
| } |
| x[[i]] <- p |
| } |
| } else { |
| for (i in seq_along(pkgs)) x[[i]] <- .clean_up_dependencies(info[i, ]) |
| } |
| x |
| } |
| |
| .find_install_order <- function(pkgs, dependencyList) |
| { |
| ## given a character vector of packages, find an install order |
| ## which reflects their dependencies. |
| DL <- dependencyList[pkgs] |
| ## some of the packages may be already installed, but the |
| ## dependencies apply to those being got from CRAN. |
| DL <- lapply(DL, function(x) x[x %in% pkgs]) |
| lens <- lengths(DL) |
| if(all(lens > 0L)) { |
| warning("every package depends on at least one other") |
| return(pkgs) |
| } |
| done <- names(DL[lens == 0L]); DL <- DL[lens > 0L] |
| while(length(DL)) { |
| OK <- vapply(DL, function(x) all(x %in% done), NA) |
| if(!any(OK)) { |
| warning(gettextf("packages %s are mutually dependent", |
| paste(sQuote(names(DL)), collapse = ", ")), |
| domain = NA) |
| return(c(done, names(DL))) |
| } |
| done <- c(done, names(DL[OK])) |
| DL <- DL[!OK] |
| } |
| done |
| } |
