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