1# File src/library/utils/R/windows/install.packages.R 2# Part of the R package, https://www.R-project.org 3# 4# Copyright (C) 1995-2019 The R Core Team 5# 6# This program is free software; you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation; either version 2 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# A copy of the GNU General Public License is available at 17# https://www.R-project.org/Licenses/ 18 19## Unexported helper 20unpackPkgZip <- function(pkg, pkgname, lib, libs_only = FALSE, 21 lock = FALSE, quiet = FALSE, reuse_lockdir = FALSE) 22{ 23 .zip.unpack <- function(zipname, dest) 24 { 25 if(file.exists(zipname)) { 26 if((unzip <- getOption("unzip")) != "internal") { 27 system(paste(shQuote(unzip), "-oq", zipname, "-d", dest), 28 show.output.on.console = FALSE, invisible = TRUE) 29 } else unzip(zipname, exdir = dest) 30 } else stop(gettextf("zip file %s not found", 31 sQuote(zipname)), domain = NA) 32 } 33 34 ## Create a temporary directory and unpack the zip to it 35 ## then get the real package name, copying the 36 ## dir over to the appropriate install dir. 37 lib <- normalizePath(lib, mustWork = TRUE) 38 tmpDir <- tempfile(, lib) 39 if (!dir.create(tmpDir)) 40 stop(gettextf("unable to create temporary directory %s", 41 sQuote(normalizePath(tmpDir, mustWork = FALSE))), 42 domain = NA, call. = FALSE) 43 cDir <- getwd() 44 ## need to ensure we are not in tmpDir when unlinking is attempted 45 on.exit(setwd(cDir)) 46 on.exit(unlink(tmpDir, recursive=TRUE), add = TRUE) 47 res <- .zip.unpack(pkg, tmpDir) 48 setwd(tmpDir) 49 res <- tools::checkMD5sums(pkgname, file.path(tmpDir, pkgname)) 50 if(!quiet && !is.na(res) && res) { 51 cat(gettextf("package %s successfully unpacked and MD5 sums checked\n", 52 sQuote(pkgname))) 53 flush.console() 54 } 55 56 desc <- read.dcf(file.path(pkgname, "DESCRIPTION"), 57 c("Package", "Type")) 58 if(desc[1L, "Type"] %in% "Translation") { 59 fp <- file.path(pkgname, "share", "locale") 60 if(file.exists(fp)) { 61 langs <- dir(fp) 62 for(lang in langs) { 63 path0 <- file.path(fp, lang, "LC_MESSAGES") 64 mos <- dir(path0, full.names = TRUE) 65 path <- file.path(R.home("share"), "locale", lang, 66 "LC_MESSAGES") 67 if(!file.exists(path)) 68 if(!dir.create(path, FALSE, TRUE)) 69 warning(gettextf("failed to create %s", sQuote(path)), 70 domain = NA) 71 res <- file.copy(mos, path, overwrite = TRUE) 72 if(any(!res)) 73 warning(gettextf("failed to create %s", 74 paste(sQuote(mos[!res]), collapse=",")), 75 domain = NA) 76 } 77 } 78 fp <- file.path(pkgname, "library") 79 if(file.exists(fp)) { 80 spkgs <- dir(fp) 81 for(spkg in spkgs) { 82 langs <- dir(file.path(fp, spkg, "po")) 83 for(lang in langs) { 84 path0 <- file.path(fp, spkg, "po", lang, "LC_MESSAGES") 85 mos <- dir(path0, full.names = TRUE) 86 path <- file.path(R.home(), "library", spkg, "po", 87 lang, "LC_MESSAGES") 88 if(!file.exists(path)) 89 if(!dir.create(path, FALSE, TRUE)) 90 warning(gettextf("failed to create %s", 91 sQuote(path)), domain = NA) 92 res <- file.copy(mos, path, overwrite = TRUE) 93 if(any(!res)) 94 warning(gettextf("failed to create %s", 95 paste(sQuote(mos[!res]), collapse=",")), 96 domain = NA) 97 } 98 } 99 } 100 } else { 101 instPath <- file.path(lib, pkgname) 102 if(identical(lock, "pkglock") || isTRUE(lock)) { 103 ## This is code adapted from tools:::.install_packages 104 lockdir <- if(identical(lock, "pkglock")) 105 file.path(lib, paste0("00LOCK-", pkgname)) 106 else file.path(lib, "00LOCK") 107 if (!reuse_lockdir) { 108 if (file.exists(lockdir)) { 109 stop(gettextf("ERROR: failed to lock directory %s for modifying\nTry removing %s", 110 sQuote(lib), sQuote(lockdir)), domain = NA) 111 } 112 dir.create(lockdir, recursive = TRUE) 113 } 114 if (!dir.exists(lockdir)) 115 stop(gettextf("ERROR: failed to create lock directory %s", 116 sQuote(lockdir)), domain = NA) 117 ## Back up a previous version 118 if (file.exists(instPath)) { 119 file.copy(instPath, lockdir, recursive = TRUE) 120 on.exit({ 121 if (restorePrevious) { 122 try(unlink(instPath, recursive = TRUE)) 123 savedcopy <- file.path(lockdir, pkgname) 124 file.copy(savedcopy, lib, recursive = TRUE) 125 warning(gettextf("restored %s", sQuote(pkgname)), 126 domain = NA, call. = FALSE, immediate. = TRUE) 127 } 128 }, add=TRUE) 129 restorePrevious <- FALSE 130 } 131 on.exit({ 132 ldel <- if (reuse_lockdir) 133 file.path(lockdir, pkgname) 134 else lockdir 135 unlink(ldel, recursive = TRUE) 136 }, add=TRUE) 137 } 138 139 if(libs_only) { 140 if (!file_test("-d", file.path(instPath, "libs"))) 141 warning(gettextf("there is no 'libs' directory in package %s", 142 sQuote(pkgname)), 143 domain = NA, call. = FALSE, immediate. = TRUE) 144 ## copy over the subdirs of 'libs', removing if already there 145 for(sub in c("i386", "x64")) 146 if (file_test("-d", file.path(tmpDir, pkgname, "libs", sub))) { 147 unlink(file.path(instPath, "libs", sub), recursive = TRUE) 148 149 ret <- file.copy(file.path(tmpDir, pkgname, "libs", sub), 150 file.path(instPath, "libs"), 151 recursive = TRUE) 152 if(any(!ret)) { 153 warning(gettextf("unable to move temporary installation %s to %s", 154 sQuote(normalizePath(file.path(tmpDir, pkgname, "libs", sub), mustWork = FALSE)), 155 sQuote(normalizePath(file.path(instPath, "libs"), mustWork = FALSE))), 156 domain = NA, call. = FALSE, immediate. = TRUE) 157 restorePrevious <- TRUE # Might not be used 158 } 159 } 160 ## update 'Archs': copied from tools:::.install.packages 161 fi <- file.info(Sys.glob(file.path(instPath, "libs", "*"))) 162 dirs <- row.names(fi[fi$isdir %in% TRUE]) 163 if (length(dirs)) { 164 descfile <- file.path(instPath, "DESCRIPTION") 165 olddesc <- readLines(descfile) 166 olddesc <- grep("^Archs:", olddesc, 167 invert = TRUE, value = TRUE, useBytes = TRUE) 168 newdesc <- c(olddesc, 169 paste("Archs:", 170 paste(basename(dirs), collapse=", ")) 171 ) 172 writeLines(newdesc, descfile, useBytes = TRUE) 173 } 174 } else { 175 ## If the package is already installed, remove it. If it 176 ## isn't there, the unlink call will still return success. 177 ret <- unlink(instPath, recursive=TRUE, force=TRUE) 178 if (ret == 0) { 179 ## Move the new package to the install lib 180 ## file.rename automatically retries few times if necessary 181 ## due to anti-virus interference 182 tmpInstPath <- file.path(tmpDir, pkgname) 183 ret <- file.rename(tmpInstPath, instPath) 184 if(!ret) { 185 if (dir.exists(tmpInstPath) && !dir.exists(instPath)) { 186 warning(gettextf("unable to move temporary installation %s to %s, copying instead", 187 sQuote(normalizePath(tmpInstPath, mustWork = FALSE)), 188 sQuote(normalizePath(instPath, mustWork = FALSE))), 189 domain = NA, call. = FALSE, immediate. = TRUE) 190 ret <- file.copy(tmpInstPath, dirname(instPath), 191 recursive = TRUE, copy.date = TRUE) 192 if(any(!ret)) { 193 warning(gettextf("unable to copy temporary installation %s to %s", 194 sQuote(normalizePath(tmpInstPath, mustWork = FALSE)), 195 sQuote(normalizePath(instPath, mustWork = FALSE))), 196 domain = NA, call. = FALSE, immediate. = TRUE) 197 restorePrevious <- TRUE # Might not be used 198 } 199 unlink(tmpInstPath, recursive = TRUE) 200 } else { 201 warning(gettextf("unable to move temporary installation %s to %s", 202 sQuote(normalizePath(tmpInstPath, mustWork = FALSE)), 203 sQuote(normalizePath(instPath, mustWork = FALSE))), 204 domain = NA, call. = FALSE, immediate. = TRUE) 205 restorePrevious <- TRUE # Might not be used 206 } 207 } 208 } else { 209 warning(gettextf("cannot remove prior installation of package %s", 210 sQuote(pkgname)), 211 domain = NA, call. = FALSE, immediate. = TRUE) 212 restorePrevious <- TRUE # Might not be used 213 } 214 } 215 } 216} 217 218## called as 219# .install.winbinary(pkgs = pkgs, lib = lib, contriburl = contriburl, 220# method = method, available = available, 221# destdir = destdir, 222# dependencies = dependencies, 223# libs_only = libs_only, ...) 224 225.install.winbinary <- 226 function(pkgs, lib, repos = getOption("repos"), 227 contriburl = contrib.url(repos), 228 method, available = NULL, destdir = NULL, 229 dependencies = FALSE, libs_only = FALSE, 230 lock = getOption("install.lock", TRUE), quiet = FALSE, ...) 231{ 232 if(!length(pkgs)) return(invisible()) 233 pkgnames <- basename(pkgs) 234 pkgnames <- sub("\\.zip$", "", pkgnames) 235 pkgnames <- sub("_[0-9.-]+$", "", pkgnames) 236 237 if(is.null(contriburl)) { 238 for(i in seq_along(pkgs)) { 239 if(is.na(pkgs[i])) next 240 unpackPkgZip(pkgs[i], pkgnames[i], lib, libs_only, lock, quiet) 241 } 242 return(invisible()) 243 } 244 tmpd <- destdir 245 nonlocalcran <- length(grep("^file:", contriburl)) < length(contriburl) 246 if(is.null(destdir) && nonlocalcran) { 247 tmpd <- file.path(tempdir(), "downloaded_packages") 248 if (!file.exists(tmpd) && !dir.create(tmpd)) 249 stop(gettextf("unable to create temporary directory %s", 250 sQuote(normalizePath(tmpd, mustWork = FALSE))), 251 domain = NA) 252 } 253 254 if(is.null(available)) 255 available <- available.packages(contriburl = contriburl, 256 method = method, ...) 257 pkgs <- getDependencies(pkgs, dependencies, available, lib, binary = TRUE) 258 259 foundpkgs <- download.packages(pkgs, destdir = tmpd, available = available, 260 contriburl = contriburl, method = method, 261 type = "win.binary", quiet = quiet, ...) 262 263 if(length(foundpkgs)) { 264 update <- unique(cbind(pkgs, lib)) 265 colnames(update) <- c("Package", "LibPath") 266 for(lib in unique(update[,"LibPath"])) { 267 oklib <- lib == update[,"LibPath"] 268 for(p in update[oklib, "Package"]) 269 { 270 okp <- p == foundpkgs[, 1L] 271 if(any(okp)) 272 unpackPkgZip(foundpkgs[okp, 2L], foundpkgs[okp, 1L], 273 lib, libs_only, lock) 274 } 275 } 276 if(!quiet && !is.null(tmpd) && is.null(destdir)) 277 ## tends to be a long path on Windows 278 cat("\n", gettextf("The downloaded binary packages are in\n\t%s", 279 normalizePath(tmpd, mustWork = FALSE)), 280 "\n", sep = "") 281 } else if(!is.null(tmpd) && is.null(destdir)) unlink(tmpd, recursive = TRUE) 282 283 invisible() 284} 285 286menuInstallPkgs <- function(type = getOption("pkgType")) 287{ 288 install.packages(lib=.libPaths()[1L], dependencies=NA, type=type) 289} 290 291menuInstallLocal <- function() 292{ 293 files <- choose.files('',filters=Filters[c('zip','tarball', 'All'),]) 294 zips <- endsWith(files, ".zip") 295 tarballs <- endsWith(files, ".tar.gz") 296 bad <- !(zips | tarballs) 297 if (any(bad)) 298 stop("Only '*.zip' and '*.tar.gz' files can be installed.") 299 if (any(zips)) install.packages(files[zips], 300 .libPaths()[1L], repos = NULL, type = "binary") 301 if (any(tarballs)) install.packages(files[tarballs], 302 .libPaths()[1L], repos = NULL, type = "source") 303} 304 305### Deprecated in 2.13.0, defunct in 2.14.0 306zip.unpack <- function(zipname, dest) .Defunct("unzip") 307 308