The R Project SVN
R
(root)/branches/R-structure/src/library/utils/R/packages2.R – Rev 81438
Rev 81425 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
# File src/library/utils/R/packages2.R# Part of the R package, https://www.R-project.org## Copyright (C) 1995-2022 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/if (.Platform$OS.type == "windows").install.macbinary <- function(...) NULL # globalVariables isn't available, so use this to suppress the warningisBasePkg <- function(pkg) {priority <- tryCatch(packageDescription(pkg, fields = "Priority"),error = function(e) e, warning = function(e) e)identical(priority, "base")}getDependencies <-function(pkgs, dependencies = NA, available = NULL, lib = .libPaths()[1L],binary = FALSE, ..., av2 = NULL) ## ... is passed to installed.packages().{if (is.null(dependencies)) return(unique(pkgs))oneLib <- length(lib) == 1Ldep2 <- NULLif(is.logical(dependencies) && is.na(dependencies))dependencies <- c("Depends", "Imports", "LinkingTo")depends <-is.character(dependencies) || (is.logical(dependencies) && dependencies)if(depends && is.logical(dependencies)) {if(binary) {dependencies <- c("Depends", "Imports", "Suggests")dep2 <- c("Depends", "Imports")} else {dependencies <- c("Depends", "Imports", "LinkingTo", "Suggests")dep2 <- c("Depends", "Imports", "LinkingTo")}}if(depends && !oneLib) {warning("Do not know which element of 'lib' to install dependencies into\nskipping dependencies")depends <- FALSE}p0 <- unique(pkgs)miss <- !p0 %in% row.names(available)base <- vapply(p0, isBasePkg, FALSE)if (sum(base))warning(sprintf(ngettext(sum(base),"package %s is a base package, and should not be updated","packages %s are base packages, and should not be updated"),paste(sQuote(p0[base]), collapse = ", ")),domain = NA, call. = FALSE)m0 <- miss & !basemsg2 <- NULLif(sum(m0) && !is.null(av2)) {keep <- rownames(av2) %in% p0[m0] ## there might be duplicate matchesav2 <- av2[keep, , drop = FALSE]if(nrow(av2)) {ds <- av2[, "Depends"]ds[is.na(ds)] <- ""x <- lapply(strsplit(sub("^[[:space:]]*", "", ds),"[[:space:]]*,[[:space:]]*"),function(s) s[grepl("^R[[:space:]]*\\(", s)])lens <- lengths(x)pos <- which(lens > 0L)av2 <- av2[pos,, drop = FALSE]; x <- x[pos]msg2 <- paste(sQuote(av2[, "Package"]), "version", av2[, "Version"],"is in the repositories but depends on", unlist(x))}}if(sum(m0)) {msg <- paste0(if(binary) "as a binary package ","for this version of R")msg3 <- c(paste0(ngettext(sum(m0),"A version of this package for your version of R might be available elsewhere,\nsee the ideas at\n","Versions of these packages for your version of R might be available elsewhere,\nsee the ideas at\n"),## refer to r-patched for released/patched versionsif (grepl("Under development", R.version.string)) {"https://cran.r-project.org/doc/manuals/r-devel/R-admin.html#Installing-packages"} else {"https://cran.r-project.org/doc/manuals/r-patched/R-admin.html#Installing-packages"}))warning(sprintf(ngettext(sum(m0),"package %s is not available %s","packages %s are not available %s"),paste(sQuote(p0[m0]), collapse = ", "),paste(c(msg, msg2, "", msg3), collapse = "\n")),domain = NA, call. = FALSE)if (sum(m0) == 1L &&!is.na(w <- match(tolower(p0[m0]),tolower(row.names(available))))) {warning(sprintf("Perhaps you meant %s ?",sQuote(row.names(available)[w])),call. = FALSE, domain = NA)}flush.console()}p0 <- p0[!miss]if(depends && length(p0)) { # check for dependencies, recursivelyp1 <- p0 # this is ok, as 1 lib only## INSTALL prepends 'lib' to the libpath## Here we are slightly more conservativelibpath <- .libPaths()if(!lib %in% libpath) libpath <- c(lib, libpath)installed <- installed.packages(lib.loc = libpath,fields = c("Package", "Version"),...)not_avail <- character()repeat {deps <- apply(available[p1, dependencies, drop = FALSE],1L, function(x) paste(x[!is.na(x)], collapse=", "))res <- .clean_up_dependencies2(deps, installed, available)not_avail <- c(not_avail, res[[2L]])deps <- unique(res[[1L]])## R should not get to here, but be safedeps <- deps[!deps %in% c("R", pkgs)]if(!length(deps)) breakpkgs <- c(deps, pkgs)p1 <- depsif(!is.null(dep2)) { dependencies <- dep2; dep2 <- NULL }}if(length(not_avail)) {not_avail <- unique(not_avail)warning(sprintf(ngettext(length(not_avail),"dependency %s is not available","dependencies %s are not available"),paste(sQuote(not_avail), collapse=", ")),domain = NA, call. = FALSE, immediate. = TRUE)flush.console()}pkgs <- unique(pkgs)pkgs <- pkgs[pkgs %in% row.names(available)]if(length(pkgs) > length(p0)) {added <- setdiff(pkgs, p0)message(sprintf(ngettext(length(added),"also installing the dependency %s","also installing the dependencies %s"),paste(sQuote(added), collapse=", ")),"\n", domain = NA)flush.console()}p0 <- pkgs}p0}install.packages <-function(pkgs, lib, repos = getOption("repos"),contriburl = contrib.url(repos, type),method, available = NULL, destdir = NULL, dependencies = NA,type = getOption("pkgType"),configure.args = getOption("configure.args"),configure.vars = getOption("configure.vars"),clean = FALSE, Ncpus = getOption("Ncpus", 1L),verbose = getOption("verbose"),libs_only = FALSE, INSTALL_opts, quiet = FALSE,keep_outputs = FALSE,...){if (!is.character(type))stop("invalid 'type'; must be a character string")type2 <- .Platform$pkgTypeif (type == "binary") {if (type2 == "source")stop("type 'binary' is not supported on this platform")else type <- type2if(type == "both" && (!missing(contriburl) || !is.null(available)))stop("specifying 'contriburl' or 'available' requires a single type, not type = \"both\"")}if (is.logical(clean) && clean)clean <- "--clean"if(is.logical(dependencies) && is.na(dependencies))dependencies <- if(!missing(lib) && length(lib) > 1L) FALSEelse c("Depends", "Imports", "LinkingTo")## Compute the configuration arguments for a given package.## If configure.args is an unnamed character vector, use that.## If it is named, match the pkg name to the names of the character## vector and if we get a match, use that element.## Similarly, configure.args is a list(), match pkg to the names pkg## and use that element, collapsing it into a single string.get_package_name <- function(pkg) {## Since the pkg argument can be the name of a file rather than## a regular package name, we have to clean that up.gsub("_[.](zip|tar[.]gz|tar[.]bzip2|tar[.]xz)", "",gsub(.standard_regexps()$valid_package_version, "",basename(pkg)))}getConfigureArgs <- function(pkg){if(.Platform$OS.type == "windows") return(character())if(length(pkgs) == 1L && length(configure.args) &&length(names(configure.args)) == 0L)return(paste0("--configure-args=",shQuote(paste(configure.args, collapse = " "))))pkg <- get_package_name(pkg)if (length(configure.args) && length(names(configure.args))&& pkg %in% names(configure.args))config <- paste0("--configure-args=",shQuote(paste(configure.args[[ pkg ]], collapse = " ")))elseconfig <- character()config}getConfigureVars <- function(pkg){if(.Platform$OS.type == "windows") return(character())if(length(pkgs) == 1L && length(configure.vars) &&length(names(configure.vars)) == 0L)return(paste0("--configure-vars=",shQuote(paste(configure.vars, collapse = " "))))pkg <- get_package_name(pkg)if (length(configure.vars) && length(names(configure.vars))&& pkg %in% names(configure.vars))config <- paste0("--configure-vars=",shQuote(paste(configure.vars[[ pkg ]], collapse = " ")))elseconfig <- character()config}get_install_opts <- function(pkg) {if(!length(INSTALL_opts))character()elsepaste(INSTALL_opts[[get_package_name(pkg)]], collapse = " ")}if(missing(pkgs)) {if(!interactive()) stop("no packages were specified")## if no packages were specified, use a menuif(.Platform$OS.type == "windows" || .Platform$GUI == "AQUA"|| (capabilities("tcltk")&& capabilities("X11") && suppressWarnings(tcltk::.TkUp)) ) {## this is the condition for a graphical select.list()} elsestop("no packages were specified")## This will only offer the specified type. If type = "both"## do not want 'available' set for "source".if(is.null(available)) {av <- available.packages(contriburl = contriburl, method = method,...)if (missing(repos)) ## Evaluating contriburl may have changed repos, which may be used belowrepos <- getOption("repos")if(type != "both") available <- av} else av <- availableif(NROW(av)) {## avoid duplicate entries in menus, since the latest available## will be picked up## sort in the locale, as R <= 2.10.1 did sopkgs <- select.list(sort(unique(rownames(av))),multiple = TRUE,title = "Packages", graphics = TRUE)}}if (.Platform$OS.type == "windows" && length(pkgs)) {## look for package in use.pkgnames <- get_package_name(pkgs)## there is no guarantee we have got the package name right:## foo.zip might contain package bar or Foo or FOO or ....## but we can't tell without trying to unpack it.inuse <- search()inuse <- sub("^package:", "", inuse[grep("^package:", inuse)])inuse <- pkgnames %in% inuseif(any(inuse)) {warning(sprintf(ngettext(sum(inuse),"package %s is in use and will not be installed","packages %s are in use and will not be installed"),paste(sQuote(pkgnames[inuse]), collapse=", ")),call. = FALSE, domain = NA, immediate. = TRUE)pkgs <- pkgs[!inuse]}}if(!length(pkgs)) return(invisible())if(missing(lib) || is.null(lib)) {lib <- .libPaths()[1L]if(!quiet && length(.libPaths()) > 1L)message(sprintf(ngettext(length(pkgs),"Installing package into %s\n(as %s is unspecified)","Installing packages into %s\n(as %s is unspecified)"),sQuote(lib), sQuote("lib")), domain = NA)}## check for writability by userok <- dir.exists(lib) & (file.access(lib, 2) == 0L)if(length(lib) > 1 && any(!ok))stop(sprintf(ngettext(sum(!ok),"'lib' element %s is not a writable directory","'lib' elements %s are not writable directories"),paste(sQuote(lib[!ok]), collapse=", ")), domain = NA)if(length(lib) == 1L && .Platform$OS.type == "windows") {## file.access is unreliable on Windows, especially >= Vista.## the only known reliable way is to try itok <- dir.exists(lib) # dir might not exist, PR#14311if(ok) {fn <- file.path(lib, paste0("_test_dir_", Sys.getpid()))unlink(fn, recursive = TRUE) # precautionres <- try(dir.create(fn, showWarnings = FALSE))if(inherits(res, "try-error") || !res) ok <- FALSEelse unlink(fn, recursive = TRUE)}}if(length(lib) == 1L && !ok) {warning(gettextf("'lib = \"%s\"' is not writable", lib),domain = NA, immediate. = TRUE)userdir <- unlist(strsplit(Sys.getenv("R_LIBS_USER"),.Platform$path.sep))[1L]if(interactive()) {ans <- askYesNo(gettext("Would you like to use a personal library instead?"), default = FALSE)if(!isTRUE(ans)) stop("unable to install packages")lib <- userdirif(!file.exists(userdir)) {ans <- askYesNo(gettextf("Would you like to create a personal library\n%s\nto install packages into?",sQuote(userdir)), default = FALSE)if(!isTRUE(ans)) stop("unable to install packages")if(!dir.create(userdir, recursive = TRUE))stop(gettextf("unable to create %s", sQuote(userdir)),domain = NA).libPaths(c(userdir, .libPaths()))}} else stop("unable to install packages")}lib <- normalizePath(lib)## check if we should infer repos = NULLif(length(pkgs) == 1L && missing(repos) && missing(contriburl)) {if((type == "source" && any(grepl("[.]tar[.](gz|bz2|xz)$", pkgs))) ||(type %in% "win.binary" && endsWith(pkgs, ".zip")) ||(startsWith(type, "mac.binary") && endsWith(pkgs, ".tgz"))) {repos <- NULLmessage("inferring 'repos = NULL' from 'pkgs'")}if (type == "both") {if (type2 %in% "win.binary" && endsWith(pkgs, ".zip")) {repos <- NULLtype <- type2message("inferring 'repos = NULL' from 'pkgs'")} else if (startsWith(type2, "mac.binary")&& endsWith(pkgs, ".tgz")) {repos <- NULLtype <- type2message("inferring 'repos = NULL' from 'pkgs'")} else if (grepl("[.]tar[.](gz|bz2|xz)$", pkgs)) {repos <- NULLtype <- "source"message("inferring 'repos = NULL' from 'pkgs'")}}}## check if we should infer the typeif (length(pkgs) == 1L && is.null(repos) && type == "both") {if ( (type2 %in% "win.binary" && endsWith(pkgs, ".zip"))||(startsWith(type2, "mac.binary")&& endsWith(pkgs, ".tgz"))) {type <- type2} else if (grepl("[.]tar[.](gz|bz2|xz)$", pkgs)) {type <- "source"}}if(is.null(repos) && missing(contriburl)) {tmpd <- destdirnonlocalrepos <- any(web <- grepl("^(http|https|ftp)://", pkgs))if(is.null(destdir) && nonlocalrepos) {tmpd <- file.path(tempdir(), "downloaded_packages")if (!file.exists(tmpd) && !dir.create(tmpd))stop(gettextf("unable to create temporary directory %s",sQuote(tmpd)),domain = NA)}if(nonlocalrepos) {df <- function(p, destfile, method, ...)download.file(p, destfile, method, mode = "wb", ...)urls <- pkgs[web]for (p in unique(urls)) {this <- pkgs == pdestfile <- file.path(tmpd, basename(p))res <- try(df(p, destfile, method, ...))if(!inherits(res, "try-error") && res == 0L)pkgs[this] <- destfileelse {## There will be enough notification from the try()pkgs[this] <- NA}}}}## Look at type == "both"## NB it is only safe to use binary packages with a macOS## build that uses the same R foundation layout as CRAN since## paths in DSOs are hard-coded.if (type == "both") {if (type2 == "source")stop("type == \"both\" can only be used on Windows or a CRAN build for macOS")if (!missing(contriburl) || !is.null(available)) type <- type2}getDeps <- TRUEif (type == "both") {if(is.null(repos))stop("type == \"both\" cannot be used with 'repos = NULL'")type <- "source"contriburl <- contrib.url(repos, "source")## The line above may have changed the repos option, so ...if (missing(repos)) repos <- getOption("repos")available <-available.packages(contriburl = contriburl, method = method,fields = "NeedsCompilation", ...)pkgs <- getDependencies(pkgs, dependencies, available, lib, ...)getDeps <- FALSE## Now see what we can get as binary packages.av2 <- available.packages(contriburl = contrib.url(repos, type2),method = method, ...)bins <- row.names(av2)bins <- pkgs[pkgs %in% bins]srcOnly <- pkgs[! pkgs %in% bins]binvers <- av2[bins, "Version"]## In most cases, packages that need compilation have non-NA "Archs"## in their binary version and "NeedsCompilation" with value "yes"## in their source version. However, the fields are not always## filled in correctly and some binary packages have executable code## outside "libs" (so "Archs" is NA), also a later version of a## package may need compilation but an older one not. To reduce the## risk that the user will attempt to install a package from source## but without having the necessary tools to build it, packages are## treated as needing compilation whenever they have non-NA "Archs"## in binary version or/and "NeedsCompilation"="yes" in source## version.hasArchs <- !is.na(av2[bins, "Archs"])needsCmp <- !(available[bins, "NeedsCompilation"] %in% "no")hasSrc <- hasArchs | needsCmpsrcvers <- available[bins, "Version"]later <- as.numeric_version(binvers) < srcversaction <- getOption("install.packages.compile.from.source","interactive")if(!nzchar(Sys.which(Sys.getenv("MAKE", "make")))) action <- "never"if(any(later)) {msg <- ngettext(sum(later),"There is a binary version available but the source version is later","There are binary versions available but the source versions are later")cat("\n",paste(strwrap(msg, indent = 2, exdent = 2), collapse = "\n"),":\n", sep = "")out <- data.frame(`binary` = binvers, `source` = srcvers,`needs_compilation` = hasSrc,row.names = bins,check.names = FALSE)[later, ]print(out)cat("\n")if(any(later & hasSrc)) {if(action == "interactive" && interactive()) {msg <-ngettext(sum(later & hasSrc),"Do you want to install from sources the package which needs compilation?","Do you want to install from sources the packages which need compilation?")res <- askYesNo(msg)if (is.na(res)) stop("Cancelled by user")if(!isTRUE(res)) later <- later & !hasSrc} else if (action == "never") {cat(" Binaries will be installed\n")later <- later & !hasSrc}}}bins <- bins[!later]if(length(srcOnly)) {s2 <- srcOnly[!( available[srcOnly, "NeedsCompilation"] %in% "no" )]if(length(s2)) {msg <-ngettext(length(s2),"Package which is only available in source form, and may need compilation of C/C++/Fortran","Packages which are only available in source form, and may need compilation of C/C++/Fortran")msg <- c(paste0(msg, ": "), sQuote(s2))msg <- strwrap(paste(msg, collapse = " "), exdent = 2)message(paste(msg, collapse = "\n"), domain = NA)if(action == "interactive" && interactive()) {res <- askYesNo("Do you want to attempt to install these from sources?")if (is.na(res)) stop("Cancelled by user")if(!isTRUE(res)) pkgs <- setdiff(pkgs, s2)} else if(action == "never") {cat(" These will not be installed\n")pkgs <- setdiff(pkgs, s2)}}}if(length(bins)) {if(type2 == "win.binary").install.winbinary(pkgs = bins, lib = lib,contriburl = contrib.url(repos, type2),method = method, available = av2,destdir = destdir,dependencies = NULL,libs_only = libs_only,quiet = quiet, ...)else.install.macbinary(pkgs = bins, lib = lib,contriburl = contrib.url(repos, type2),method = method, available = av2,destdir = destdir,dependencies = NULL,quiet = quiet, ...)}pkgs <- setdiff(pkgs, bins)if(!length(pkgs)) return(invisible())message(sprintf(ngettext(length(pkgs),"installing the source package %s","installing the source packages %s"),paste(sQuote(pkgs), collapse=", ")),"\n", domain = NA)flush.console()## end of "both"} else if (getOption("install.packages.check.source", "yes") %in% "yes"&& (type %in% "win.binary" || startsWith(type, "mac.binary"))) {if (missing(contriburl) && is.null(available) && !is.null(repos)) {contriburl2 <- contrib.url(repos, "source")# The line above may have changed the repos option, so..if (missing(repos)) repos <- getOption("repos")av1 <- tryCatch(suppressWarnings(available.packages(contriburl = contriburl2, method = method, ...)),error = function(e)e)if(inherits(av1, "error")) {message("source repository is unavailable to check versions")available <-available.packages(contriburl = contrib.url(repos, type),method = method, ...)} else {srcpkgs <- pkgs[pkgs %in% row.names(av1)]## Now see what we can get as binary packages.available <-available.packages(contriburl = contrib.url(repos, type),method = method, ...)bins <- pkgs[pkgs %in% row.names(available)]## so a package might only be available as source,## or it might be later in source.## FIXME: might only want to check on the same repository,na <- srcpkgs[!srcpkgs %in% bins]if (length(na)) {msg <-sprintf(ngettext(length(na),"package %s is available as a source package but not as a binary","packages %s are available as source packages but not as binaries"),paste(sQuote(na), collapse = ", "))cat("\n ", msg, "\n\n", sep = "")}binvers <- available[bins, "Version"]srcvers <- binversOK <- bins %in% srcpkgssrcvers[OK] <- av1[bins[OK], "Version"]later <- as.numeric_version(binvers) < srcversif(any(later)) {msg <- ngettext(sum(later),"There is a binary version available (and will be installed) but the source version is later","There are binary versions available (and will be installed) but the source versions are later")cat("\n",paste(strwrap(msg, indent = 2, exdent = 2), collapse = "\n"),":\n", sep = "")print(data.frame(`binary` = binvers, `source` = srcvers,row.names = bins,check.names = FALSE)[later, ])cat("\n")}}}}if(.Platform$OS.type == "windows") {if(startsWith(type, "mac.binary"))stop("cannot install macOS binary packages on Windows")if(type %in% "win.binary") {## include local .zip files.install.winbinary(pkgs = pkgs, lib = lib, contriburl = contriburl,method = method, available = available,destdir = destdir,dependencies = dependencies,libs_only = libs_only, quiet = quiet, ...)return(invisible())}## Avoid problems with spaces in pathnames.have_spaces <- grep(" ", pkgs)if(length(have_spaces)) {## we want the short name for the directory,## but not for a .tar.gz, and package names never contain spaces.p <- pkgs[have_spaces]dirs <- shortPathName(dirname(p))pkgs[have_spaces] <- file.path(dirs, basename(p))}## Avoid problems with backslashes## -- will mess up UNC names, but they don't workpkgs <- gsub("\\", "/", pkgs, fixed=TRUE)} else {if(startsWith(type, "mac.binary")) {if(!grepl("darwin", R.version$platform))stop("cannot install macOS binary packages on this platform").install.macbinary(pkgs = pkgs, lib = lib, contriburl = contriburl,method = method, available = available,destdir = destdir,dependencies = dependencies, quiet = quiet, ...)return(invisible())}if(type %in% "win.binary")stop("cannot install Windows binary packages on this platform")if(!file.exists(file.path(R.home("bin"), "INSTALL")))stop("This version of R is not set up to install source packages\nIf it was installed from an RPM, you may need the R-devel RPM")}cmd0 <- file.path(R.home("bin"), "R")args0 <- c("CMD", "INSTALL")output <- if(quiet) FALSE else ""env <- character()tlim <- Sys.getenv("_R_INSTALL_PACKAGES_ELAPSED_TIMEOUT_")tlim <- if(is.na(tlim)) 0 else tools:::get_timeout(tlim)outdir <- getwd()if(is.logical(keep_outputs)) {if(is.na(keep_outputs))keep_outputs <- FALSE} else if(is.character(keep_outputs) &&(length(keep_outputs) == 1L)) {if(!dir.exists(keep_outputs) &&!dir.create(keep_outputs, recursive = TRUE))stop(gettextf("unable to create %s", sQuote(keep_outputs)),domain = NA)outdir <- normalizePath(keep_outputs)keep_outputs <- TRUE} elsestop(gettextf("invalid %s argument", sQuote("keep_outputs")),domain = NA)## we need to ensure that R CMD INSTALL runs with the same## library trees, i.e., .R_LIBS() as this session.## FIXME: At least on Windows, either run sub-R directly (to avoid sh)## or run the install in the current process.if(length(libpath <- .R_LIBS())) {## <NOTE>## For the foreseeable future, the 'env' argument to system2()## on Windows is limited to calls to make and rterm (but not R## CMD): hence need to set the R_LIBS env var here.if(.Platform$OS.type == "windows") {## We don't have a way to set an environment variable for## a single command, as we do not spawn a shell.oldrlibs <- Sys.getenv("R_LIBS")Sys.setenv(R_LIBS = libpath)on.exit(Sys.setenv(R_LIBS = oldrlibs))} elseenv <- paste0("R_LIBS=", shQuote(libpath))## </NOTE>}if (is.character(clean))args0 <- c(args0, clean)if (libs_only)args0 <- c(args0, "--libs-only")if (!missing(INSTALL_opts)) {if(!is.list(INSTALL_opts)) {args0 <- c(args0, paste(INSTALL_opts, collapse = " "))INSTALL_opts <- list()}} else {INSTALL_opts <- list()}if(verbose)message(gettextf("system (cmd0): %s",paste(c(cmd0, args0), collapse = " ")),domain = NA)if(is.null(repos) && missing(contriburl)) {## install from local source tarball(s)update <- cbind(path.expand(pkgs), lib) # for side-effect of recycling to same lengthfor(i in seq_len(nrow(update))) {if (is.na(update[i, 1L])) nextargs <- c(args0,get_install_opts(update[i, 1L]),"-l", shQuote(update[i, 2L]),getConfigureArgs(update[i, 1L]),getConfigureVars(update[i, 1L]),shQuote(update[i, 1L]))status <- system2(cmd0, args, env = env,stdout = output, stderr = output,timeout = tlim)## if this times out it will leave locks behindif(status > 0L)warning(gettextf("installation of package %s had non-zero exit status",sQuote(update[i, 1L])),domain = NA)else if(verbose) {cmd <- paste(c(cmd0, args), collapse = " ")message(sprintf("%d): succeeded '%s'", i, cmd), domain = NA)}}return(invisible())}tmpd <- destdirnonlocalrepos <- !all(startsWith(contriburl, "file:"))if(is.null(destdir) && nonlocalrepos) {tmpd <- file.path(tempdir(), "downloaded_packages")if (!file.exists(tmpd) && !dir.create(tmpd))stop(gettextf("unable to create temporary directory %s",sQuote(tmpd)),domain = NA)}## from here on we deal with source packages in reposav2 <- NULLif(is.null(available)) {filters <- getOption("available_packages_filters")if(!is.null(filters)) {available <- available.packages(contriburl = contriburl,method = method, ...)} else {f <- setdiff(available_packages_filters_default,c("R_version", "duplicates"))av2 <- available.packages(contriburl = contriburl, filters = f,method = method, ...)f <- available_packages_filters_db[["R_version"]]f2 <- available_packages_filters_db[["duplicates"]]available <- f2(f(av2))}}if(getDeps) ## true except for type = "both" above.pkgs <- getDependencies(pkgs, dependencies, available, lib, ...,av2 = av2)foundpkgs <- download.packages(pkgs, destdir = tmpd, available = available,contriburl = contriburl, method = method,type = "source", quiet = quiet, ...)## at this point 'pkgs' may contain duplicates,## the same pkg in different libsif(length(foundpkgs)) {if(verbose) message(gettextf("foundpkgs: %s",paste(foundpkgs, collapse=", ")),domain = NA)update <- unique(cbind(pkgs, lib))colnames(update) <- c("Package", "LibPath")found <- pkgs %in% foundpkgs[, 1L]files <- foundpkgs[match(pkgs[found], foundpkgs[, 1L]), 2L]if(verbose) message(gettextf("files: %s",paste(files, collapse=", \n\t")),domain = NA)update <- cbind(update[found, , drop=FALSE], file = files)if(nrow(update) > 1L) {upkgs <- unique(pkgs <- update[, 1L])DL <- .make_dependency_list(upkgs, available)p0 <- .find_install_order(upkgs, DL)## can't use update[p0, ] due to possible multiple matchesupdate <- update[sort.list(match(pkgs, p0)), ]}if (Ncpus > 1L && nrow(update) > 1L) {tlim_cmd <- character()if(tlim > 0) {if(nzchar(timeout <- Sys.which("timeout"))) {## SIGINT works better and is used for system.tlim_cmd <- c(shQuote(timeout), "-s INT", tlim)} elsewarning("timeouts for parallel installs require the 'timeout' command")}## if --no-lock or --lock was specified in INSTALL_opts## that will override this.args0 <- c(args0, "--pkglock")tmpd2 <- file.path(tempdir(), "make_packages")if (!file.exists(tmpd2) && !dir.create(tmpd2))stop(gettextf("unable to create temporary directory %s",sQuote(tmpd2)),domain = NA)mfile <- file.path(tmpd2, "Makefile")conn <- file(mfile, "wt")deps <- paste(paste0(update[, 1L], ".ts"), collapse=" ")deps <- strwrap(deps, width = 75, exdent = 2)deps <- paste(deps, collapse=" \\\n")cat("all: ", deps, "\n", sep = "", file = conn)aDL <- .make_dependency_list(upkgs, available, recursive = TRUE)for(i in seq_len(nrow(update))) {pkg <- update[i, 1L]fil <- update[i, 3L]args <- c(args0,get_install_opts(fil),"-l", shQuote(update[i, 2L]),getConfigureArgs(fil),getConfigureVars(fil),shQuote(fil),">", paste0(pkg, ".out"),"2>&1")## <NOTE>## We currently only use env on Unix for R_LIBS.## Windows we do Sys.setenv(R_LIBS = libpath),## since system2() has limited support for 'env'## Should we use env on Windows as well?## If so, would we need## cmd <- paste(c(shQuote(command), env, args),## collapse = " ")## on Windows?cmd <- paste(c("MAKEFLAGS=",tlim_cmd,shQuote(cmd0),args),collapse = " ")## </NOTE>deps <- aDL[[pkg]]deps <- deps[deps %in% upkgs]## very unlikely to be too longdeps <- if(length(deps))paste(paste0(deps, ".ts"), collapse = " ") else ""cat(paste0(pkg, ".ts: ", deps),paste("\t@echo begin installing package", sQuote(pkg)),paste0("\t@", cmd, " && touch ", pkg, ".ts"),paste0("\t@cat ", pkg, ".out"),"", sep = "\n", file = conn)}close(conn)cwd <- setwd(tmpd2)on.exit(setwd(cwd))## MAKE will be set by sourcing Renvironstatus <- system2(Sys.getenv("MAKE", "make"),c("-k -j", Ncpus),stdout = output, stderr = output,env = env)if(status > 0L) {## Try to figure out whichpkgs <- update[, 1L]tss <- sub("[.]ts$", "", dir(".", pattern = "[.]ts$"))failed <- pkgs[!pkgs %in% tss]for (pkg in failed) system(paste0("cat ", pkg, ".out"))warning(gettextf("installation of one or more packages failed,\n probably %s",paste(sQuote(failed), collapse = ", ")),domain = NA)}if(keep_outputs)file.copy(paste0(update[, 1L], ".out"), outdir)## Keep binary packages possibly created via --buildfile.copy(Sys.glob(paste0(update[, 1L], "*.zip")), cwd)file.copy(Sys.glob(paste0(update[, 1L], "*.tgz")), cwd)file.copy(Sys.glob(paste0(update[, 1L], "*.tar.gz")), cwd)setwd(cwd); on.exit()unlink(tmpd2, recursive = TRUE)} else {tmpd2 <- tempfile()if(!dir.create(tmpd2))stop(gettextf("unable to create temporary directory %s",sQuote(tmpd2)),domain = NA)outfiles <- file.path(tmpd2, paste0(update[, 1L], ".out"))for(i in seq_len(nrow(update))) {outfile <- if(keep_outputs) outfiles[i] else outputfil <- update[i, 3L]args <- c(args0,get_install_opts(fil),"-l", shQuote(update[i, 2L]),getConfigureArgs(fil),getConfigureVars(fil),shQuote(fil))status <- system2(cmd0, args, env = env,stdout = outfile, stderr = outfile,timeout = tlim)## if this times out it will leave locks behindif(!quiet && keep_outputs)writeLines(readLines(outfile))if(status > 0L)warning(gettextf("installation of package %s had non-zero exit status",sQuote(update[i, 1L])),domain = NA)else if(verbose) {cmd <- paste(c(cmd0, args), collapse = " ")message(sprintf("%d): succeeded '%s'", i, cmd),domain = NA)}}if(keep_outputs)file.copy(outfiles, outdir)unlink(tmpd2, recursive = TRUE)}## Using stderr is the wish of PR#16420if(!quiet && nonlocalrepos && !is.null(tmpd) && is.null(destdir))cat("\n", gettextf("The downloaded source packages are in\n\t%s",sQuote(normalizePath(tmpd, mustWork = FALSE))),"\n", sep = "", file = stderr())## update packages.html on Unix only if .Library was installed intolibs_used <- unique(update[, 2L])if(.Platform$OS.type == "unix" && .Library %in% libs_used) {message("Updating HTML index of packages in '.Library'")make.packages.html(.Library)}} else if(!is.null(tmpd) && is.null(destdir)) unlink(tmpd, TRUE)invisible()}##end install.packages## treat variables as global in a package, for codetools & checkglobalVariables <- function(names, package, add = TRUE)registerNames(names, package, ".__global__", add)## suppress foreign function checks, for checksuppressForeignCheck <- function(names, package, add = TRUE)registerNames(names, package, ".__suppressForeign__", add)registerNames <- function(names, package, .listFile, add = TRUE) {.simplePackageName <- function(env) {get0(".packageName", envir = env, inherits = FALSE,ifnotfound = "(unknown package)")}if(missing(package)) {env <- topenv(parent.frame(2L)) # We cannot be called directly!package <- .simplePackageName(env)}else if(is.environment(package)) {env <- packagepackage <- .simplePackageName(env)}elseenv <- asNamespace(package)current <- get0(.listFile, envir = env, inherits = FALSE, ifnotfound = character())if(! missing(names)) {if(environmentIsLocked(env))stop(gettextf("The namespace for package \"%s\" is locked; no changes in the global variables list may be made.",package))current <- if(add) unique(c(current, names)) else namesassign(.listFile, current, envir = env)}current}packageName <- function(env = parent.frame()) {if (!is.environment(env)) stop("'env' must be an environment")env <- topenv(env)if (!is.null(pn <- get0(".packageName", envir = env, inherits = FALSE)))pnelse if (identical(env, .BaseNamespaceEnv))"base"## else NULL}##' R's .libPaths() to be used in 'R CMD ...' or similar,##' most easily by a previous Sys.setenv(R_LIBS = .R_LIBS())## not yet exported.R_LIBS <- function(libp = .libPaths()) {libp <- libp[! libp %in% .Library]if(length(libp))paste(libp, collapse = .Platform$path.sep)else "" # character(0) would fail in Sys.setenv()}