The R Project SVN
R
(root)/trunk/src/library/tools/R/install.R – Rev 90124
Rev 89849 | Blame | Compare with Previous | Last modification | View Log | Download | RSS feed
# File src/library/tools/R/install.R# Part of the R package, https://www.R-project.org## Copyright (C) 1995-2026 The R Core Team## NB: also copyright dates in Usages.## 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/#### R based engine for R CMD INSTALL SHLIB Rprof###### R developers can use this to debug the function by running it## directly as tools:::.install_packages(args), where the args should## be what commandArgs(TRUE) would return, that is a character vector## of (space-delimited) terms that would be passed to R CMD INSTALL. E.g.##if(FALSE) {tools:::.install_packages(c("--preclean", "--no-multiarch","tree"))## orstatus <- tryCatch(tools:::.install_packages(c("--no-clean-on-error", "--no-multiarch","tree"), no.q = TRUE), error = function(e) as.numeric(sub(".* exit status *", "",conditionMessage(e))))## ordebugonce(tools:::.install_packages)tools:::.install_packages(c("-c", "--debug", "--no-clean-on-error", "--no-multiarch","tree"))## and then (after about 40 x [Enter]) when do_install is defined:debug(do_install) ## and 'c'}.install_packages <- function(args = NULL, no.q = interactive(), warnOption = 1){## calls system() on Windows for## sh (configure.win/cleanup.win) make zip## global variablescurPkg <- character() # list of packages in current pkglockdir <- ""is_first_package <- TRUEstars <- "*"user.tmpdir <- Sys.getenv("PKG_BUILD_DIR")keep.tmpdir <- nzchar(user.tmpdir)## Need these here in case of an early error, e.g. missing etc/Makeconftmpdir <- ""clean_on_error <- TRUER_runR_deps_only <- function(cmd, deps_only_env, multiarch = FALSE, ...) {deps_only <-config_val_to_logical(Sys.getenv("_R_CHECK_INSTALL_DEPENDS_","FALSE"))env <- if (deps_only) deps_only_envelse ""## needed for some packages (AnnotationDbi) that install other## packages during their tests (otherwise system profile fails## because it cannot find the tests startup file)env <- paste(env, "R_TESTS=")opts <- "--no-save --no-restore --no-echo"if (deps_only) {opts <- paste(opts, "--no-init-file --no-site-file")if (!multiarch)## do not use --no-environ with multiarch, because Renviron## may include architecture-specific settings that may differ## from settings of the host process architectureopts <- paste(opts, "--no-environ")}R_runR(cmd = cmd, Ropts = opts, env = env, ...)}do_exit <-if(no.q)function(status) stop(".install_packages() exit status ", status)elsefunction(status) q("no", status = status, runLast = FALSE)do_exit_on_error <- function(status = 1L){## If we are not yet processing a package, we will not have## set curPkgif(clean_on_error && length(curPkg)) {pkgdir <- file.path(lib, curPkg)if (nzchar(pkgdir) && dir.exists(pkgdir) &&is_subdir(pkgdir, lib)) {starsmsg(stars, "removing ", sQuote(pkgdir))unlink(pkgdir, recursive = TRUE)}if (nzchar(lockdir) &&dir.exists(lp <- file.path(lockdir, curPkg)) &&is_subdir(lp, lockdir)) {starsmsg(stars, "restoring previous ", sQuote(pkgdir))if (WINDOWS) {file.copy(lp, dirname(pkgdir), recursive = TRUE,copy.date = TRUE)unlink(lp, recursive = TRUE)} else {## some shells require that they be run in a known dirsetwd(startdir)if(system(paste("mv -f", shQuote(lp), shQuote(pkgdir))))message(" restoration failed\n", domain = NA)}}}do_cleanup()do_exit(status=status)}do_cleanup <- function(){if(!keep.tmpdir && nzchar(tmpdir)) do_cleanup_tmpdir()if (!is_first_package) {## Only need to do this in case we successfully installed## at least one packageif (lib == .Library && "html" %in% build_help_types)utils::make.packages.html(.Library, docdir = R.home("doc"))}if (nzchar(lockdir)) unlink(lockdir, recursive = TRUE)}do_cleanup_tmpdir <- function(){## Solaris will not remove any directory in the current pathsetwd(startdir)if (!keep.tmpdir && dir.exists(tmpdir)) unlink(tmpdir, recursive=TRUE)}# This produces a (by default single) quoted string for use in a# command sent to another R process.quote_path <- function(path, quote = "'") {path <- gsub("\\", "\\\\", path, fixed = TRUE)path <- gsub(quote, paste0("\\", quote), path, fixed = TRUE)paste0(quote, path, quote)}# Escape backslashes in a replacement string for gsub etc.# To be used when the replacement is a path name which may include# backslashes, e.g. with UNC paths on Windows.quote_replacement <- function(r)paste0(gsub("\\", "\\\\", r, fixed=TRUE))on.exit(do_exit_on_error())WINDOWS <- .Platform$OS.type == "windows"cross <- Sys.getenv("R_CROSS_BUILD")have_cross <- nzchar(cross)if(have_cross && !cross %in% c("x64","singlearch"))stop(gettextf("invalid value for '%s' : %s","R_CROSS_BUILD", sQuote(cross)),domain = NA)if (have_cross) {WINDOWS <- TRUESys.setenv(R_OSTYPE = "windows")}if (WINDOWS) MAKE <- "make"else MAKE <- Sys.getenv("MAKE") # FIXME shQuote, default?rarch <- Sys.getenv("R_ARCH") # unix onlyif (WINDOWS && nzchar(.Platform$r_arch))rarch <- paste0("/", .Platform$r_arch)test_archs <- rarchif (have_cross) {rarch = if (cross == "singlearch") "" else paste0("/", cross)test_archs <- c()}SHLIB_EXT <- if (WINDOWS) ".dll" else {## can we do better?mconf <- file.path(R.home(), paste0("etc", rarch), "Makeconf")## PCRE needed for Debian arm* platformssub(".*= ", "", grep("^SHLIB_EXT", readLines(mconf), value = TRUE,perl = TRUE))}if(getOption("warn") < warnOption) {op <- options(warn = warnOption)on.exit(options(op), add = TRUE)}invisible(Sys.setlocale("LC_COLLATE", "C")) # discard outputif (WINDOWS) {rhome <- chartr("\\", "/", R.home())## These might be needed for configure.win and Make{file,vars}.win## Some people have *assumed* that R_HOME uses /Sys.setenv(R_HOME = rhome)if (nzchar(rarch)) Sys.setenv(R_ARCH = rarch, R_ARCH_BIN = rarch)}Usage <- function() {cat("Usage: R CMD INSTALL [options] pkgs","","Install the add-on packages specified by pkgs. The elements of pkgs can","be relative or absolute paths to directories with the package","sources, or to gzipped package 'tar' archives. The library tree","to install to can be specified via '--library'. By default, packages are","installed in the library tree rooted at the first directory in",".libPaths() for an R session run in the current environment.","","Options:"," -h, --help print short help message and exit"," -v, --version print INSTALL version info and exit"," -c, --clean remove files created during installation"," --preclean remove files created during a previous run"," -d, --debug turn on debugging messages",if(WINDOWS) " and build a debug DLL"," -l, --library=LIB install packages to library tree LIB"," --no-configure do not use the package's configure script"," --no-docs do not install HTML, LaTeX or examples help"," --html build HTML help"," --no-html do not build HTML help"," --latex install LaTeX help"," --example install R code for help examples"," --fake do minimal install for testing purposes"," --no-lock install on top of any existing installation"," without using a lock directory"," --lock use a per-library lock directory (default)"," --pkglock use a per-package lock directory"," (default for a single package)"," --build build binaries of the installed package(s)"," --sign sign the installed package(s)"," --install-tests install package-specific tests (if any)"," --no-R, --no-libs, --no-data, --no-help, --no-demo, --no-exec,"," --no-inst"," suppress installation of the specified part of the"," package for testing or other special purposes"," --no-multiarch build only the main architecture"," --libs-only only install the libs directory"," --data-compress= none, gzip (default), bzip2 or xz compression"," to be used for lazy-loading of data"," --resave-data re-save data files as compactly as possible"," --compact-docs re-compress PDF files under inst/doc"," --with-keep.source"," --without-keep.source"," use (or not) 'keep.source' for R code"," --with-keep.parse.data"," --without-keep.parse.data"," use (or not) 'keep.parse.data' for R code"," --byte-compile byte-compile R code"," --no-byte-compile do not byte-compile R code"," --staged-install install to a temporary directory and then move"," to the target directory (default)"," --no-staged-install install directly to the target directory"," --no-test-load skip test of loading installed package"," --no-clean-on-error do not remove installed package on error"," --merge-multiarch multi-arch by merging (from a single tarball only)"," --use-vanilla do not read any Renviron or Rprofile files"," --use-LTO use Link-Time Optimization"," --no-use-LTO do not use Link-Time Optimization"," --use-C17 use a C standard at most C17 (also C90, C99)"," --use-C23 use a C standard at least C23","\nfor Unix"," --configure-args=ARGS"," set arguments for the configure scripts (if any)"," --configure-vars=VARS"," set variables for the configure scripts (if any)"," --strip strip shared object(s)"," --strip-lib strip static/dynamic libraries under lib/"," --dsym (macOS only) generate dSYM directory"," --built-timestamp=STAMP"," set timestamp for Built: entry in DESCRIPTION",## "\nand on Windows only",## " --force-biarch attempt to build both architectures",## " even if there is a non-empty configure.win",## " --compile-both compile both architectures on 32-bit Windows","","Which of --html or --no-html is the default depends on the build of R:",paste0("for this one it is ",if(static_html) "--html" else "--no-html", "."),"","Report bugs at <https://bugs.R-project.org>.", sep = "\n")}## Check whether dir is a subdirectory of parent,## to protect against malicious package names like ".." below## Assumes that both directories existis_subdir <- function(dir, parent) {rl <- Sys.readlink(dir) ## symbolic link (on POSIX, not Windows) is ok:(!is.na(rl) && nzchar(rl)) ||normalizePath(parent) == normalizePath(file.path(dir, ".."))}fullpath <- function(dir){owd <- setwd(dir)full <- getwd()setwd(owd)full}## used for LazyData, KeepSource, ByteCompile, Biarch, StagedInstallparse_description_field <- function(desc, field, default)str_parse_logic(desc[field], default = default,otherwise = quote(errmsg("invalid value of ", field, " field in DESCRIPTION")))starsmsg <- function(stars, ...)message(stars, " ", ..., domain = NA)errmsg <- function(...){message("ERROR: ", ..., domain = NA)do_exit_on_error()}pkgerrmsg <- function(msg, pkg, ...)errmsg(msg, " for package ", sQuote(pkg), ...)## 'pkg' is the absolute path to package sources.do_install <- function(pkg){if (WINDOWS && endsWith(pkg, ".zip")) {pkg_name <- basename(pkg)pkg_name <- sub("\\.zip$", "", pkg_name)pkg_name <- sub("_[0-9.-]+$", "", pkg_name)reuse_lockdir <- lock && !pkglockif (pkglock)lock <- "pkglock"utils:::unpackPkgZip(pkg, pkg_name, lib, libs_only, lock,reuse_lockdir = reuse_lockdir,name_from_dir = TRUE)return()}setwd(pkg)## We checked this exists, but not that it is readabledesc <- tryCatch(read.dcf(fd <- file.path(pkg, "DESCRIPTION")),error = identity)if(inherits(desc, "error") || !length(desc))stop(gettextf("error reading file '%s'", fd),domain = NA, call. = FALSE)desc <- desc[1L,]## Let's see if we have a bundleif (!is.na(desc["Bundle"])) {stop("this seems to be a bundle -- and they are defunct")} else {pkg_name <- desc["Package"]if (is.na(pkg_name)) errmsg("no 'Package' field in 'DESCRIPTION'")curPkg <<- pkg_name}instdir <- file.path(lib, pkg_name) # = <library>/<pkg>Sys.setenv(R_PACKAGE_NAME = pkg_name, R_PACKAGE_DIR = instdir)status <- .Rtest_package_depends_R_version()if (status) do_exit_on_error()dir.create(instdir, recursive = TRUE, showWarnings = FALSE)if (!dir.exists(instdir)) {# This allows a package to be installed if a broken symbolic# link (or a regular file) is place (PR#18262)unlink(instdir, recursive = FALSE)dir.create(instdir, recursive = TRUE, showWarnings = FALSE)}if (!dir.exists(instdir)) {errmsg("unable to create ", sQuote(instdir))}if (!is_subdir(instdir, lib)) {errmsg(sQuote(pkg_name), " is not a legal package name")}## Make sure we do not attempt installing to srcdir.owd <- setwd(instdir)if (owd == getwd()) pkgerrmsg("cannot install to srcdir", pkg_name)setwd(owd)## Figure out whether this is a source or binary package.is_source_package <- is.na(desc["Built"])if (is_source_package) {## Find out if any C++ or C standard is requested in DESCRIPTION filesys_requires <- desc["SystemRequirements"]if (!is.na(sys_requires)) {sys_requires <- unlist(strsplit(sys_requires, ","))found <- NAfor (i in cxx_standards) {## pattern <- paste0("^[[:space:]]*C[+][+]",i,"[[:space:]]*$")pattern <- paste0("(^| )C[+][+]",i,"([ ,;]|$)")if(any(grepl(pattern, sys_requires))) {Sys.setenv("R_PKG_CXX_STD"=i)on.exit(Sys.unsetenv("R_PKG_CXX_STD"))found <- ibreak}}if (is.na(found)) {pattern <- paste0("^[[:space:]]*C[+][+]")val <- grep(pattern, sys_requires, value = TRUE)if(length(val)) {val <- sub(pattern, "", val)val <- sub("[,;].*$", "", val)val <- sub(" *$", "", val)val <- paste0("C++", val)msg <- sprintf("SystemRequirements: invalid C++ specification %s", sQuote(val))warning(msg, domain = NA, call. = FALSE)}}else if(found %in% c("11", "14")) {msg <-sprintf("SystemRequirements specified C++%s: support has been removed", found)warning(msg, domain = NA, call. = FALSE)}if(is.na(use_C)) {if(any(grepl("USE_C17", sys_requires))) use_C <<- 17if(any(grepl("USE_C23", sys_requires))) use_C <<- 23if(any(grepl("USE_C90", sys_requires))) use_C <<- 90if(any(grepl("USE_C99", sys_requires))) use_C <<- 99}}}if (!is_first_package) cat("\n")if (is_source_package)do_install_source(pkg_name, instdir, pkg, desc)elsedo_install_binary(pkg_name, instdir, desc)## Add read permission to all, write permission to owner## If group-write permissions were requested, set them.Call(C_dirchmod, instdir, group.writable)is_first_package <<- FALSEif (sign && !zip_up) {starsmsg(stars, "SHA256 sums").installSHA256sums(instdir)starsmsg(stars, "signing")create.signature(file.path(instdir, "SHA256"),file.path(instdir, "SHA256.sig"))sig <- verify.signature(file.path(instdir, "SHA256"),file.path(instdir, "SHA256.sig"))if (isTRUE(sig)) {info <- attr(sig,"result")starsmsg(stars, paste("signed with", info$fingerprint, info$userid))}}if (tar_up) { # Unix onlyif (!sign) { # sign has already done this abovestarsmsg(stars, "SHA256 sums").installSHA256sums(instdir)}starsmsg(stars, "creating tarball")version <- desc["Version"]compression <- "gzip"compression_level <- 9Lcustom.bin <- .pkg.type(.Platform$pkgType) == "other.binary"filename <- if (custom.bin) {build <- gsub("^([[:lower:]]+)[.]binary(|[.]([[:alnum:]_-]+))$","\\1\\2", .Platform$pkgType)compression <- "xz"## we could adjust compression_level for zstd here - perhaps an env var?paste0(pkg_name, "_", version, "_R_", gsub(".", "-", build, fixed=TRUE), ".tar.", compression)} else if (!grepl("darwin", R.version$os)) {paste0(pkg_name, "_", version, "_R_",Sys.getenv("R_PLATFORM"), ".tar.gz")} else {paste0(pkg_name, "_", version,".tgz")}filepath <- file.path(startdir, filename)owd <- setwd(lib)res <- utils::tar(filepath, curPkg, compression = compression,compression_level = compression_level,tar = Sys.getenv("R_INSTALL_TAR"))if (res)errmsg(sprintf("packaging into %s failed", sQuote(filename)))message("packaged installation of ",sQuote(pkg_name), " as ", sQuote(filename),domain = NA)setwd(owd)}if (zip_up) { # Windows onlystarsmsg(stars, "MD5 sums").installMD5sums(instdir)## we could use utils::zip() here.ZIP <- "zip" # Windows onlyversion <- desc["Version"]filename <- paste0(pkg_name, "_", version, ".zip")filepath <- shQuote(file.path(startdir, filename))## system(paste("rm -f", filepath))unlink(filepath)owd <- setwd(lib)res <- system(paste(shQuote(ZIP), "-r9Xq", filepath,paste(curPkg, collapse = " ")))setwd(owd)if (res)message("running 'zip' failed", domain = NA)elsemessage("packaged installation of ",sQuote(pkg_name), " as ", filename, domain = NA)}if (Sys.getenv("_R_INSTALL_NO_DONE_") != "yes") {## message("", domain = NA) # ensure next starts on a new line, for R CMD checkstarsmsg(stars, "DONE (", pkg_name, ")")}curPkg <<- character()}## Unix onlydo_install_binary <- function(pkg, instdir, desc){starsmsg(stars, "installing *binary* package ", sQuote(pkg), " ...")if (file.exists(file.path(instdir, "DESCRIPTION"))) {if (nzchar(lockdir))system(paste("mv -f", shQuote(instdir),shQuote(file.path(lockdir, pkg))))dir.create(instdir, recursive = TRUE, showWarnings = FALSE)}TAR <- Sys.getenv("TAR", 'tar')res <- system(paste("cp -R .", shQuote(instdir),"|| (", TAR, "cd - .| (cd", shQuote(instdir), "&&", TAR, "-xf -))"))if (res) errmsg("installing binary package failed")sig.ok <- FALSEres <- checkSHA256sums(pkg, instdir)if(!is.na(res) && res) {starsmsg(stars,gettextf("package %s successfully unpacked and %s sums checked",sQuote(pkg), "SHA256"))if (isTRUE(file.exists(sig <- file.path(instdir, "SHA256.sig")))) {res <- verifySHA256signature(pkg, instdir)if(!is.na(res) && res) {sig.ok <- TRUEinfo <- attr(res, "result")starsmsg(stars,gettextf("package %s signature verified (%s %s)",sQuote(pkg), info$fingerprint, info$userid))}}} else {res <- checkMD5sums(pkg, instdir)if(!is.na(res) && res) {starsmsg(stars,gettextf("package %s successfully unpacked and %s sums checked",sQuote(pkg), "MD5"))}}if (isTRUE(config_val_to_logical(Sys.getenv("_R_INSTALL_REQUIRE_SIGNED", "FALSE"))) &&!sig.ok) errmsg(gettextf("Valid signature is required, but package %s could not be successfully verified.",sQuote(pkg)))if (tar_up) {starsmsg(stars, sQuote(pkg)," was already a binary package and will not be rebuilt")tar_up <- FALSE}}## to be run from package source directoryrun_clean <- function(){if (dir.exists("src") && length(dir("src", all.files = TRUE)) > 2L) {if (WINDOWS) archs <- c("i386", "x64")else {wd2 <- setwd(file.path(R.home("bin"), "exec"))archs <- Sys.glob("*")setwd(wd2)}if(length(archs))for(arch in archs) {ss <- paste0("src-", arch)## it seems fixing permissions is sometimes needed.Call(C_dirchmod, ss, group.writable)unlink(ss, recursive = TRUE)}owd <- setwd("src")if (WINDOWS) {if (file.exists("Makefile.ucrt"))system(paste(MAKE, "-f Makefile.ucrt clean"))else if (file.exists("Makefile.win"))system(paste(MAKE, "-f Makefile.win clean"))elseunlink(c("Makedeps",Sys.glob("*_res.rc"),Sys.glob("*.[do]")))# system("rm -f *_res.rc *.o *.d Makedeps")} else {if (file.exists("Makefile")) system(paste(MAKE, "clean"))else ## we will be using SHLIB --precleanunlink(Sys.glob(paste0("*", SHLIB_EXT)))}setwd(owd)}if (WINDOWS) {if (file.exists("cleanup.ucrt")) {if (system("sh ./cleanup.ucrt"))warning("running 'cleanup.ucrt' failed", call. = FALSE, domain = NA)} else if (file.exists("cleanup.win"))if (system("sh ./cleanup.win"))warning("running 'cleanup.win' failed", call. = FALSE, domain = NA)} else if (file_test("-x", "cleanup")) {if (system("./cleanup"))warning("running 'cleanup' failed", call. = FALSE, domain = NA)} else if (file.exists("cleanup"))warning("'cleanup' exists but is not executable -- see the 'R Installation and Administration Manual'", call. = FALSE)revert_install_time_patches()}do_install_source <- function(pkg_name, instdir, pkg_dir, desc){Sys.setenv("R_INSTALL_PKG" = pkg_name)on.exit(Sys.unsetenv("R_INSTALL_PKG"))shlib_install <- function(instdir, arch){## install.libs.R allows customization of the libs installation processif (file.exists("install.libs.R")) {message("installing via 'install.libs.R' to ", instdir,domain = NA)## the following variables are defined to be available,## and to prevent abuse we don't expose anything elselocal.env <- local({ SHLIB_EXT <- SHLIB_EXTR_PACKAGE_DIR <- instdirR_PACKAGE_NAME <- pkg_nameR_PACKAGE_SOURCE <- pkg_dirR_ARCH <- archWINDOWS <- WINDOWSenvironment()})parent.env(local.env) <- .GlobalEnvsource("install.libs.R", local = local.env)return(TRUE)}## otherwise proceed with the default which is to just copy *${SHLIB_EXT}files <- Sys.glob(paste0("*", SHLIB_EXT))if (length(files)) {libarch <- if (nzchar(arch)) paste0("libs", arch) else "libs"dest <- file.path(instdir, libarch)message('installing to ', dest, domain = NA)dir.create(dest, recursive = TRUE, showWarnings = FALSE)file.copy(files, dest, overwrite = TRUE)if((do_strip || config_val_to_logical(Sys.getenv("_R_SHLIB_STRIP_","false"))) &&nzchar(strip_cmd <- Sys.getenv("R_STRIP_SHARED_LIB"))) {system(paste(c(strip_cmd,shQuote(file.path(dest, files))),collapse = " "))}## not clear if this is still necessary, but sh version did soif (!WINDOWS)Sys.chmod(file.path(dest, files), dmode)## macOS does not keep debugging symbols in binaries## anymore so optionally we can create dSYMs. This is## important since we will blow away .o files so there## is no way to create it later.if (dsym && startsWith(R.version$os, "darwin")) {starsmsg(stars, gettextf("generating debug symbols (%s)", "dSYM"))dylib <- Sys.glob(paste0(dest, "/*", SHLIB_EXT))for (d in dylib) system(paste0("dsymutil ", d))}if(config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_","TRUE"))&& file_test("-f", "symbols.rds")) {file.copy("symbols.rds", dest)}}}## This is only called for Makevars[.win], so assume it## does create a shlib: not so reliably reported on Windows## Note though that it may not create pkg_name.dll, and## graph does not.run_shlib <- function(pkg_name, srcs, instdir, arch, use_LTO = NA){args <- c(shargs,if(isTRUE(use_LTO)) "--use-LTO",if(isFALSE(use_LTO)) "--no-use-LTO",if(isTRUE(use_C == "17")) "--use-C17"else if(isTRUE(use_C == "23")) "--use-C23"else if(isTRUE(use_C == "90")) "--use-C90"else if(isTRUE(use_C == "99")) "--use-C99","-o", paste0(pkg_name, SHLIB_EXT),srcs)if (WINDOWS && debug) args <- c(args, "--debug")if (debug) message("about to run ","R CMD SHLIB ", paste(args, collapse = " "),domain = NA)if (.shlib_internal(args) == 0L) {if(WINDOWS && !file.exists("install.libs.R")&& !length(Sys.glob("*.dll"))) {message("no DLL was created")return(TRUE)}shlib_install(instdir, arch)return(FALSE)} else return(TRUE)}## Patch hardcoded paths in shared objects/dynamic libraries## so that they can be moved to a different directory.## Not used on WINDOWS.patch_rpaths <- function(){slibs <- list.files(instdir, recursive = TRUE, all.files = TRUE,full.names = TRUE)slibs <- grep("(\\.sl$)|(\\.so$)|(\\.dylib$)|(\\.dll$)", slibs,value = TRUE)if (!length(slibs)) return()have_file <- nzchar(Sys.which("file"))## file reports macOS dylibs as 'dynamically linked shared library'if (have_file) {## RcppParallel has .so files containing ASCII text## (linker script) which make the tools below produce## a lot of error messages. However, some docker## installations do not have "file" utility.## Solaris' "file" does not use 'shared'.#### On macOS, a single "dylib" file can have a shared object## for multiple architectures, so multiple lines with## "shared"/"dynamically linked"are_shared <- vapply(slibs,function(l) any(grepl("(shared|dynamically linked)",system(paste("file", shQuote(l)), intern = TRUE))),NA)slibs <- slibs[are_shared]if (!length(slibs)) return()}starsmsg(stars, "checking absolute paths in shared objects and dynamic libraries")uname <- system("uname -a", intern = TRUE)os <- sub(" .*", "", uname)have_chrpath <- nzchar(Sys.which("chrpath"))have_patchelf <- nzchar(Sys.which("patchelf"))have_readelf <- nzchar(Sys.which("readelf"))have_macos_clt <- identical(os, "Darwin") &&nzchar(Sys.which("otool")) &&nzchar(Sys.which("install_name_tool"))have_solaris_elfedit <- identical(os, "SunOS") &&nzchar(Sys.which("elfedit"))hardcoded_paths <- FALSEfailed_fix <- FALSE# paths below are protected from the shell, but special# characters/spaces should not be used, because they cannot be# reproduced correctly in the outputs from external toolsif (have_solaris_elfedit) {## Solaris only## changes both rpath and DT_NEEDED pathsfor (l in slibs) {out <- suppressWarnings(system(paste("elfedit -re dyn:value", shQuote(l)), intern = TRUE))out <- grep("^[ \t]*\\[[0-9]+\\]", out, value = TRUE)re <- "^[ \t]*\\[([0-9]+)\\][ \t]+([^ \t]+)[ \t]+([^ \t]+)[ \t]*(.*)"paths <- gsub(re, "\\4", out)idxs <- gsub(re, "\\1", out)old_paths <- paths# "\\$ORIGIN/.."paths <- gsub(instdir, quote_replacement(final_instdir),paths, fixed = TRUE)changed <- paths != old_pathspaths <- paths[changed]old_paths <- old_paths[changed]idxs <- idxs[changed]for (i in seq_along(paths)) {hardcoded_paths <- TRUEqp <- gsub('([" \\])', "\\\\\\1", paths[i])qp <- gsub("'", "\\\\'", qp)cmd <- paste0("elfedit -e \"dyn:value -dynndx -s ",idxs[i], " ", qp, "\" ", shQuote(l))message(cmd, domain = NA)ret <- suppressWarnings(system(cmd, intern = FALSE))if (ret == 0)message("NOTE: fixed path ", sQuote(old_paths[i]), domain = NA)}out <- suppressWarnings(system(paste("elfedit -re dyn:value", shQuote(l)), intern = TRUE))out <- grep("^[ \t]*\\[", out, value = TRUE)paths <- gsub(re, "\\4", out)if (any(grepl(instdir, paths, fixed = TRUE)))failed_fix <- TRUE}} else if (have_macos_clt) {## macOS onlyfor (l in slibs) {## change identification name of the libraryout <- suppressWarnings(system(paste("otool -D", shQuote(l)), intern = TRUE))out <- out[-1L] # first line is l (includes instdir)oldid <- outif (length(oldid) == 1 &&grepl(instdir, oldid, fixed = TRUE)) {hardcoded_paths <- TRUEnewid <- gsub(instdir, quote_replacement(final_instdir),oldid, fixed = TRUE)cmd <- paste("install_name_tool -id", shQuote(newid),shQuote(l))message(cmd, domain = NA)ret <- suppressWarnings(system(cmd, intern = FALSE))if (ret == 0)## NOTE: install_name does not signal an error in## some casesmessage("NOTE: fixed library identification name ",sQuote(oldid), domain = NA)}## change paths to other librariesout <- suppressWarnings(system(paste("otool -L", shQuote(l)), intern = TRUE))paths <- grep("\\(compatibility", out, value = TRUE)paths <- gsub("^[ \t]*(.*) \\(compatibility.*", "\\1",paths)old_paths <- paths# "@loader_path/.."paths <- gsub(instdir, quote_replacement(final_instdir),paths, fixed = TRUE)changed <- paths != old_pathspaths <- paths[changed]old_paths <- old_paths[changed]for(i in seq_along(paths)) {hardcoded_paths <- TRUEcmd <- paste("install_name_tool -change",shQuote(old_paths[i]), shQuote(paths[i]),shQuote(l))message(cmd, domain = NA)ret <- suppressWarnings(system(cmd, intern = FALSE))if (ret == 0)## NOTE: install_name does not signal an error in## some casesmessage("NOTE: fixed library path ",sQuote(old_paths[i]), domain = NA)}out <- suppressWarnings(system(paste("otool -L", shQuote(l)), intern = TRUE))out <- grep("\\(compatibility", out, value = TRUE)if (any(grepl(instdir, out, fixed = TRUE)))failed_fix <- TRUE## change rpath entriesout <- suppressWarnings(system(paste("otool -l", shQuote(l)), intern = TRUE))out <- grep("(^[ \t]*cmd )|(^[ \t]*path )", out,value = TRUE)rpidx <- grep("cmd LC_RPATH$", out)if (length(rpidx)) {paths <- gsub("^[ \t]*path ", "", out[rpidx+1])paths <- gsub("(.*) \\(offset .*", "\\1", paths)old_paths <- paths# "@loader_path/.."paths <- gsub(instdir, quote_replacement(final_instdir),paths, fixed = TRUE)changed <- paths != old_pathspaths <- paths[changed]old_paths <- old_paths[changed]for(i in seq_along(paths)) {hardcoded_paths <- TRUEcmd <- paste("install_name_tool -rpath",shQuote(old_paths[i]),shQuote(paths[i]),shQuote(l))message(cmd, domain = NA)ret <- suppressWarnings(system(cmd))if (ret == 0)message("NOTE: fixed rpath ",sQuote(old_paths[i]), domain = NA)}}## check no hard-coded paths are leftout <- suppressWarnings(system(paste("otool -l", shQuote(l)), intern = TRUE))out <- out[-1L] # first line is l (includes instdir)if (any(grepl(instdir, out, fixed = TRUE)))failed_fix <- TRUE}} else if (have_patchelf) {## probably Linuxfor(l in slibs) {# fix rpathrpath <- suppressWarnings(system(paste("patchelf --print-rpath", shQuote(l)),intern = TRUE))old_rpath <- rpath# "\\$ORIGIN/.."rpath <- gsub(instdir, quote_replacement(final_instdir),rpath, fixed = TRUE)if (length(rpath) && nzchar(rpath) && old_rpath != rpath) {hardcoded_paths <- TRUEcmd <- paste("patchelf", "--set-rpath",shQuote(rpath), shQuote(l))message(cmd, domain = NA)ret <- suppressWarnings(system(cmd))if (ret == 0)message("NOTE: fixed rpath ", sQuote(old_rpath), domain = NA)rpath <- suppressWarnings(system(paste("patchelf --print-rpath",shQuote(l)), intern = TRUE))if (any(grepl(instdir, rpath, fixed = TRUE)))failed_fix <- TRUE}# fix DT_NEEDEDif (have_readelf) {out <- suppressWarnings(system(paste("readelf -d", shQuote(l)), intern = TRUE))re0 <- "0x.*\\(NEEDED\\).*Shared library:"out <- grep(re0, out, value = TRUE)re <- "^[ \t]*0x[0-9]+[ \t]+\\(NEEDED\\)[ \t]+Shared library:[ \t]*\\[(.*)\\]"paths <- gsub(re, "\\1", out)old_paths <- paths# "\\$ORIGIN/.."paths <- gsub(instdir, quote_replacement(final_instdir),paths, fixed = TRUE)changed <- paths != old_pathspaths <- paths[changed]old_paths <- old_paths[changed]for(i in seq_along(paths)) {cmd <- paste("patchelf --replace-needed",shQuote(old_paths[i]),shQuote(paths[i]),shQuote(l))message(cmd, domain = NA)ret <- suppressWarnings(system(cmd))if (ret == 0)message("NOTE: fixed library path ",sQuote(old_paths[i]), domain = NA)}out <- suppressWarnings(system(paste("readelf -d", shQuote(l)), intern = TRUE))out <- grep(re0, out, value = TRUE)if (any(grepl(instdir, out, fixed = TRUE)))failed_fix <- TRUE}}} else if (have_chrpath) {## Linux (possibly Solaris, but there elfedit should be## available, instead); only fixes rpaths, not DT_NEEDEDfor(l in slibs) {out <- suppressWarnings(system(paste("chrpath", shQuote(l)), intern = TRUE))# when multiple rpaths are present, there is a single# RUNPATH= line with the paths separated by :rpath <- grep(".*PATH=", out, value=TRUE)rpath <- gsub(".*PATH=", "", rpath)old_rpath <- rpath# "\\$ORIGIN/.."rpath <- gsub(instdir, quote_replacement(final_instdir),rpath, fixed = TRUE)if (length(rpath) && nzchar(rpath) && old_rpath != rpath) {hardcoded_paths <- TRUEcmd <- paste("chrpath", "-r", shQuote(rpath),shQuote(l))message(cmd, domain = NA)ret <- suppressWarnings(system(cmd))if (ret == 0)message("NOTE: fixed rpath ", sQuote(old_rpath), domain = NA)out <- suppressWarnings(system(paste("chrpath", shQuote(l)), intern = TRUE))rpath <- grep(".*PATH=", out, value = TRUE)rpath <- gsub(".*PATH=", "", rpath)if (any(grepl(instdir, rpath, fixed = TRUE)))failed_fix <- TRUE}}}if (hardcoded_paths)message("WARNING: shared objects/dynamic libraries with hard-coded temporary installation paths")if (failed_fix)errmsg("some hard-coded temporary paths could not be fixed")if (have_readelf) {## check again, needed mostly on Linux (chrpath may not be## available or there may be DT_NEEDED entries with absolute## paths); ldd is not suitable because it interprets $ORIGINfor(l in slibs) {out <- suppressWarnings(system(paste("readelf -d", shQuote(l)), intern = TRUE))out <- grep("^[ \t]*0x", out, value = TRUE)if (any(grepl(instdir, out, fixed = TRUE))) {## give path relative to installation dirll <- sub(file.path(instdir, ""), "", l, fixed = TRUE)errmsg("absolute paths in ",sQuote(ll)," include the temporary installation directory:"," please report to the package maintainer"," and use ", sQuote("--no-staged-install"))}}}} # patch_rpaths()## Make the destination directories available to the developer's## installation scripts (e.g. configure)Sys.setenv(R_LIBRARY_DIR = lib)if (nzchar(lib0)) {## FIXME: is this needed?## set R_LIBS to include the current installation directoryrlibs <- Sys.getenv("R_LIBS")rlibs <- if (nzchar(rlibs)) paste(lib, rlibs, sep = .Platform$path.sep) else libSys.setenv(R_LIBS = rlibs)## This is needed.libPaths(c(lib, .libPaths()))}Type <- desc["Type"]if (!is.na(Type) && Type == "Frontend") {if (WINDOWS) errmsg("'Frontend' packages are Unix-only")starsmsg(stars, "installing *Frontend* package ", sQuote(pkg_name), " ...")if (preclean) system(paste(MAKE, "clean"))if (use_configure) {if (file_test("-x", "configure")) {res <- system(paste(paste(configure_vars, collapse = " "),"./configure",paste(configure_args, collapse = " ")))if (res) pkgerrmsg("configuration failed", pkg_name)} else if (file.exists("configure"))errmsg("'configure' exists but is not executable -- see the 'R Installation and Administration Manual'")}if (file.exists("Makefile"))if (system(MAKE)) pkgerrmsg("make failed", pkg_name)if (clean) system(paste(MAKE, "clean"))return()}if (!is.na(Type) && Type == "Translation")errmsg("'Translation' packages are defunct")OS_type <- desc["OS_type"]if (WINDOWS) {if ((!is.na(OS_type) && OS_type == "unix") && !fake)errmsg(" Unix-only package")} else {if ((!is.na(OS_type) && OS_type == "windows") && !fake)errmsg(" Windows-only package")}if(group.writable) { ## group-write modes if requested:fmode <- "664"dmode <- "775"} else {fmode <- "644"dmode <- "755"}## At this point we check that we have the dependencies we need.## We cannot use installed.packages() as other installs might be## going on in parallelpkgInfo <- .split_description(.read_description("DESCRIPTION"))R_install_force_depends_imports <- config_val_to_logical(Sys.getenv("_R_INSTALL_LIBS_ONLY_FORCE_DEPENDS_IMPORTS_", "TRUE"))if (libs_only && isFALSE(R_install_force_depends_imports))pkgs <- unique(c(names(names(pkgInfo$LinkingTo))))elsepkgs <- unique(c(names(pkgInfo$Depends), names(pkgInfo$Imports),names(pkgInfo$LinkingTo)))if (length(pkgs)) {miss <- character()for (pkg in pkgs) {if(!length(find.package(pkg, quiet = TRUE)))miss <- c(miss, pkg)}if (length(miss) > 1)pkgerrmsg(sprintf("dependencies %s are not available",paste(sQuote(miss), collapse = ", ")),pkg_name,sprintf("\nPerhaps try a variation of:\ninstall.packages(c(%s))",paste(sQuote(miss, FALSE), collapse = ", ")))else if (length(miss))pkgerrmsg(sprintf("dependency %s is not available",sQuote(miss)),pkg_name,sprintf("\nPerhaps try a variation of:\ninstall.packages(%s)",sQuote(miss, FALSE)))}starsmsg(stars, "installing *source* package ",sQuote(pkg_name), " ...")stars <- "**"starsmsg(stars,sprintf("this is package %s version %s",sQuote(desc["Package"]),sQuote(desc["Version"])))res <- checkSHA256sums(pkg_name, getwd())if(!is.na(res) && res) {starsmsg(stars,gettextf("package %s successfully unpacked and %s sums checked",sQuote(pkg_name), "SHA256"))if (isTRUE(file.exists("SHA256.sig"))) {res <- verifySHA256signature(pkg_name, getwd())if(!is.na(res) && res) {info <- attr(res, "result")starsmsg(stars,gettextf("package %s signature verified (%s %s)",sQuote(pkg_name), info$fingerprint, info$userid))}}} else {res <- checkMD5sums(pkg_name, getwd())if(!is.na(res) && res) {starsmsg(stars,gettextf("package %s successfully unpacked and %s sums checked",sQuote(pkg_name), "MD5"))}}if (file.exists(file.path(instdir, "DESCRIPTION"))) {## Back up a previous versionif (nzchar(lockdir)) {if (debug) starsmsg(stars, "backing up earlier installation")if(WINDOWS) {file.copy(instdir, lockdir, recursive = TRUE,copy.date = TRUE)if (more_than_libs) unlink(instdir, recursive = TRUE)} else if (more_than_libs)system(paste("mv -f ", shQuote(instdir),shQuote(file.path(lockdir, pkg_name))))elsefile.copy(instdir, lockdir, recursive = TRUE,copy.date = TRUE)} else if (more_than_libs) unlink(instdir, recursive = TRUE)if (more_than_libs && dir.exists(instdir))# On Windows, a DLL cannot be unlinked if in useerrmsg("cannot remove earlier installation, is it in use?")dir.create(instdir, recursive = TRUE, showWarnings = FALSE)}pkg_staged_install <- SI <-parse_description_field(desc, "StagedInstall", default = NA)if (is.na(pkg_staged_install)) pkg_staged_install <- staged_installif (have_cross) pkg_staged_install <- FALSEif (pkg_staged_install && libs_only) {pkg_staged_install <- FALSEmessage("not using staged install with --libs-only")}if (pkg_staged_install && !lock) {pkg_staged_install <- FALSEmessage("staged installation is only possible with locking")}if (pkg_staged_install) {starsmsg(stars, "using staged installation")final_instdir <- instdirfinal_lib <- libfinal_rpackagedir <- Sys.getenv("R_PACKAGE_DIR")final_rlibs <- Sys.getenv("R_LIBS")final_libpaths <- .libPaths()instdir <- file.path(lockdir, "00new", pkg_name)Sys.setenv(R_PACKAGE_DIR = instdir)dir.create(instdir, recursive = TRUE, showWarnings = FALSE)lib <- file.path(lockdir, "00new")rlibs <- if (nzchar(final_rlibs))paste(lib, final_rlibs, sep = .Platform$path.sep)elselibSys.setenv(R_LIBS = rlibs).libPaths(c(lib, final_libpaths))} else {if(isFALSE(SI))starsmsg(stars,"using non-staged installation via StagedInstall field")else if (Sys.getenv("_R_INSTALL_SUPPRESS_NO_STAGED_MESSAGE_") != "yes")starsmsg(stars, "using non-staged installation")}if (preclean) run_clean()if (WINDOWS) {# Installation-time patching was enabled as a temporary measure# during the transition from MSVCRT to UCRT, when packages with# many reverse dependencies had to be updated to link.# URL or a local directory with patches: ("no" to no patching)it_patches_base <- Sys.getenv("_R_INSTALL_TIME_PATCHES_", "no")# The patches are identified by package name. An index is used# to map the name to a directory with patches for a given# package. There may be multiple patches for a single package,# but that hasn't been used. The patches applied to a package# are copied into directory install_time_patches inside the# package installation (so in library, but also in binary# package build) for reference.# The patches are automatically reverted on cleanup, see# revert_install_time_patches, also during R CMD build (see# build.R). The latter is needed to ensure that unpatched source# package tarball is produced when the package native code is# compiled during R CMD build, e.g. to build vignettes.# This feature is experimental, it may be completely removed in# the future.if (!it_patches_base %in% c("no", "disabled", "false", "FALSE")) {patches_idx <- tryCatch({idxfile <- file(paste0(it_patches_base, "/","patches_idx.rds"))patches_idx <- readRDS(idxfile)close(idxfile)patches_idx},error = function(e) NULL)if (is.null(patches_idx))message("WARNING: installation-time patches will not be applied, could not get the patches index", domain = NA)else {patches_msg <- FALSEfor(p in patches_idx[[pkg_name]]) {if (!patches_msg) {patches_msg <- TRUEstarsmsg(stars, "applying installation-time patches")}purl <- paste0(it_patches_base, "/", p)have_patch <- nzchar(Sys.which("patch"))if (!have_patch)stop("patch utility is needed for installation-time patching")dir.create("install_time_patches", recursive=TRUE)fname <- paste0("install_time_patches/", basename(p))if (grepl("^http", purl))utils::download.file(purl, destfile = fname, mode = "wb")elsefile.copy(purl, fname)if (system2("patch", args = c("--dry-run", "-p2", "--binary", "--force"),stdin = fname, stdout = NULL, stderr = NULL) != 0) {## the patch cannot be applied, check if it might## be reversedif (system2("patch", args = c("--dry-run", "-R", "-p2", "--binary","--force"), stdin = fname) == 0)message("NOTE: Skipping installation-time patch ", purl," which seems to be already applied.\n", domain = NA)elsemessage("WARNING: failed to apply patch ", purl, "\n", domain = NA)} else {if (system2("patch", args = c("-p2", "--binary", "--force"),stdin = fname) != 0)## should not happen as dry-run succeededmessage("WARNING: failed to apply patch ", p, "\n", domain = NA)elsemessage("Applied installation-time patch ", purl," and saved it as ", fname," in package installation\n", domain = NA)}}}}}if (use_configure) {if (WINDOWS) {if (file.exists(f <- "./configure.ucrt") ||file.exists(f <- "./configure.win")) {## an approach with less quoting hellev <- c("CC", "CFLAGS", "CXX", "CXXFLAGS", "CPPFLAGS","LDFLAGS", "FC", "FCFLAGS")## skip any which are already set.ev <- ev[!nzchar(Sys.getenv(ev))]ev1 <- evif (!is.na(use_C))ev1 <- c(sprintf(c("CC%s", "C%sFLAGS"), use_C),ev[!(ev %in% c("CC", "CFLAGS"))])ev2 <- lapply(ev1, function(x)system2(file.path(R.home("bin"), "Rcmd.exe"),c("config", x), stdout = TRUE))names(ev2) <- ev1do.call(Sys.setenv, ev2)res <- system(paste("sh", f))## as we skipped those already set, unsetting is safe.Sys.unsetenv(ev2)if (res) pkgerrmsg("configuration failed", pkg_name)} else if (file.exists("configure"))message("\n"," **********************************************\n"," WARNING: this package has a configure script\n"," It probably needs manual configuration\n"," **********************************************\n\n", domain = NA)} else {## FIXME: should these be quoted?if (file_test("-x", "configure")) {cmd <- paste(paste(configure_vars, collapse = " "),"./configure",paste(configure_args, collapse = " "))if (debug) message("configure command: ", sQuote(cmd),domain = NA)## in case the configure script calls SHLIB (some do)cmd <- paste("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_=false",cmd)ev <- c("CC", "CFLAGS", "CXX", "CXXFLAGS", "CPPFLAGS","LDFLAGS", "FC", "FCFLAGS")## skip any which are already set.ev <- ev[!nzchar(Sys.getenv(ev))]ev1 <- evif (!is.na(use_C))ev1 <- c(sprintf(c("CC%s", "C%sFLAGS"), use_C),ev[-(1:2)])ev2 <- vapply(ev1,function(x)system2(file.path(R.home("bin"), "R"),c("CMD", "config", x),stdout = TRUE),"")ev3 <- paste0(ev, "=", shQuote(ev2))## skip any which are empty, possible for CXX)ev3 <- ev3[nzchar(ev2)]cmd <- paste(c(ev3, cmd), collapse = " ")res <- system(cmd)if (res) pkgerrmsg("configuration failed", pkg_name)} else if (file.exists("configure"))errmsg("'configure' exists but is not executable -- see the 'R Installation and Administration Manual'")}}if (more_than_libs) {for (f in c("NAMESPACE", "LICENSE", "LICENCE","NEWS", "NEWS.md", "README.md"))if (file.exists(f)) {file.copy(f, instdir, TRUE)Sys.chmod(file.path(instdir, f), fmode)}res <- try(.install_package_description('.', instdir, built_stamp))if (inherits(res, "try-error"))pkgerrmsg("installing package DESCRIPTION failed", pkg_name)if (!file.exists(namespace <- file.path(instdir, "NAMESPACE")) ) {if(dir.exists("R"))errmsg("a 'NAMESPACE' file is required")else writeLines("## package without R code", namespace)}}if (install_libs && dir.exists("src") &&length(dir("src", all.files = TRUE)) > 2L) {starsmsg(stars, "libs")if (!file.exists(file.path(R.home("include"), "R.h")))## maybe even an error? But installing Fortran-based packages should workwarning("R include directory is empty -- perhaps need to install R-devel.rpm or similar", call. = FALSE)has_error <- FALSElinkTo <- pkgInfo$LinkingToif (!is.null(linkTo)) {lpkgs <- sapply(linkTo, function(x) x[[1L]])## we checked that these were all available earlier,## but be cautious in case this changed.paths <- find.package(lpkgs, quiet = TRUE)bpaths <- basename(paths)if (length(paths)) {## check any version requirementshave_vers <-(lengths(linkTo) > 1L) & lpkgs %in% bpathsfor (z in linkTo[have_vers]) {p <- z[[1L]]path <- paths[bpaths %in% p]current <- readRDS(file.path(path, "Meta", "package.rds"))$DESCRIPTION["Version"]target <- as.numeric_version(z$version)if (!do.call(z$op, list(as.numeric_version(current), target)))stop(gettextf("package %s %s was found, but %s %s is required by %s",sQuote(p), current, z$op,target, sQuote(pkgname)),call. = FALSE, domain = NA)}clink_cppflags <- paste(paste0("-I'", paths, "/include'"),collapse = " ")Sys.setenv(CLINK_CPPFLAGS = clink_cppflags)}} else clink_cppflags <- ""libdir <- file.path(instdir, paste0("libs", rarch))dir.create(libdir, showWarnings = FALSE)if (WINDOWS) {owd <- setwd("src")if (file.exists(f <- "Makefile.ucrt") || file.exists(f <- "Makefile.win")) {system_makefile <-file.path(R.home(), paste0("etc", rarch), "Makeconf")makefiles <- c(system_makefile,makevars_site(),f,makevars_user())message(paste0(" running 'src/", f, "' ..."), domain = NA)p1 <- function(...) paste(..., collapse = " ")makeargs <-if (!is.na(use_C))sprintf(c("CC='$(CC%s)'", "CFLAGS='$(C%sFLAGS)'"), use_C)else character()cmd <- paste("make --no-print-directory",p1("-f", shQuote(makefiles)),p1(makeargs))res <- system(cmd)if (res == 0L) shlib_install(instdir, rarch)else has_error <- TRUE} else { ## no src/Makefile.winsrcs <- dir(pattern = "\\.([cfmM]|cc|cpp|f90|f95|mm)$",all.files = TRUE)archs <- if(have_cross) {if (cross == "singlearch") "" else cross## else if (!force_both && !grepl(" x64 ", utils::win.version()))## "i386"} else {## see what is installed## NB, not R.home("bin")f <- dir(file.path(R.home(), "bin"))f[f %in% c("i386", "x64")]}one_only <- !multiarchhas_configure_ucrt <- file.exists("../configure.ucrt")if(!one_only && (has_configure_ucrt || file.exists("../configure.win"))) {one_only <- sum(nchar(readLines(if(has_configure_ucrt) "../configure.ucrt" else "../configure.win",warn = FALSE), "bytes")) > 0if(one_only && !force_biarch) {if(parse_description_field(desc, "Biarch", FALSE))force_biarch <- TRUEelse if (length(archs) > 1L) {if (has_configure_ucrt)warning("this package has a non-empty 'configure.ucrt' file,\nso building only the main architecture\n", call. = FALSE, domain = NA)elsewarning("this package has a non-empty 'configure.win' file,\nso building only the main architecture\n", call. = FALSE, domain = NA)}}}if(force_biarch) one_only <- FALSEif(one_only || length(archs) < 2L)has_error <-run_shlib(pkg_name, srcs, instdir, rarch, use_LTO)else {setwd(owd)test_archs <- archsfor(arch in archs) {message("", domain = NA) # a blank linestarsmsg("***", "arch - ", arch)ss <- paste0("src-", arch)dir.create(ss, showWarnings = FALSE)file.copy(Sys.glob("src/*"), ss, recursive = TRUE)## avoid read-only files/dir such as nested .svn.Call(C_dirchmod, ss, group.writable)setwd(ss)ra <- paste0("/", arch)Sys.setenv(R_ARCH = ra, R_ARCH_BIN = ra)has_error <-run_shlib(pkg_name, srcs, instdir, ra, use_LTO)setwd(owd)if (has_error) break}}}setwd(owd)} else { # not WINDOWSif (file.exists("src/Makefile")) {if (nzchar(rarch)) {arch <- substr(rarch, 2, 1000)starsmsg(stars, "arch - ", arch)}owd <- setwd("src")system_makefile <-file.path(paste0(R.home("etc"), rarch), "Makeconf")makefiles <- c(system_makefile,makevars_site(),"Makefile",makevars_user())makeargs <-if (!is.na(use_C))sprintf(c("CC='$(CC%s)'", "CFLAGS='$(C%sFLAGS)'"), use_C)else character()p1 <- function(...) paste(..., collapse = " ")cmd <- paste(MAKE,p1("-f", shQuote(makefiles)),p1(makeargs))res <- system(cmd)if (res == 0L) shlib_install(instdir, rarch)else has_error <- TRUEsetwd(owd)} else { ## no src/Makefileowd <- setwd("src")srcs <- dir(pattern = "\\.([cfmM]|cc|cpp|f90|f95|mm)$",all.files = TRUE)## This allows Makevars to set OBJECTS or its own targets.allfiles <- if (file.exists("Makevars")) c("Makevars", srcs) else srcswd2 <- setwd(file.path(R.home("bin"), "exec"))archs <- Sys.glob("*")setwd(wd2)if (length(allfiles)) {use_LTO <-if (!is.na(use_LTO)) use_LTOelseparse_description_field(desc, "UseLTO", default = NA)## if there is an executable configure script we install only the main## sub-architectureif (!multiarch || length(archs) <= 1 ||file_test("-x", "../configure")) {if (nzchar(rarch))starsmsg("***", "arch - ",substr(rarch, 2, 1000))has_error <- run_shlib(pkg_name, srcs, instdir, rarch, use_LTO)} else {setwd(owd)test_archs <- archsfor(arch in archs) {if (arch == "R") {## top-level, so one arch without subdirshas_error <- run_shlib(pkg_name, srcs, instdir, "", use_LTO)} else {starsmsg("***", "arch - ", arch)ss <- paste0("src-", arch)dir.create(ss, showWarnings = FALSE)file.copy(Sys.glob("src/*"), ss, recursive = TRUE)setwd(ss)ra <- paste0("/", arch)## FIXME: do this lower downSys.setenv(R_ARCH = ra)has_error <- run_shlib(pkg_name, srcs, instdir, ra, use_LTO)Sys.setenv(R_ARCH = rarch)setwd(owd)if (has_error) break}}}} else warning("no source files found", call. = FALSE)}setwd(owd)}if (has_error)pkgerrmsg("compilation failed", pkg_name)## if we have subarchs, update DESCRIPTIONfi <- file.info(Sys.glob(file.path(instdir, "libs", "*")))dirs <- basename(row.names(fi[fi$isdir %in% TRUE, ]))## avoid DLLs installed by rogue packagesif(WINDOWS) dirs <- dirs[dirs %in% c("i386", "x64")]if (length(dirs)) {descfile <- file.path(instdir, "DESCRIPTION")olddesc <- readLines(descfile, warn = FALSE)olddesc <- filtergrep("^Archs:", olddesc, useBytes = TRUE)newdesc <- c(olddesc,paste("Archs:", paste(dirs, collapse = ", ")))writeLines(newdesc, descfile, useBytes = TRUE)saveRDS(.split_description(.read_description(descfile)),file.path(instdir, "Meta", "package.rds"))}} else if (multiarch) { # end of src dirif (WINDOWS) {wd2 <- setwd(file.path(R.home(), "bin")) # not R.home("bin")archs <- Sys.glob("*")setwd(wd2)test_archs <- archs[archs %in% c("i386", "x64")]} else {wd2 <- setwd(file.path(R.home("bin"), "exec"))test_archs <- Sys.glob("*")setwd(wd2)}}# if (WINDOWS && "x64" %in% test_archs) {# ## we cannot actually test x64 unless this is 64-bit# ## Windows, even if it is installed.# if (!grepl(" x64 ", utils::win.version())) test_archs <- "i386"#}if (have_cross) Sys.unsetenv("R_ARCH")if (WINDOWS && dir.exists("install_time_patches"))file.copy("install_time_patches", instdir, recursive = TRUE)## R files must start with a letterif (install_R && dir.exists("R") && length(dir("R"))) {starsmsg(stars, "R")dir.create(file.path(instdir, "R"), recursive = TRUE,showWarnings = FALSE)## This cannot be done in a C localeres <- try(.install_package_code_files(".", instdir))if (inherits(res, "try-error"))pkgerrmsg("unable to collate and parse R files", pkg_name)if (file.exists(f <- file.path("R", "sysdata.rda"))) {comp <- TRUE## (We set .libPaths)if(!is.na(lazycompress <- desc["SysDataCompression"])) {comp <- switch(lazycompress,"none" = FALSE,"gzip" = TRUE,"bzip2" = 2L,"xz" = 3L,TRUE) # default to gzip} else if(file.size(f) > 1e6) comp <- 3L # "xz"res <- try(sysdata2LazyLoadDB(f, file.path(instdir, "R"),compress = comp))if (inherits(res, "try-error"))pkgerrmsg("unable to build sysdata DB", pkg_name)}if (fake) {## Fix up hook functions so they do not attempt to## (un)load missing compiled code, initialize ...## This does stop them being tested at all.if (file.exists("NAMESPACE")) {cat("",'.onLoad <- .onAttach <- function(lib, pkg) NULL','.onUnload <- function(libpaths) NULL',sep = "\n",file = file.path(instdir, "R", pkg_name), append = TRUE)## <NOTE>## Tweak fake installation to provide an 'empty'## useDynLib() for the time being. Completely## removing the directive results in checkFF()## being too aggressive in the case where the## presence of the directive enables unambiguous## symbol resolution w/out 'PACKAGE' arguments.## However, empty directives are not really meant## to work ...## encoding issues ... so need useBytes = TRUE## FIXME: some packages have useDynLib()## spread over several lines.writeLines(sub("useDynLib.*", 'useDynLib("")',readLines("NAMESPACE", warn = FALSE),perl = TRUE, useBytes = TRUE),file.path(instdir, "NAMESPACE"))## </NOTE>} else {cat("",'.onLoad <- function (libname, pkgname) NULL','.onAttach <- function (libname, pkgname) NULL','.onDetach <- function(libpath) NULL','.onUnload <- function(libpath) NULL','.Last.lib <- function(libpath) NULL',sep = "\n",file = file.path(instdir, "R", pkg_name), append = TRUE)}}} # end of R## data files must not be hidden: data() may ignore themif (install_data && dir.exists("data") && length(dir("data"))) {starsmsg(stars, "data")files <- Sys.glob(file.path("data", "*")) # ignores dotfilesif (length(files)) {is <- file.path(instdir, "data")dir.create(is, recursive = TRUE, showWarnings = FALSE)file.remove(Sys.glob(file.path(instdir, "data", "*")))file.copy(files, is, TRUE)thislazy <- parse_description_field(desc, "LazyData",default = lazy_data)if (!thislazy && resave_data) {paths <- Sys.glob(c(file.path(is, "*.rda"),file.path(is, "*.RData")))if (length(paths)) {starsmsg(paste0(stars, "*"), "resaving rda files")resaveRdaFiles(paths, compress = "auto")}}Sys.chmod(Sys.glob(file.path(instdir, "data", "*")), fmode)if (thislazy) {starsmsg(paste0(stars, "*"),"moving datasets to lazyload DB")## 'it is possible that data in a package will## make use of the code in the package, so ensure## the package we have just installed is on the## library path.'## (We set .libPaths)lazycompress <- desc["LazyDataCompression"]if(!is.na(lazycompress))data_compress <- switch(lazycompress,"none" = FALSE,"gzip" = TRUE,"bzip2" = 2L,"xz" = 3L,## perhaps error?TRUE) # default to gzipres <- try(data2LazyLoadDB(pkg_name, lib,compress = data_compress))if (inherits(res, "try-error"))pkgerrmsg("lazydata failed", pkg_name)}} else warning("empty 'data' directory", call. = FALSE)}## demos must start with a letterif (install_demo && dir.exists("demo") && length(dir("demo"))) {starsmsg(stars, "demo")dir.create(file.path(instdir, "demo"), recursive = TRUE,showWarnings = FALSE)file.remove(Sys.glob(file.path(instdir, "demo", "*")))res <- try(.install_package_demos(".", instdir))if (inherits(res, "try-error"))pkgerrmsg("installing demos failed", pkg_name)Sys.chmod(Sys.glob(file.path(instdir, "demo", "*")), fmode)}## dotnames are ignored.if (install_exec && dir.exists("exec") && length(dir("exec"))) {starsmsg(stars, "exec")dir.create(file.path(instdir, "exec"), recursive = TRUE,showWarnings = FALSE)file.remove(Sys.glob(file.path(instdir, "exec", "*")))files <- Sys.glob(file.path("exec", "*"))if (length(files)) {file.copy(files, file.path(instdir, "exec"), TRUE)if (!WINDOWS)Sys.chmod(Sys.glob(file.path(instdir, "exec", "*")), dmode)}}if (install_inst && dir.exists("inst") &&length(dir("inst", all.files = TRUE)) > 2L) {starsmsg(stars, "inst")i_dirs <- list.dirs("inst")[-1L] # not inst itselfi_dirs <- filtergrep(.vc_dir_names_re, i_dirs)## This ignores any restrictive permissions in the source## tree, since the later .Call(C_dirchmod) call will## fix the permissions.## handle .Rinstignore:ignore_file <- ".Rinstignore"ignore <- if (file.exists(ignore_file)) {ignore <- readLines(ignore_file, warn = FALSE)ignore[nzchar(ignore)]} else character()for(e in ignore)i_dirs <- filtergrep(e, i_dirs, perl = TRUE, ignore.case = TRUE)lapply(gsub("^inst", quote_replacement(instdir), i_dirs),function(p) dir.create(p, FALSE, TRUE)) # be paranoidi_files <- list.files("inst", all.files = TRUE,full.names = TRUE, recursive = TRUE)i_files <- filtergrep(.vc_dir_names_re, i_files)for(e in ignore)i_files <- filtergrep(e, i_files, perl = TRUE, ignore.case = TRUE)i_files <- i_files %w/o% c("inst/doc/Rplots.pdf","inst/doc/Rplots.ps")i_files <- filtergrep("inst/doc/.*[.](log|aux|bbl|blg|dvi)$",i_files, perl = TRUE, ignore.case = TRUE)## Temporary kludgeif (!dir.exists("vignettes") && pkgname %notin% c("RCurl"))i_files <- filtergrep("inst/doc/.*[.](png|jpg|jpeg|gif|ps|eps)$",i_files, perl = TRUE, ignore.case = TRUE)i_files <- i_files %w/o% "Makefile"i2_files <- gsub("^inst", quote_replacement(instdir), i_files)file.copy(i_files, i2_files)if (!WINDOWS) {## make executable if the source file was (for owner)modes <- file.mode(i_files)execs <- as.logical(modes & as.octmode("100"))Sys.chmod(i2_files[execs], dmode)}if (compact_docs) {pdfs <- dir(file.path(instdir, "doc"), pattern="\\.pdf",recursive = TRUE, full.names = TRUE,all.files = TRUE)res <- compactPDF(pdfs, gs_quality = "none")## print selectivelyprint(res[res$old > 1e5, ])}}rait <- Sys.getenv("R_ALWAYS_INSTALL_TESTS", "FALSE")install_tests <- install_tests || config_val_to_logical(rait)if (install_tests && dir.exists("tests") &&length(dir("tests", all.files = TRUE)) > 2L) {starsmsg(stars, "tests")file.copy("tests", instdir, recursive = TRUE)}## LazyLoading/Compilingif (install_R && dir.exists("R") && length(dir("R"))) {BC <- if (!is.na(byte_compile)) byte_compileelseparse_description_field(desc, "ByteCompile", default = TRUE)rcps <- Sys.getenv("R_COMPILE_PKGS")rcp <- switch(rcps,"TRUE"=, "true"=, "True"=, "yes"=, "Yes"= 1,"FALSE"=,"false"=,"False"=, "no"=, "No" = 0,as.numeric(rcps))if (!is.na(rcp))BC <- (rcp > 0)if (BC) {starsmsg(stars,"byte-compile and prepare package for lazy loading")## need to disable JITcmd <- c("Sys.setenv(R_ENABLE_JIT = 0L)","invisible(compiler::enableJIT(0))","invisible(compiler::compilePKGS(1L))","compiler::setCompilerOptions(suppressAll = FALSE)","compiler::setCompilerOptions(suppressUndefined = TRUE)","compiler::setCompilerOptions(suppressNoSuperAssignVar = TRUE);")} else {starsmsg(stars, "preparing package for lazy loading")cmd <- ""}keep.source <-parse_description_field(desc, "KeepSource",default = keep.source)## Some people change current directory in their R profile, but## at least .getRequiredPackages needs to find the DESCRIPTION## filecmd <- append(cmd, paste0("setwd(", quote_path(getwd()), ")"))## Something above, e.g. lazydata, might have loaded the namespacecmd <- append(cmd,paste0("if (isNamespaceLoaded(\"",pkg_name, "\"))"," unloadNamespace(\"", pkg_name, "\")"))cmd <- append(cmd,"suppressPackageStartupMessages(.getRequiredPackages(quietly = TRUE))")if (pkg_staged_install)set.install.dir <- paste0(", set.install.dir = ",quote_path(final_instdir))elseset.install.dir <- ""cmd <- append(cmd,paste0("tools:::makeLazyLoading(\"", pkg_name, "\", ",quote_path(lib), ", ","keep.source = ", keep.source, ", ","keep.parse.data = ", keep.parse.data,set.install.dir, ")"))cmd <- paste(cmd, collapse="\n")out <- R_runR_deps_only(cmd,setRlibs(LinkingTo = TRUE, quote = TRUE))if(length(out))cat(paste(c(out, ""), collapse = "\n"))if(length(attr(out, "status")))pkgerrmsg("lazy loading failed", pkg_name)}if (install_help) {starsmsg(stars, "help")if (!dir.exists("man") ||!length(list_files_with_type("man", "docs")))cat("No man pages found in package ", sQuote(pkg_name), "\n")encoding <- desc["Encoding"]if (is.na(encoding)) encoding <- "unknown"res <- try(.install_package_Rd_objects(".", instdir, encoding))if (inherits(res, "try-error"))pkgerrmsg("installing Rd objects failed", pkg_name)starsmsg(paste0(stars, "*"), "installing help indices")## always want HTML package index.writePkgIndices(pkg_dir, instdir)if (build_help) {## This is used as the default outputEncoding for latexoutenc <- desc["Encoding"]if (is.na(outenc)) outenc <- "UTF-8".convertRdfiles(pkg_dir, instdir,types = build_help_types,outenc = outenc)}if (dir.exists(figdir <- file.path(pkg_dir, "man", "figures"))) {starsmsg(paste0(stars, "*"), "copying figures")dir.create(destdir <- file.path(instdir, "help", "figures"))file.copy(Sys.glob(c(file.path(figdir, "*.png"),file.path(figdir, "*.jpg"),file.path(figdir, "*.jpeg"),file.path(figdir, "*.svg"),file.path(figdir, "*.pdf"))), destdir)}}## pkg indices: this also tangles the vignettes (if installed)if (install_inst || install_demo || install_help) {starsmsg(stars, "building package indices")cmd <- c("tools:::.install_package_indices(\".\",",quote_path(instdir), ")")cmd <- paste(cmd, collapse="\n")out <- R_runR_deps_only(cmd,setRlibs(LinkingTo = TRUE, quote = TRUE))if(length(out))cat(paste(c(out, ""), collapse = "\n"))if (length(attr(out, "status")))errmsg("installing package indices failed")if(dir.exists("vignettes")) {starsmsg(stars, "installing vignettes")enc <- desc["Encoding"]if (is.na(enc)) enc <- ""if (!fake &&file_test("-f", file.path("build", "vignette.rds")))installer <- .install_package_vignettes3else## handle pre-3.0.2 tarballs## and installation from package sources,## including by temp_install_pkg() during R CMD buildinstaller <- .install_package_vignettes2res <- try(installer(".", instdir, enc))if (inherits(res, "try-error"))errmsg("installing vignettes failed")}}## Install a dump of the parsed NAMESPACE file## For a fake install, use the modified NAMESPACE file we installedif (install_R && file.exists("NAMESPACE")) {res <- try(.install_package_namespace_info(if(fake) instdir else ".", instdir))if (inherits(res, "try-error"))errmsg("installing namespace metadata failed")}if (clean) run_clean()do_test_load <- function(extra_cmd = NULL) {## Do this in a separate R process, in case it crashes R.## FIXME: maybe the quoting as 'lib' is not quite good enough## On a Unix-alike this calls system(input=)## and that uses a temporary file and redirection.cmd <- paste0("tools:::.test_load_package('", pkg_name, "', ", quote_path(lib), ")")if (!is.null(extra_cmd))cmd <- paste0(cmd, "\n", extra_cmd)## R_LIBS was set already, but Rprofile/Renviron may change ittlim <- get_timeout(Sys.getenv("_R_INSTALL_TEST_LOAD_ELAPSED_TIMEOUT_"))if (length(test_archs) > 1L) {msgs <- character()for (arch in test_archs) {starsmsg("***", "arch - ", arch)out <- R_runR_deps_only(cmd,deps_only_env = setRlibs(lib0, self = TRUE, quote = TRUE),arch = arch, timeout = tlim, multiarch = TRUE)if(length(attr(out, "status")))msgs <- c(msgs, arch)if(length(out))cat(paste(c(out, ""), collapse = "\n"))}if (length(msgs)) {msg <- paste("loading failed for",paste(sQuote(msgs), collapse = ", "))errmsg(msg) # does not return}} else {out <- R_runR_deps_only(cmd,deps_only_env = setRlibs(lib0, self = TRUE, quote = TRUE),timeout = tlim)if(length(out)) {cat(paste(c(out, ""), collapse = "\n"))}if(length(attr(out, "status")))errmsg("loading failed") # does not return}}if (test_load && !have_cross) {if (pkg_staged_install)starsmsg(stars,"testing if installed package can be loaded from temporary location")elsestarsmsg(stars, "testing if installed package can be loaded")do_test_load()}if (pkg_staged_install) {if (WINDOWS) {unlink(final_instdir, recursive = TRUE) # needed for file.renameif (!file.rename(instdir, final_instdir)) {if (dir.exists(instdir) && !dir.exists(final_instdir)) {message("WARNING: moving package to final location failed, copying instead")ret <- file.copy(instdir, dirname(final_instdir),recursive = TRUE, copy.date = TRUE)if (any(!ret))errmsg(" copying to final location failed")unlink(instdir, recursive = TRUE)} elseerrmsg(" moving to final location failed")}} else {patch_rpaths()unlink(final_instdir, recursive = TRUE)# needed for mv on some file systems, even though# according to POSIX mv should work when the target is an# empty directoryowd <- setwd(startdir)status <- system(paste("mv -f",shQuote(instdir),shQuote(dirname(final_instdir))))if (status) errmsg(" moving to final location failed")setwd(owd)}instdir <- final_instdirlib <- final_libSys.setenv(R_PACKAGE_DIR = final_rpackagedir)Sys.setenv(R_LIBS = final_rlibs).libPaths(final_libpaths)if (test_load) {starsmsg(stars,"testing if installed package can be loaded from final location")# The test for hard-coded installation path is done together# with test loading to save time. The test is intentionally# run on a loaded package, to allow for paths to be fixed in# .onLoad and loadNamespace().serf <- tempfile()cmd <- paste0("f <- base::file(", quote_path(serf),", \"wb\")")cmd <- append(cmd,paste0("base::invisible(base::suppressWarnings(base::serialize(","base::as.list(base::getNamespace(\"", pkg_name, "\"), all.names=TRUE), f)))"))cmd <- append(cmd, "base::close(f)")do_test_load(extra_cmd = paste(cmd, collapse = "\n"))starsmsg(stars,"testing if installed package keeps a record of temporary installation path")r <- readBin(serf, "raw", n=file.size(serf))unlink(serf)if (length(grepRaw("00new", r, fixed = TRUE, all = FALSE,value = FALSE)))errmsg("hard-coded installation path: ","please report to the package maintainer and use ",sQuote("--no-staged-install"))}}if (do_strip_lib &&nzchar(strip_cmd <- Sys.getenv("R_STRIP_STATIC_LIB")) &&length(a_s <- Sys.glob(file.path(file.path(lib, curPkg),"lib", "*.a")))) {if(length(a_s) > 1L)starsmsg(stars, "stripping static libraries under lib")elsestarsmsg(stars, "stripping static library under lib")system(paste(c(strip_cmd, shQuote(a_s)), collapse = " "))}if (do_strip_lib &&nzchar(strip_cmd <- Sys.getenv("R_STRIP_SHARED_LIB")) &&length(so_s <- Sys.glob(file.path(file.path(lib, curPkg), "lib",paste0("*", SHLIB_EXT))))) {if(length(so_s) > 1L)starsmsg(stars, "stripping dynamic libraries under lib")elsestarsmsg(stars, "stripping dynamic library under lib")system(paste(c(strip_cmd, shQuote(so_s)), collapse = " "))}} ## do_install_sourceoptions(showErrorCalls = FALSE)pkgs <- character()if (is.null(args)) {args <- commandArgs(TRUE)## it seems that splits on spaces, so try harder.args <- paste(args, collapse = " ")args <- strsplit(args,'nextArg', fixed = TRUE)[[1L]][-1L]}args0 <- argsstartdir <- getwd()if (is.null(startdir))stop("current working directory cannot be ascertained")lib <- lib0 <- ""clean <- FALSEpreclean <- FALSEdebug <- FALSEstatic_html <- nzchar(system.file("html", "mean.html", package="base"))build_html <- static_htmlbuild_latex <- FALSEbuild_example <- FALSEuse_configure <- TRUEconfigure_args <- character()configure_vars <- character()fake <- FALSE## lazy <- TRUElazy_data <- FALSEbyte_compile <- NA # means take from DESCRIPTION file.staged_install <- NA # means not given by command line argument## Next is not very useful unless R CMD INSTALL reads a startup filelock <- getOption("install.lock", NA) # set for overall or per-packagepkglock <- FALSE # set for per-package lockinglibs_only <- FALSEtar_up <- zip_up <- FALSEsign <- FALSEshargs <- character()multiarch <- TRUEforce_biarch <- FALSEforce_both <- FALSEtest_load <- TRUEmerge <- FALSEdsym <- nzchar(Sys.getenv("PKG_MAKE_DSYM"))get_user_libPaths <- FALSEdata_compress <- TRUE # FALSE (none), TRUE (gzip), 2 (bzip2), 3 (xz)resave_data <- FALSEcompact_docs <- FALSEkeep.source <- getOption("keep.source.pkgs")keep.parse.data <- getOption("keep.parse.data.pkgs")use_LTO <- NA # means take from DESCRIPTION file.use_C <- NA # means take from DESCRIPTION file.built_stamp <- character()install_libs <- TRUEinstall_R <- TRUEinstall_data <- TRUEinstall_demo <- TRUEinstall_exec <- TRUEinstall_inst <- TRUEinstall_help <- TRUEinstall_tests <- FALSEdo_strip <- do_strip_lib <- FALSEwhile(length(args)) {a <- args[1L]if (a %in% c("-h", "--help")) {Usage()do_exit(0)}else if (a %in% c("-v", "--version")) {cat("R add-on package installer: ",R.version[["major"]], ".", R.version[["minor"]]," (r", R.version[["svn rev"]], ")\n", sep = "")cat("",.R_copyright_msg(2000),"This is free software; see the GNU General Public License version 2","or later for copying conditions. There is NO warranty.",sep = "\n")do_exit(0)} else if (a %in% c("-c", "--clean")) {clean <- TRUEshargs <- c(shargs, "--clean")} else if (a == "--preclean") {preclean <- TRUEshargs <- c(shargs, "--preclean")} else if (a %in% c("-d", "--debug")) {debug <- TRUE} else if (a == "--no-configure") {use_configure <- FALSE} else if (a == "--no-docs") {build_html <- build_latex <- build_example <- FALSE} else if (a == "--no-html") {build_html <- FALSE} else if (a == "--html") {build_html <- TRUE} else if (a == "--latex") {build_latex <- TRUE} else if (a == "--example") {build_example <- TRUE} else if (a == "-l") {if (length(args) >= 2L) {lib <- args[2L]; args <- args[-1L]}else stop("-l option without value", call. = FALSE)} else if (substr(a, 1, 10) == "--library=") {lib <- substr(a, 11, 1000)} else if (substr(a, 1, 17) == "--configure-args=") {configure_args <- c(configure_args, substr(a, 18, 1000))} else if (substr(a, 1, 17) == "--configure-vars=") {configure_vars <- c(configure_vars, substr(a, 18, 1000))} else if (a == "--fake") {fake <- TRUE} else if (a == "--no-lock") {lock <- pkglock <- FALSE} else if (a == "--lock") {lock <- TRUE; pkglock <- FALSE} else if (a == "--pkglock") {lock <- pkglock <- TRUE} else if (a == "--libs-only") {libs_only <- TRUE} else if (a == "--no-multiarch") {multiarch <- FALSE## } else if (a == "--force-biarch") {## force_biarch <- TRUE## } else if (a == "--compile-both") {## force_both <- TRUE} else if (a == "--maybe-get-user-libPaths") {get_user_libPaths <- TRUE} else if (a == "--build") {if (WINDOWS) zip_up <- TRUE else tar_up <- TRUE} else if (a == "--sign") {sign <- TRUE} else if (substr(a, 1, 16) == "--data-compress=") {dc <- substr(a, 17, 1000)dc <- match.arg(dc, c("none", "gzip", "bzip2", "xz"))data_compress <- switch(dc,"none" = FALSE,"gzip" = TRUE,"bzip2" = 2,"xz" = 3)} else if (a == "--resave-data") {resave_data <- TRUE} else if (a == "--install-tests") {install_tests <- TRUE} else if (a == "--no-inst") {install_inst <- FALSE} else if (a == "--no-R") {install_R <- FALSE} else if (a == "--no-libs") {install_libs <- FALSE} else if (a == "--no-data") {install_data <- FALSE} else if (a == "--no-demo") {install_demo <- FALSE} else if (a == "--no-exec") {install_exec <- FALSE} else if (a == "--no-help") {install_help <- FALSE} else if (a == "--no-test-load") {test_load <- FALSE} else if (a == "--no-clean-on-error") {clean_on_error <- FALSE} else if (a == "--merge-multiarch") {merge <- TRUE} else if (a == "--compact-docs") {compact_docs <- TRUE} else if (a == "--with-keep.source") {keep.source <- TRUE} else if (a == "--without-keep.source") {keep.source <- FALSE} else if (a == "--with-keep.parse.data") {keep.parse.data <- TRUE} else if (a == "--without-keep.parse.data") {keep.parse.data <- FALSE} else if (a == "--byte-compile") {byte_compile <- TRUE} else if (a == "--no-byte-compile") {byte_compile <- FALSE} else if (a == "--use-LTO") {use_LTO <- TRUE} else if (a == "--no-use-LTO") {use_LTO <- FALSE} else if (a == "--use-C17") {use_C <- 17} else if (a == "--use-C23") {use_C <- 23} else if (a == "--use-C90") {use_C <- 90} else if (a == "--use-C99") {use_C <- 99} else if (a == "--staged-install") {staged_install <- TRUE} else if (a == "--no-staged-install") {staged_install <- FALSE} else if (a == "--dsym") {dsym <- TRUE} else if (a == "--strip") {do_strip <- TRUE} else if (a == "--strip-lib") {do_strip_lib <- TRUE} else if (substr(a, 1, 18) == "--built-timestamp=") {built_stamp <- substr(a, 19, 1000)} else if (startsWith(a, "-")) {message("Warning: unknown option ", sQuote(a), domain = NA)} else pkgs <- c(pkgs, a)args <- args[-1L]}if (keep.tmpdir) {make_tmpdir <- function(prefix, nchars = 8, ntries = 100) {for(i in 1:ntries) {name <- paste(sample(c(0:9, letters, LETTERS), nchars, replace=TRUE), collapse="")path <- paste(prefix, name, sep = "/")if (dir.create(path, showWarnings = FALSE, recursive = T)) {return(path)}}stop("cannot create unique directory for build")}tmpdir <- make_tmpdir(user.tmpdir)} else {tmpdir <- tempfile("R.INSTALL")if (!dir.create(tmpdir))stop("cannot create temporary directory")}if (merge) {if (length(pkgs) != 1L || !file_test("-f", pkgs))stop("ERROR: '--merge-multiarch' applies only to a single tarball",call. = FALSE)if (WINDOWS) {f <- dir(file.path(R.home(), "bin"))archs <- f[f %in% c("i386", "x64")]if (length(archs) > 1L) {args <- args0 %w/o% c("--merge-multiarch", "--build")## this will report '* DONE (foo)' if it works, which## R CMD check treats as an indication of success.## so use a backdoor to suppress it.Sys.setenv("_R_INSTALL_NO_DONE_" = "yes")for (arch in archs) {cmd <- c(shQuote(file.path(R.home(), "bin", arch,"Rcmd.exe")),"INSTALL", shQuote(args), "--no-multiarch")if (arch == "x64") {## this will suppress stars message "using## non-staged installation", which could otherwise## be turned into R CMD check noteSys.setenv("_R_INSTALL_SUPPRESS_NO_STAGED_MESSAGE_" = "yes")cmd <- c(cmd, "--libs-only --no-staged-install",if(zip_up) "--build")Sys.unsetenv("_R_INSTALL_NO_DONE_")}cmd <- paste(cmd, collapse = " ")if (debug) message("about to run ", cmd, domain = NA)message("\n", "install for ", arch, "\n", domain = NA)res <- system(cmd)if (arch == "x64")Sys.unsetenv("_R_INSTALL_SUPPRESS_NO_STAGED_MESSAGE_")if(res) break}}} else {archs <- dir(file.path(R.home("bin"), "exec"))if (length(archs) > 1L) {args <- args0 %w/o% c("--merge-multiarch", "--build")## this will report '* DONE (foo)' if it works, which## R CMD check treats as an indication of success.## so use a backdoor to suppress it.Sys.setenv("_R_INSTALL_NO_DONE_" = "yes")last <- archs[length(archs)]for (arch in archs) {cmd <- c(shQuote(file.path(R.home("bin"), "R")),"--arch", arch, "CMD","INSTALL", shQuote(args), "--no-multiarch")if (arch != archs[1L]) {## this will suppress stars message "using## non-staged installation", which could otherwise## be turned into R CMD check noteSys.setenv("_R_INSTALL_SUPPRESS_NO_STAGED_MESSAGE_" = "yes")cmd <- c(cmd, "--libs-only --no-staged-install")}if (arch == last) {Sys.unsetenv("_R_INSTALL_NO_DONE_")if(tar_up) cmd <- c(cmd, "--build")}cmd <- paste(cmd, collapse = " ")if (debug) message("about to run ", cmd, domain = NA)message("\n", "install for ", arch, "\n", domain = NA)res <- system(cmd)if (arch != archs[1L])Sys.unsetenv("_R_INSTALL_SUPPRESS_NO_STAGED_MESSAGE_")if(res) break}}}if (length(archs) > 1L) {if (res) do_exit_on_error()do_cleanup()on.exit()return(invisible())}message("only one architecture so ignoring '--merge-multiarch'",domain = NA)}## now unpack tarballs and do some basic checksallpkgs <- character()for(pkg in pkgs) {if (debug) message("processing ", sQuote(pkg), domain = NA)if (file_test("-f", pkg)) {if (WINDOWS && endsWith(pkg, ".zip")) {if (debug) message("a zip file", domain = NA)pkgname <- basename(pkg)pkgname <- sub("\\.zip$", "", pkgname)pkgname <- sub("_[0-9.-]+$", "", pkgname)allpkgs <- c(allpkgs, pkg)next}if (debug) message("a file", domain = NA)of <- dir(tmpdir, full.names = TRUE)## force the use of internal untar unless over-ridden## so e.g. .tar.xz works everywhereif (utils::untar(pkg, exdir = tmpdir,tar = Sys.getenv("R_INSTALL_TAR", "internal")))errmsg("error unpacking tarball")## Now see what we gotnf <- dir(tmpdir, full.names = TRUE)new <- nf %w/o% ofif (!length(new))errmsg("cannot extract package from ", sQuote(pkg))if (length(new) > 1L)errmsg("extracted multiple files from ", sQuote(pkg))if (dir.exists(new)) pkgname <- basename(new)else errmsg("cannot extract package from ", sQuote(pkg))if (file.exists(file.path(tmpdir, pkgname, "DESCRIPTION"))) {allpkgs <- c(allpkgs, file.path(tmpdir, pkgname))} else errmsg("cannot extract package from ", sQuote(pkg))} else if (file.exists(file.path(pkg, "DESCRIPTION"))) {if (debug) message("a directory", domain = NA)pkgname <- basename(pkg)allpkgs <- c(allpkgs, fullpath(pkg))} else {warning("invalid package ", sQuote(pkg), call. = FALSE)next}}if (!length(allpkgs))stop("ERROR: no packages specified", call.=FALSE)if (!nzchar(lib)) {lib <- if (get_user_libPaths) { ## need .libPaths()[1L] *after* the site- and user-initializationsystem(paste(shQuote(file.path(R.home("bin"), "Rscript")),"-e 'cat(.libPaths()[1L])'"),intern = TRUE)}else .libPaths()[1L]starsmsg(stars, "installing to library ", sQuote(lib))} else {lib0 <- lib <- path.expand(lib)## lib is allowed to be a relative path.## should be OK below, but be sure.cwd <- tryCatch(setwd(lib), error = function(e)stop(gettextf("ERROR: cannot cd to directory %s", sQuote(lib)),call. = FALSE, domain = NA))lib <- getwd()setwd(cwd)}ok <- dir.exists(lib)if (ok) {if (WINDOWS) {## file.access is unreliable on Windows## the only known reliable way is to try itfn <- 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)} else ok <- file.access(lib, 2L) == 0L}if (!ok)stop("ERROR: no permission to install to directory ",sQuote(lib), call. = FALSE)group.writable <- if(WINDOWS) FALSE else {## install package group-writable iff in group-writable libd <- as.octmode("020")(file.mode(lib) & d) == d ## TRUE iff g-bit is "w"}if (libs_only) {install_R <- FALSEinstall_data <- FALSEinstall_demo <- FALSEinstall_exec <- FALSEinstall_inst <- FALSEinstall_help <- FALSE}more_than_libs <- !libs_only## if(!WINDOWS && !more_than_libs) test_load <- FALSEmk_lockdir <- function(lockdir){if (file.exists(lockdir)) {message("ERROR: failed to lock directory ", sQuote(lib)," for modifying\nTry removing ", sQuote(lockdir),domain = NA)do_cleanup_tmpdir()do_exit(status = 3)}dir.create(lockdir, recursive = TRUE)if (!dir.exists(lockdir)) {message("ERROR: failed to create lock directory ", sQuote(lockdir),domain = NA)do_cleanup_tmpdir()do_exit(status = 3)}if (debug) starsmsg(stars, "created lock directory ", sQuote(lockdir))}if (is.na(lock)) {lock <- TRUEpkglock <- length(allpkgs) == 1L}if (lock && !pkglock) {lockdir <- file.path(lib, "00LOCK")mk_lockdir(lockdir)}if (is.na(staged_install)) {# environment variable intended as temporaryrsi <- Sys.getenv("R_INSTALL_STAGED")rsi <- switch(rsi,"TRUE"=, "true"=, "True"=, "yes"=, "Yes"= 1,"FALSE"=,"false"=,"False"=, "no"=, "No" = 0,as.numeric(rsi))if (!is.na(rsi))staged_install <- (rsi > 0)elsestaged_install <- TRUE}if ((tar_up || zip_up) && fake)stop("building a fake installation is disallowed")if (fake) {use_configure <- FALSEif("--html" %notin% args0)build_html <- FALSEbuild_latex <- FALSEbuild_example <- FALSEinstall_libs <- FALSEinstall_demo <- FALSEinstall_exec <- FALSE# install_inst <- FALSE}build_help_types <- character()if (build_html) build_help_types <- c(build_help_types, "html")if (build_latex) build_help_types <- c(build_help_types, "latex")if (build_example) build_help_types <- c(build_help_types, "example")build_help <- length(build_help_types) > 0Lif (debug)starsmsg(stars, "build_help_types=",paste(build_help_types, collapse = " "))if (debug)starsmsg(stars, "DBG: 'R CMD INSTALL' now doing do_install()")for(pkg in allpkgs) {if (pkglock) {lockdir <- file.path(lib, paste0("00LOCK-", basename(pkg)))mk_lockdir(lockdir)}do_install(pkg)}do_cleanup()on.exit()invisible()} ## .install_packages()## for R CMD SHLIB on all platforms.SHLIB <- function(){status <- .shlib_internal(commandArgs(TRUE))q("no", status = (status != 0), runLast=FALSE)}## for .SHLIB and R CMD INSTALL on all platforms.shlib_internal <- function(args){Usage <- function()cat("Usage: R CMD SHLIB [options] files | linker options","","Build a shared object for dynamic loading from the specified source or","object files (which are automagically made from their sources) or","linker options. If not given via '--output', the name for the shared","object is determined from the first source or object file.","","Options:"," -h, --help print short help message and exit"," -v, --version print version info and exit"," -o, --output=LIB use LIB as (full) name for the built library"," -c, --clean remove files created during compilation"," --preclean remove files created during a previous run"," -n, --dry-run dry run, showing commands that would be used"," --use-LTO use Link-Time Optimization"," --no-use-LTO do not use Link-Time Optimization"," --use-C17 use a C standard at most C17 (alsp C90, C99)"," --use-C23 use a C standard at least C23","","Windows only:"," -d, --debug build a debug DLL","","Report bugs at <https://bugs.R-project.org>.",sep = "\n")## FIXME shQuote here?p1 <- function(...) paste(..., collapse = " ")WINDOWS <- .Platform$OS.type == "windows"cross <- Sys.getenv("R_CROSS_BUILD")if(nzchar(cross)) {if(!cross %in% c("x64", "singlearch"))stop(gettextf("invalid value for '%s' : %s","R_CROSS_BUILD", sQuote(cross)),domain = NA)WINDOWS <- TRUESys.setenv(R_ARCH = if (cross == "singlearch") "" else paste0("/", cross))}if (!WINDOWS) {mconf <- readLines(file.path(paste0(R.home("etc"), Sys.getenv("R_ARCH")),"Makeconf"))SHLIB_EXT <- sub(".*= ", "", grep("^SHLIB_EXT", mconf, value = TRUE,perl = TRUE))SHLIB_LIBADD <- sub(".*= ", "", grep("^SHLIB_LIBADD", mconf,value = TRUE, perl = TRUE))MAKE <- Sys.getenv("MAKE")rarch <- Sys.getenv("R_ARCH")} else {rhome <- chartr("\\", "/", R.home())Sys.setenv(R_HOME = rhome)SHLIB_EXT <- ".dll"SHLIB_LIBADD <- ""MAKE <- "make"## Formerly for winshlib.mk to pick up Makeconfrarch <- Sys.getenv("R_ARCH", NA_character_)if(is.na(rarch)) {if (nzchar(.Platform$r_arch)) {rarch <- paste0("/", .Platform$r_arch)Sys.setenv(R_ARCH = rarch)} else rarch <- ""}}OBJ_EXT <- ".o" # all currrent compilers, but not some on Windows## The order of inclusion of Makefiles on a Unix-alike is## package's src/Makevars## etc/Makeconf## site Makevars## share/make/shlib.mk## user Makevars## and similarly elsewhereobjs <- character()shlib <- ""makefiles <-c(file.path(paste0(R.home("etc"), rarch), "Makeconf"),makevars_site(),file.path(R.home("share"), "make",if (WINDOWS) "winshlib.mk" else "shlib.mk"))shlib_libadd <- if (nzchar(SHLIB_LIBADD)) SHLIB_LIBADD else character()with_c <- FALSEwith_cxx <- FALSEwith_f77 <- FALSEwith_f9x <- FALSEwith_objc <- FALSEuse_cxxstd <- NULLuse_fc_link <- FALSEuse_lto <- NAuse_C <- ""pkg_libs <- character()clean <- FALSEpreclean <- FALSEdry_run <- FALSEdebug <- FALSEwhile(length(args)) {a <- args[1L]if (a %in% c("-h", "--help")) {Usage()return(0L)}else if (a %in% c("-v", "--version")) {cat("R shared object builder: ",R.version[["major"]], ".", R.version[["minor"]]," (r", R.version[["svn rev"]], ")\n", sep = "")cat("",.R_copyright_msg(2000),"This is free software; see the GNU General Public License version 2","or later for copying conditions. There is NO warranty.",sep = "\n")return(0L)} else if (a %in% c("-n", "--dry-run")) {dry_run <- TRUE} else if (a %in% c("-d", "--debug")) {debug <- TRUE} else if (a %in% c("-c", "--clean")) {clean <- TRUE} else if (a == "--preclean") {preclean <- TRUE} else if (a == "--use-LTO") {use_lto <- TRUE} else if (a == "--no-use-LTO") {use_lto <- FALSE} else if (a == "--use-C17") {use_C <- 17} else if (a == "--use-C23") {use_C <- 23} else if (a == "--use-C90") {use_C <- 90} else if (a == "--use-C99") {use_C <- 99} else if (a == "-o") {if (length(args) >= 2L) {shlib <- args[2L]; args <- args[-1L]}else stop("-o option without value", call. = FALSE)} else if (substr(a, 1, 9) == "--output=") {shlib <- substr(a, 10, 1000)} else {## a source file or something like -Ldir -lfoobase <- sub("\\.[[:alnum:]]*$", "", a)ext <- sub(paste0(base, "."), "", a, fixed = TRUE)nobj <- ""if (nzchar(ext)) {## This will not work if there are no source files in## the top-level directoryif (ext %in% c("cc", "cpp")) {with_cxx <- TRUEnobj <- base} else if (ext == "m") {with_objc <- TRUEnobj <- base} else if (ext %in% c("mm", "M")) {## ObjC++ implies ObjC because we need ObjC runtime## ObjC++ implies C++ because we use C++ linkerwith_objc <- with_cxx <- TRUEnobj <- base} else if (ext == "f") {with_f77 <- TRUEnobj <- base} else if (ext %in% c("f90", "f95")) {with_f9x <- TRUEnobj <- base} else if (ext == "c") {with_c <- TRUEnobj <- base} else if (ext == "o") {nobj <- base}if (nzchar(nobj) && !nzchar(shlib))shlib <- paste0(nobj, SHLIB_EXT)}if (nzchar(nobj)) objs <- c(objs, nobj)else pkg_libs <- c(pkg_libs, a)}args <- args[-1L]}if (length(objs)) objs <- paste0(objs, OBJ_EXT, collapse = " ")makefiles <- c(makefiles, makevars_user())makeobjs <- paste0("OBJECTS=", shQuote(objs))if (WINDOWS && (file.exists(fn <- "Makevars.ucrt") || file.exists(fn <- "Makevars.win"))) {makefiles <- c(fn, makefiles)lines <- readLines(fn, warn = FALSE)if (length(grep("^OBJECTS *=", lines, perl=TRUE, useBytes = TRUE)))makeobjs <- ""if (length(ll <- grep("^CXX_STD *=", lines, perl = TRUE,value = TRUE, useBytes = TRUE)) == 1) {val <- gsub("^CXX_STD *= *CXX", "", ll)val <- gsub("#.*$", "", val)val <- gsub(" +$", "", val)if (val %in% cxx_standards) {use_cxxstd <- valwith_cxx <- TRUE} else {val <- gsub("^CXX_STD *= *", "", ll)val <- gsub("#.*$", "", val)val <- gsub(" +$", "", val)msg <- sprintf("src/%s: Unknown C++ standard %s was ignored", fn, sQuote(val))warning(msg, domain = NA, call. = FALSE)}}if (any(grepl("^USE_FC_TO_LINK", lines, perl=TRUE, useBytes = TRUE)))use_fc_link <- TRUE} else if (file.exists("Makevars")) {makefiles <- c("Makevars", makefiles)lines <- readLines("Makevars", warn = FALSE)if (length(grep("^OBJECTS *=", lines, perl = TRUE, useBytes = TRUE)))makeobjs <- ""if (length(ll <- grep("^CXX_STD *=", lines, perl = TRUE,value = TRUE, useBytes = TRUE)) == 1) {val <- gsub("^CXX_STD *= *CXX", "", ll)val <- gsub("#.*$", "", val)val <- gsub(" +$", "", val)if (val %in% cxx_standards) {use_cxxstd <- valwith_cxx <- TRUE} else {val <- gsub("^CXX_STD *= *", "", ll)val <- gsub("#.*$", "", val)val <- gsub(" +$", "", val)msg <- sprintf("src/Makevars: Unknown C++ standard %s was ignored", sQuote(val))warning(msg, domain = NA, call. = FALSE)}}if (any(grepl("^USE_FC_TO_LINK", lines, perl=TRUE, useBytes = TRUE)))use_fc_link <- TRUE}if (is.null(use_cxxstd)) {for (i in cxx_standards) {if (nzchar(Sys.getenv(paste0("USE_CXX", i)))) {use_cxxstd <- ibreak}}}val <- Sys.getenv("R_PKG_CXX_STD")if (is.null(use_cxxstd)) {if (val %in% cxx_standards) {use_cxxstd <- val}} else if (nzchar(val) && (val != use_cxxstd)) {warning("SystemRequirements and Makevars* specified different C++ standards", domain = NA, call. = FALSE)}if (with_cxx) {checkCXX <- function(cxxstd) {for (i in rev(seq_along(makefiles))) {lines <- readLines(makefiles[i], warn = FALSE)pattern <- paste0("^CXX", cxxstd, " *= *")ll <- grep(pattern, lines, perl = TRUE, value = TRUE,useBytes = TRUE)for (j in rev(seq_along(ll))) {cxx <- gsub(pattern, "", ll[j])return(nzchar(cxx))}}return(FALSE)}if (!is.null(use_cxxstd)) {if (use_cxxstd == "98") {stop("C++98 standard requested but unsupported",call. = FALSE, domain = NA)}if (use_cxxstd %in% c("11", "14")) {message("specified C++", use_cxxstd, domain = NA)use_cxxstd <- NULL}else if (!checkCXX(use_cxxstd)) {stop(paste0("C++", use_cxxstd, " standard requested but CXX",use_cxxstd, " is not defined"),call. = FALSE, domain = NA)} elsemessage("specified C++", use_cxxstd, domain = NA)}}makeargs <- paste0("SHLIB=", shQuote(shlib))if (with_cxx) {if (!is.null(use_cxxstd)) {cxx_makeargs <- sprintf(c("CXX='$(CXX%s) $(CXX%sSTD)'","CXXFLAGS='$(CXX%sFLAGS)'","CXXPICFLAGS='$(CXX%sPICFLAGS)'","SHLIB_LDFLAGS='$(SHLIB_CXX%sLDFLAGS)'","SHLIB_LD='$(SHLIB_CXX%sLD)'"),use_cxxstd, use_cxxstd)makeargs <- c(cxx_makeargs, makeargs)}else {makeargs <- c("SHLIB_LDFLAGS='$(SHLIB_CXXLDFLAGS)'","SHLIB_LD='$(SHLIB_CXXLD)'", makeargs)}} else if (use_fc_link && (with_f77 || with_f9x))makeargs <- c("SHLIB_LDFLAGS='$(SHLIB_FCLDFLAGS)'","SHLIB_LD='$(SHLIB_FCLD)'",## avoid $(LIBINTL) and $(LIBR)"ALL_LIBS='$(PKG_LIBS) $(SHLIB_LIBADD) $(SAN_LIBS)'",makeargs)if (with_objc) shlib_libadd <- c(shlib_libadd, "$(OBJC_LIBS)")if (with_f77 || with_f9x) {if (use_fc_link)shlib_libadd <- c(shlib_libadd, "$(FCLIBS_XTRA)")elseshlib_libadd <- c(shlib_libadd, "$(FLIBS) $(FCLIBS_XTRA)")}if (nzchar(use_C)) {checkC <- function(cstd) {for (i in rev(seq_along(makefiles))) {lines <- readLines(makefiles[i], warn = FALSE)pattern <- paste0("^CC", cstd, " *= *")ll <- grep(pattern, lines, perl = TRUE, value = TRUE,useBytes = TRUE)for (j in rev(seq_along(ll))) {cs <- gsub(pattern, "", ll[j])return(nzchar(cs))}}return(FALSE)}if (!checkC(use_C)) {stop(paste0("C", use_C, " standard requested but CC", use_C," is not defined"),call. = FALSE, domain = NA)}c_makeargs <- sprintf(c("CC='$(CC%s)'", "CFLAGS='$(C%sFLAGS)'"), use_C)makeargs <- c(c_makeargs, makeargs)}if (length(pkg_libs))makeargs <- c(makeargs,paste0("PKG_LIBS='", p1(pkg_libs), "'"))if (length(shlib_libadd))makeargs <- c(makeargs,paste0("SHLIB_LIBADD='", p1(shlib_libadd), "'"))if (with_f9x && file.exists("Makevars") &&length(grep("^\\s*PKG_FCFLAGS", lines, perl = TRUE, useBytes = TRUE)))makeargs <- c(makeargs, "P_FCFLAGS='$(PKG_FCFLAGS)'")if (WINDOWS && debug) makeargs <- c(makeargs, "DEBUG=T")## TCLBIN is needed for tkrplot and tcltk2if (WINDOWS && rarch == "/x64") makeargs <- c(makeargs, "WIN=64 TCLBIN=")build_objects_symbol_tables <-config_val_to_logical(Sys.getenv("_R_SHLIB_BUILD_OBJECTS_SYMBOL_TABLES_","FALSE"))makeargs <- c(makeargs,if(isTRUE(use_lto))c(paste0("LTO=", shQuote("$(LTO_OPT)")),paste0("LTO_FC=", shQuote("$(LTO_FC_OPT)")))else if(isFALSE(use_lto)) c("LTO=", "LTO_FC="))## if(config_val_to_logical(Sys.getenv("_R_CXX_USE_NO_REMAP_", "TRUE")))## makeargs <- c(makeargs, "CXX_DEFS=-DR_NO_REMAP")## if(config_val_to_logical(Sys.getenv("_R_USE_STRICT_R_HEADERS_", "FALSE")))## makeargs <- c(makeargs, "XDEFS=-DSTRICT_R_HEADERS=1")cmd <- paste(MAKE, p1(paste("-f", shQuote(makefiles))), p1(makeargs),p1(makeobjs))if (dry_run) {cat("make cmd is\n ", cmd, "\n\nmake would use\n", sep = "")system(paste(cmd, "-n"))res <- 0} else {## first report versions of involved compilerslines <- system(paste(MAKE, p1(paste("-f", shQuote(makefiles))),"compilers"), intern = TRUE)## (unless make fails anyway, such as from syntax errors in makefiles)if (is.null(attr(lines, "status"))) {if (with_c) {cc <- lines[grep("^CC =", lines)]cc <- sub("CC = ", "", cc)## We do not strip flags in configure so leave them here## cc <- sub(" -.*", "", cc)## As this might be more than one word we use system not system2.cc_ver <- try(system(paste(cc, "--version"),intern = TRUE), silent = TRUE)if(!inherits(cc_ver, "try-error"))message("using C compiler: ", sQuote(cc_ver[1L]),domain = NA) # grepped in check}if (with_f77 || with_f9x) {fc <- lines[grep("^FC =", lines)]fc <- sub("FC = ", "", fc)## fc <- sub(" -.*", "", fc)fc_ver <- try(system(paste(fc, "--version"),intern = TRUE), silent = TRUE)if(!inherits(fc_ver, "try-error"))message("using Fortran compiler: ", sQuote(fc_ver[1L]),domain = NA)}if (with_cxx) {cxx <- lines[grep("^CXX =", lines)]cxx <- sub("CXX = ", "", cxx)## cxx <- sub(" -.*", "", cxx)if(nzchar(cxx)) {cxx_ver <- try(system(paste(cxx, "--version"),intern = TRUE), silent = TRUE)if(!inherits(cxx_ver, "try-error")) {message("using C++ compiler: ", sQuote(cxx_ver[1L]),domain = NA)if(!is.null(use_cxxstd))message("using C++", use_cxxstd, domain = NA)}}}}if (Sys.info()["sysname"] == "Darwin" &&(with_c|| with_f77 || with_f9x || with_cxx)) {## report the SDK in use: this changed at Xcode/CLT 26sdk <- try(system2("xcrun", "--show-sdk-version", TRUE, TRUE), silent = TRUE)if(!inherits(sdk, "try-error")) {sdk <- if (length(attr(sdk, "status"))) NA_character_else paste0("MacOSX", sdk, ".sdk")message("using SDK: ", sQuote(sdk), domain = NA)}}if (preclean) system(paste(cmd, "shlib-clean"))res <- system(cmd)if((res == 0L) && build_objects_symbol_tables) {## Should only do this if the previous one went ok.system(paste(cmd, "symbols.rds"))}if (clean) system(paste(cmd, "shlib-clean"))}res # probably a multiple of 256}## called for base packages from src/Makefile[.win] and from## .install_packages in this file. Really *help* indices..writePkgIndices <-function(dir, outDir, OS = .Platform$OS.type, html = TRUE){re <- function(x){## sort order for topics, a little tricky## FALSE sorts before TRUExx <- rep.int(TRUE, length(x))xx[grep("-package", x, fixed = TRUE)] <- FALSEorder(xx, toupper(x), x)}html_header <- function(pkg, title, version, encoding, conn){cat(paste(HTMLheader(title,logo = staticLogoPath(dir, relative = TRUE, Rhome = "../../..", dir = TRUE),Rhome = "../../..",up = "../../../doc/html/packages.html",css = "R.css"),collapse = "\n"),'<h2>Documentation for package ‘', pkg, '’ version ',version, '</h2>\n\n', sep = "", file = conn)cat('<ul><li><a href="../DESCRIPTION" type="text/plain',## These days we should really always have UTF-8 ...if(!is.na(encoding) && (encoding == "UTF-8"))"; charset=utf-8",'">DESCRIPTION file</a></li>\n',sep = "", file = conn)if (file.exists(file.path(outDir, "doc")))cat('<li><a href="../doc/index.html">User guides, package vignettes and other documentation</a></li>\n',file = conn)if (file.exists(file.path(outDir, "demo")))cat('<li><a href="../demo">Code demos</a>. Use <a href="../../utils/help/demo">demo()</a> to run them.</li>\n',sep = "", file = conn)for(nfile in c("NEWS", "NEWS.Rd", "NEWS.md")) {if(file.exists(file.path(outDir, nfile))) {cat('<li><a href="../', nfile, '">Package NEWS</a></li>\n',sep = "", file = conn)break}}if(file.exists(file.path(outDir, "README.md")))cat('<li><a href="../README.md">Package README</a></li>\n',sep = "", file = conn)cat('</ul>\n\n<h2>Help Pages</h2>\n\n\n',sep ="", file = conn)}firstLetterCategory <- function(x){x[endsWith(x, "-package")] <- " "x <- toupper(substr(x, 1, 1))x[x > "Z"] <- "misc"x[x < "A" & x != " "] <- "misc"x}## This may well already have been done:Rd <- if (file.exists(f <- file.path(outDir, "Meta", "Rd.rds")))readRDS(f)else {## Keep this in sync with .install_package_Rd_indices().## Rd objects should already have been installed.db <- tryCatch(Rd_db(basename(outDir), lib.loc = dirname(outDir)),error = function(e) NULL)## If not, we build the Rd db from the sources:if (is.null(db)) db <- Rd_db(dir = dir)Rd <- Rd_contents(db)saveRDS(Rd, file.path(outDir, "Meta", "Rd.rds"))Rd}topics <- Rd$AliasesM <- if (!length(topics)) {list2DF(list(Topic = character(),File = character(),Title = character(),Internal = character()))} else {lens <- lengths(topics)files <- sub("\\.[Rr]d$", "", Rd$File)internal <- (vapply(Rd$Keywords,function(x) match("internal", x, 0L),0L) > 0L)list2DF(list(Topic = unlist(topics),File = rep.int(files, lens),Title = rep.int(Rd$Title, lens),Internal = rep.int(internal, lens)))}## FIXME duplicated aliases warningoutman <- file.path(outDir, "help")dir.create(outman, showWarnings = FALSE)MM <- M[re(M[, 1L]), 1:2]utils::write.table(MM, file.path(outman, "AnIndex"),quote = FALSE, row.names = FALSE, col.names = FALSE,sep = "\t")a <- structure(MM[, 2L], names=MM[, 1L])saveRDS(a, file.path(outman, "aliases.rds"))## have HTML index even if no help pagesoutman <- file.path(outDir, "html")dir.create(outman, showWarnings = FALSE)outcon <- file(file.path(outman, "00Index.html"), "wt")on.exit(close(outcon))## we know we have a valid file by now.desc <- read.dcf(file.path(outDir, "DESCRIPTION"))[1L, ]## re-encode if necessaryif(!is.na(enc <- desc["Encoding"])) {## should be valid in UTF-8, might be invalid in declared encodingdesc <- iconv(desc, enc, "UTF-8", sub = "byte")}## drop internal entries (by default)if(!config_val_to_logical(Sys.getenv("_R_INSTALL_HTML_INDEX_INTERNAL_TOO_","FALSE")))M <- M[!M[, 4L], ]if (desc["Package"] %in% c("base", "graphics", "stats", "utils")) {for(pass in 1:2) {## we skip method aliasesgen <- gsub("\\.data\\.frame", ".data_frame", M$Topic)gen <- sub("\\.model\\.matrix$", ".modelmatrix", gen)gen <- sub("^(all|as|is|file|Sys|row|na|model)\\.", "\\1_", gen)gen <- sub("^(.*)\\.test", "\\1_test", gen)gen <- sub("([-[:alnum:]]+)\\.[^.]+$", "\\1", gen)last <- nrow(M)nongen <- gen %in% c("ar", "bw", "contr", "dyn", "lm", "qr", "ts", "which", ".Call", ".External", ".Library", ".First", ".Last")nc <- nchar(gen)asg <- (nc > 3) & endsWith(gen, "<-")skip <- (gen == c("", gen[-last])) & (M$File == c("", M$File[-last])) & !nongenskip <- skip | asg##N <- cbind(M$Topic, gen, c("", gen[-last]), skip)M <- M[!skip, ]}}# Collapse method links into unique (generic, file) pairsM$Topic <- sub("^([^,]*),.*-method$", "\\1-method", M$Topic)M <- M[!duplicated(M[, c("Topic", "File")]),]M <- M[re(M[, 1L]), ]## encode some entries.htmlize <- function(x, backtick){x <- gsub("&", "&", x, fixed = TRUE)x <- gsub("<", "<", x, fixed = TRUE)x <- gsub(">", ">", x, fixed = TRUE)if (backtick) {x <- gsub("---", "-", x, fixed = TRUE)x <- gsub("--", "-", x, fixed = TRUE)## these have been changed in the Rd parser#x <- gsub("``", "“", x, fixed = TRUE)#x <- gsub("''", "”", x, fixed = TRUE)#x <- gsub("\\`([^']+)'", "‘\\1’", x)#x <- gsub("`", "'", x, fixed = TRUE)}x}M$HTopic <- htmlize(M$Topic, FALSE)M$ Title <- htmlize(M$Title, TRUE)## No need to handle encodings: everything is in UTF-8html_header(desc["Package"], htmlize(desc["Title"], TRUE),desc["Version"], desc["Encoding"], outcon)use_alpha <- (nrow(M) > 100)if (use_alpha) {first <- firstLetterCategory(M$Topic)nm <- sort(names(table(first)))m <- match(" ", nm, 0L) # -packageif (m) nm <- c(" ", nm[-m])m <- match("misc", nm, 0L) # force last in all locales.if (m) nm <- c(nm[-m], "misc")writeLines(c('<p style="text-align: center;">',paste0("<a href=\"#", nm, "\">", nm, "</a>"),"</p>\n"), outcon)for (f in nm) {MM <- M[first == f, ]if (f != " ")cat("\n<h2><a id=\"", f, "\">-- ", f, " --</a></h2>\n\n",sep = "", file = outcon)writeLines(c('<table style="width: 100%;">',paste0('<tr><td style="width: 25%;"><a href="', MM[, 2L], '.html">',MM$HTopic, '</a></td>\n<td>', MM[, 3L],'</td></tr>'),"</table>"), outcon)}} else if (nrow(M)) {writeLines(c('<table style="width: 100%;">',paste0('<tr><td style="width: 25%;"><a href="', M[, 2L], '.html">',M$HTopic, '</a></td>\n<td>', M[, 3L],'</td></tr>'),"</table>"), outcon)} else { # no rowswriteLines("There are no help pages in this package", outcon)}writeLines('</div></body></html>', outcon)file.copy(file.path(R.home("doc"), "html", "R.css"), outman)invisible(NULL)}### * .convertRdfiles## possible types are "html", "latex", "example"## outenc is used as the default output encoding for latex conversion.convertRdfiles <-function(dir, outDir, types = "html", silent = FALSE, outenc = "UTF-8"){showtype <- function(type) {if (!shown) {nc <- nchar(bf)if (nc < 38L)cat(" ", bf, rep.int(" ", 40L - nc), sep = "")elsecat(" ", bf, "\n", rep.int(" ", 44L), sep = "")shown <<- TRUE}## 'example' is always last, so 5+spacecat(type, rep.int(" ", max(0L, 6L - nchar(type))), sep = "")}dirname <- c("html", "latex", "R-ex")ext <- c(".html", ".tex", ".R")names(dirname) <- names(ext) <- c("html", "latex", "example")mandir <- file.path(dir, "man")if (!dir.exists(mandir)) return()desc <- readRDS(file.path(outDir, "Meta", "package.rds"))$DESCRIPTIONpkg <- desc["Package"]ver <- desc["Version"]for(type in types)dir.create(file.path(outDir, dirname[type]), showWarnings = FALSE)cat(" converting help for package ", sQuote(pkg), "\n", sep = "")## FIXME: add this lib to lib.loc?if ("html" %in% types) {## may be slow, so add a messageif (!silent) message(" finding HTML links ...", appendLF = FALSE, domain = NA)Links <- findHTMLlinks(outDir, level = 0:1)if (!silent) message(" done", domain = NA)Links2 <- character()}## Rd objects may already have been installed.db <- tryCatch(Rd_db(basename(outDir), lib.loc = dirname(outDir)),error = function(e) NULL)## If not, we build the Rd db from the sources:if (is.null(db)) db <- Rd_db(dir = dir)if (!length(db)) return().whandler <- function(e) {.messages <<- c(.messages,paste("Rd warning:", conditionMessage(e)))tryInvokeRestart("muffleWarning")}.ehandler <- function(e) {message() # force newlineunlink(ff)stop(conditionMessage(e), domain = NA, call. = FALSE)}.convert <- function(expr)withCallingHandlers(tryCatch(expr, error = .ehandler),warning = .whandler)files <- names(db) # not full file namesfor(nf in files) {.messages <- character()Rd <- db[[nf]]attr(Rd, "source") <- NULLbf <- sub("\\.[Rr]d$", "", basename(nf)) # e.g. nf = "unix/Signals.Rd"f <- attr(Rd, "Rdfile")# full file nameshown <- FALSEif ("html" %in% types) {type <- "html"ff <- file.path(outDir, dirname[type],paste0(bf, ext[type]))if (!file_test("-f", ff) || file_test("-nt", f, ff)) {showtype(type)## assume prepare_Rd was run when dumping the .rds## so use defines = NULL for speed.convert(Rd2HTML(Rd, ff, package = c(pkg, ver),defines = NULL,Links = Links, Links2 = Links2))}}if ("latex" %in% types) {type <- "latex"ff <- file.path(outDir, dirname[type],paste0(bf, ext[type]))if (!file_test("-f", ff) || file_test("-nt", f, ff)) {showtype(type).convert(Rd2latex(Rd, ff, defines = NULL,outputEncoding = outenc,writeEncoding = (outenc != "UTF-8")))}}if ("example" %in% types) {type <- "example"ff <- file.path(outDir, dirname[type],paste0(bf, ext[type]))if (!file_test("-f", ff) || file_test("-nt", f, ff)) {.convert(Rd2ex(Rd, ff, defines = NULL))if (file_test("-f", ff)) showtype(type)}}if (shown) {cat("\n")if (length(.messages)) writeLines(unique(.messages))}}## Now check for files to remove.## These start with a letter.bfs <- sub("\\.[Rr]d$", "", basename(files)) # those to keepif ("html" %in% types) {type <- "html"have <- list.files(file.path(outDir, dirname[type]))have2 <- sub(".html", "", basename(have), fixed=TRUE)drop <- have[have2 %notin% c(bfs, "00Index", "R.css")]unlink(file.path(outDir, dirname[type], drop))}if ("latex" %in% types) {type <- "latex"have <- list.files(file.path(outDir, dirname[type]))have2 <- sub(".tex", "", basename(have), fixed=TRUE)drop <- have[have2 %notin% bfs]unlink(file.path(outDir, dirname[type], drop))}if ("example" %in% types) {type <- "example"have <- list.files(file.path(outDir, dirname[type]))have2 <- sub(".R", "", basename(have), fixed=TRUE)drop <- have[have2 %notin% bfs]unlink(file.path(outDir, dirname[type], drop))}}### * .makeDllRes.makeDllRes <-function(name="", version = "0.0"){if (file.exists(f <- "../DESCRIPTION") ||file.exists(f <- "../../DESCRIPTION")) {desc <- read.dcf(f)[[1L]]if (!is.na(f <- desc["Package"])) name <- fif (!is.na(f <- desc["Version"])) version <- f}writeLines(c('#include <windows.h>','#include "Rversion.h"','','VS_VERSION_INFO VERSIONINFO','FILEVERSION R_FILEVERSION','PRODUCTVERSION 3,0,0,0','FILEFLAGSMASK 0x3L','FILEOS VOS__WINDOWS32','FILETYPE VFT_APP','BEGIN',' BLOCK "StringFileInfo"',' BEGIN',' BLOCK "040904E4"',' BEGIN'))cat(" VALUE \"FileDescription\", \"DLL for R package `", name,"'\\0\"\n"," VALUE \"FileVersion\", \"", version, "\\0\"\n", sep = "")writeLines(c(' VALUE "Compiled under R Version", R_MAJOR "." R_MINOR " (" R_YEAR "-" R_MONTH "-" R_DAY ")\\0"',' VALUE "Project info", "https://www.r-project.org\\0"',' END',' END',' BLOCK "VarFileInfo"',' BEGIN',' VALUE "Translation", 0x409, 1252',' END','END'))}### * makevars_usermakevars_user <-function(){m <- character()if(.Platform$OS.type == "windows") {if(!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA_character_))) {if(file.exists(f)) m <- f}else if((Sys.getenv("R_ARCH") == "/x64") &&file.exists(f <- path.expand("~/.R/Makevars.ucrt")))m <- felse if((Sys.getenv("R_ARCH") == "/x64") &&file.exists(f <- path.expand("~/.R/Makevars.win64")))m <- felse if(file.exists(f <- path.expand("~/.R/Makevars.win")))m <- felse if(file.exists(f <- path.expand("~/.R/Makevars")))m <- f}else {if(!is.na(f <- Sys.getenv("R_MAKEVARS_USER", NA_character_))) {if(file.exists(f)) m <- f}else if(file.exists(f <- path.expand(paste0("~/.R/Makevars-",Sys.getenv("R_PLATFORM")))))m <- felse if(file.exists(f <- path.expand("~/.R/Makevars")))m <- f}m}revert_install_time_patches <- function(){WINDOWS <- .Platform$OS.type == "windows"if (WINDOWS && dir.exists("install_time_patches")) {patches <- sort(list.files("install_time_patches"),decreasing = TRUE)for(p in patches) {fname <- paste0("install_time_patches/", p)if (system2("patch",args = c("-p2", "--binary", "--force", "--reverse"),stdin = fname) != 0)message("WARNING: failed to revert patch ", p, "\n", domain = NA)elsemessage("Reverted installation-time patch ", p," in package installation\n", domain = NA)}unlink("install_time_patches", recursive = TRUE)}}### * makevars_sitemakevars_site <-function(){m <- character()if(is.na(f <- Sys.getenv("R_MAKEVARS_SITE", NA_character_)))f <- file.path(paste0(R.home("etc"), Sys.getenv("R_ARCH")),"Makevars.site")if(file.exists(f))m <- fm}cxx_standards <- c("26", "23", "20", "17", "14", "11", "98")### Local variables: ***### mode: outline-minor ***### outline-regexp: "### [*]+" ***### End: ***