Permalink
Switch branches/tags
Nothing to show
Find file Copy path
Fetching contributors…
Cannot retrieve contributors at this time
543 lines (502 sloc) 20 KB
#' Updating Method
#'
#' Update Windows PATH.
#'
#' @param h.scope A \code{list} vector specifying the update scope:
#' \code{"r"} updates the R version based on the version that launched the
#' session that called this function; \code{"rtools"} updates the Rtools paths
#' given that you provide the path to your Rtools installation in arg
#' \code{path.rtools}.
#' @param h.relict A \code{character} vector specifying how to handle relicts
#' (old versions): \code{"keep"} or \code{"remove"}, should be self-explanatory.
#' @param h.pos A \code{character} vector specifying where to add new entries:
#' \code{"prepend"} or \code{"append"}, should be self-explanatory.
#' @param path.rtools A \code{character} scalar specifying the path to your Rtools
#' installation \emph{including} the version number (e.g. \code{C:\Rtools\2.14}).
#' @param do.32bit A \code{logical} scalar. If \code{TRUE} the path to the 32 bit
#' version of R is added (i.e. \code{"~/bin/i386"}); else the path to the 64 bit
#' version (i.e. \code{"~/bin"}).
#' @param do.ask A \code{logical} scalar. If \code{TRUE} the user is presented
#' the old PATH and the planned changes to PATH and can decided whether to update the path or
#' not; else user is not asked.
#' @param do.sort A \code{logical} scalar. If \code{TRUE}, the remaining part
#' of PATH (i.e. entries that have nothing to do with those being investigated)
#' is sorted in ascending order; else this part of PATH is left as found.
#' @param do.test A \code{logical} scalar. If \code{TRUE} a test PATH is called
#' in order to test the function without actually doing anything to PATH.
#' @param .do.verbose A \code{logical} scalar. If \code{TRUE} print additional
#' status messages; else not.
#' @param ... \code{ANY} further arguments.
#' @return A \code{character} scalar containing the new Windows PATH.
#' @author Janko Thyson \email{janko.thyson@@rappster.de}
#' @references \url{http://http://rappster.wordpress.com/}
#' @example inst/examples/pathWindowsUpdate.R
setMethod(
f="pathWindowsUpdate",
signature=signature(h.scope="list"),
definition=cmpfun(function(
h.scope=list(r=NULL, rtools=character(), gtk=character()),
h.relict=list(keep=NULL, remove=NULL),
h.pos=list(prepend=NULL, append=NULL),
do.rollback=TRUE,
do.ask=TRUE,
do.sort=FALSE,
do.test=FALSE,
.do.verbose=FALSE,
...
) {
#---------------------------------------------------------------------------
# PREPROCESSING
#---------------------------------------------------------------------------
envirLocalInit(do.minimal=TRUE)
h.scope <- argProcess(
arg=h.scope,
valid=list(r=NULL, rtools=character(), gtk=character())
)
h.relict <- argProcess(
arg=h.relict,
valid=list(keep=NULL, remove=NULL),
h.restrict=1
)
h.pos <- argProcess(
arg=h.pos,
valid=list(prepend=NULL, append=NULL),
h.restric=1
)
# NOTATION OF COMPONENTS
h.scope.mpd <- lapply(seq(h.scope), function(x.scope) {
switch(names(h.scope[x.scope]),
"r"={
out <- list(id="R", rgx="R-\\d*\\.\\d*\\.\\d*/bin",
vers.0=character(), vers.1=character())
},
"rtools"={
out <- list(id="Rtools",
rgx="Rtools/\\d*\\.\\d*((/bin)|(/MinGW/bin)|(/MinGW64/bin))",
vers.0=character(), vers.1=character())
},
"gtk"={
out <- list(id="GTK", rgx="GTK/\\d*\\.\\d*\\.\\d*/bin",
vers.0=character(), vers.1=character())
}
)
})
names(h.scope.mpd) <- names(h.scope)
# rgx.r <- "R-\\d*\\.\\d*\\.\\d*"
# rgx.r.bin <- paste(rgx.r, "\\\\bin", sep="")
do.mustwork <- TRUE
if (do.test) {
options(warn=-1)
do.mustwork <- FALSE
msg <- c(
"########################################################\n",
"# #\n",
"# >>> RUNNING IN TEST MODE <<< #\n",
"# #\n",
"# Your PATH will *NOT* be altered! #\n",
"########################################################\n"
)
message(msg)
path <- c("C:/Junk/App", "C:/Program Files/ApplicationB",
"C:/Program Files/ApplicationA",
"C:/R/R-2.13.1/bin", "C:/R/R-2.14.0/bin",
"C:/Rtools/2.13/bin", "C:/Rtools/2.13/MinGW/bin",
"C:/Rtools/2.13/MinGW64/bin",
"C:/Rtools/2.14/bin", "C:/Rtools/2.14/MinGW/bin",
"C:/Rtools/2.14/MinGW64/bin",
"C:/GTK/1.2.3/bin"
)
# path <- normalizePath(path, winslash="\\", mustWork=FALSE)
h.scope.mpd$r$path <- "C:/R/R-2.14.0"
h.scope.mpd$r$vers.1 <- "2.14.0"
} else {
path <- normalizePath(unlist(strsplit(Sys.getenv("PATH"), split=";")),
winslash="/")
h.scope.mpd$r$path <- R.home()
h.scope.mpd$r$vers.1 <- paste(R.version$major, R.version$minor, sep=".")
}
# OLD PATH
path.0 <- path[-1]
# Seems like the first entry in this vector is the *running* R
# distribution. It's not really in the path, just appears so!
# TODO: check
# Clean path
# idx <- grep("/", path.0)
# if (length(idx)) {
# path.0 <- path.0[-idx]
# }
idx <- which(path.0 == "")
if (length(idx)) {
path.0 <- path.0[-idx]
}
# ROLLBACK
if (do.rollback) {
envirModify(
h.mod=list(comps=c(".HIVE", "temp", "win")),
h.value=list(path=paste(path.0, collapse=";"))
)
}
# /
# /PREPROCESSING ----------
#---------------------------------------------------------------------------
# INNER FUNCTION
#---------------------------------------------------------------------------
pathWindowsUpdateInner <- function(
path,
path.add,
version.1,
rgx.relict,
rgx.relict.version,
do.ask=TRUE,
do.sort=FALSE,
do.test=FALSE,
.do.verbose=FALSE,
...
) {
path.0 <- path
# path.add <- normalizePath(path.add)
# RELICTS
idx <- grep(rgx.relict, path, perl=TRUE)
if (length(idx)) {
path.relict <- path[idx]
path <- path[-idx]
if (.do.verbose) {
msg <- c(
paste(.LOCAL$name, "/the following versions are already contained in your PATH:\n", sep=""),
paste(paste("*", normalizePath(path.relict)), collapse="\n"),
"\n\nFurther processing is based on arg 'h.relict' ..."
)
message(msg)
}
# Drop identical path
idx <- which(path.relict == path.add)
if (length(idx)) {
path.relict <- path.relict[-idx]
}
# Drop identical version
idx <- gregexpr(rgx.relict.version, path.relict)
if (length(idx)) {
version.0 <- sapply(seq(along=idx), function(x) {
idx.this <- idx[[x]]
path.this <- path.relict[[x]]
out <- gsub("^[[:alpha:]]*/", "",
substr(path.this, start=idx.this,
stop=idx.this+attributes(idx.this)$match.length))
out <- unlist(strsplit(out, split="/"))[1]
return(out)
})
idx <- which(version.0 == version.1)
if (length(idx)) {
path.relict <- path.relict[-idx]
}
}
if ("remove" %in% names(h.relict)) {
# path.add <- path.add
if (.do.verbose) {
message(paste(.LOCAL$name, "/removing old versions ...", sep=""))
}
}
if ("keep" %in% names(h.relict)) {
path.add <- c(path.add, path.relict)
if (length(path.relict) & .do.verbose) {
message(paste(.LOCAL$name, "/keeping old versions ...", sep=""))
}
}
}
# /
if (do.sort) {
collation <- c(".*/Rtools/.*", ".*/R/.*", ".*/GTK/.*")
path.temp <- NULL
for (x in collation) {
path.temp <- c(path.temp, grep(x, path, value=TRUE))
}
path <- c(path.temp, setdiff(path, path.temp))
}
# /
# NEW PATH
if ("prepend" %in% names(h.pos)) {
path.1 <- c(path.add, path)
}
if ("append" %in% names(h.pos)) {
path.1 <- c(path, path.add)
}
# /
# MESSAGE
if (.do.verbose) {
msg <- c(
"\n",
"####################\n",
"# Old Windows PATH #\n",
"####################\n",
paste(normalizePath(path.0), collapse="\n"), "\n\n",
"####################\n",
"# New Windows PATH #\n",
"####################\n",
paste(normalizePath(path.1), collapse="\n"), "\n"
)
message(msg)
}
path.set <- normalizePath(path.1)
# /
# IDENTICAL
out <- path.set
if (all(path.0 == path.1)) {
if (.do.verbose) {
message(paste(.LOCAL$name, "/paths are identical\n", sep=""))
}
return(out)
}
# /
# DECISION
if (do.ask) {
decision <- tolower(select.list(choices=c("No", "Yes"),
title="Update PATH?"))
if (decision == "yes") {
path.set <- paste(path.set, collapse=";")
if (.do.verbose) {
message(paste(.LOCAL$name, "/updating Windows PATH ...\n", sep=""))
}
out <- path.1
if (!do.test) {
system(paste("setx PATH \"", path.set, "\"", sep = ""))
}
}
if (decision == "no") {
if (.do.verbose) {
message(paste(.LOCAL$name, "/windows PATH not updated\n", sep=""))
}
}
} else {
path.set <- paste(path.set, collapse=";")
if (.do.verbose) {
message(paste(.LOCAL$name, "/updating Windows PATH ...\n", sep=""))
}
out <- path.1
if (!do.test) {
system(paste("setx PATH \"", path.set, "\"", sep = ""))
}
}
# /
return(out)
}
# /INNER FUNCTION ----------
#---------------------------------------------------------------------------
# GTK
#---------------------------------------------------------------------------
h.this <- "gtk"
if (h.this %in% names(h.scope)) {
h.this.val <- h.scope[[h.this]]
path <- h.this.val
if (!length(path)) {
path <- file.path(normalizePath(Sys.getenv("APPS"), winslash="/"),
h.scope.mpd[[h.this]]$id)
if (!file.exists(path)) {
stop(paste("Invalid path: '", path, "'", sep=""))
}
path <- list.files(path, full.names=TRUE)
} else {
if (!do.test) {
if (!file.exists(path)) {
stop(paste(.LOCAL$name, "/invalid path: '", path, "'", sep=""))
}
}
}
path <- file.path(path[length(path)], "bin")
# VERSION
h.scope.mpd[[h.this]]$vers.1 <- basename(path)
if (!all(sapply(path, grepl, path.0, fixed=TRUE))) {
path.0 <- pathWindowsUpdateInner(
path=path.0,
path.add=path,
version.1=h.scope.mpd[[h.this]]$vers.1,
rgx.relict=h.scope.mpd[[h.this]]$rgx,
rgx.relict.version=h.scope.mpd[[h.this]]$rgx,
do.ask=do.ask,
do.sort=do.sort,
do.test=do.test,
.do.verbose=.do.verbose
)
# path.0 <- unlist(strsplit(path.0, split=";"))
} else {
message(paste(.LOCAL$name, "/windows PATH is up to date\n", sep=""))
if (do.test) {
message(">>> TEST MODE <<<\nElse the following would happen:\n")
path.0 <- pathWindowsUpdateInner(
path=path.0,
path.add=path,
version.1=h.scope.mpd[[h.this]]$vers.1,
rgx.relict=h.scope.mpd[[h.this]]$rgx,
rgx.relict.version=h.scope.mpd[[h.this]]$rgx,
do.ask=do.ask,
do.sort=do.sort,
do.test=do.test,
.do.verbose=.do.verbose
)
# path.0 <- unlist(strsplit(path.0, split=";"))
}
}
}
# /GTK ----------
#---------------------------------------------------------------------------
# R
#---------------------------------------------------------------------------
h.this <- "r"
if (h.this %in% names(h.scope)) {
h.this.val <- h.scope[[h.this]]
bits <- h.this.val
path <- h.scope.mpd$r$path
path.temp <- normalizePath(file.path(path, "bin"))
if (.do.verbose) {
message(paste(.LOCAL$name, "/checking Windows PATH with respect to R version",
h.scope.mpd[[h.this]]$vers.1, " ...\n", sep=""))
}
if ((shell("R --version") != 0) ||
!grepl(path, path.0, fixed=TRUE)
) {
path <- path.temp
if (is.null(bits)) {
path <- file.path(path, "i386")
}
path.0 <- pathWindowsUpdateInner(
path=path.0,
path.add=path,
version.1=h.scope.mpd[[h.this]]$vers.1,
# rgx.relict=rgx.r.bin,
# rgx.relict.version=rgx.r,
rgx.relict=h.scope.mpd[[h.this]]$rgx,
rgx.relict.version=h.scope.mpd[[h.this]]$rgx,
do.ask=do.ask,
do.sort=do.sort,
do.test=do.test,
.do.verbose=.do.verbose
)
# path.0 <- unlist(strsplit(path.0, split=";"))
} else {
message(paste(.LOCAL$name, "/windows PATH is up to date\n", sep=""))
path <- path.temp
if (do.test) {
message(">>> TEST MODE <<<\nElse the following would happen:\n")
path.0 <- pathWindowsUpdateInner(
path=path.0,
path.add=path,
version.1=h.scope.mpd[[h.this]]$vers.1,
# rgx.relict=rgx.r.bin,
# rgx.relict.version=rgx.r,
rgx.relict=h.scope.mpd[[h.this]]$rgx,
rgx.relict.version=h.scope.mpd[[h.this]]$rgx,
do.ask=do.ask,
do.sort=do.sort,
do.test=do.test,
.do.verbose=.do.verbose
)
# path.0 <- unlist(strsplit(path.0, split=";"))
}
}
}
# /R ----------
#---------------------------------------------------------------------------
# RTOOLS
#---------------------------------------------------------------------------
h.this <- "rtools"
if (h.this %in% names(h.scope)) {
h.this.val <- h.scope[[h.this]]
path <- h.this.val
h.scope.mpd[[h.this]]$vers.1 <- gsub("\\.\\d*$", "", h.scope.mpd$r$vers.1)
if (!length(path)) {
path <- file.path(normalizePath(Sys.getenv("APPS"), winslash="/"),
h.scope.mpd[[h.this]]$id)
if (!file.exists(path)) {
stop(paste(.LOCAL$name, "/invalid path: '", path, "'", sep=""))
}
path.temp <- list.files(path, full.names=TRUE)
path <- grep(paste(".*/", h.scope.mpd[[h.this]]$vers.1,
"$", sep=""), path.temp, value=TRUE)
if (!length(path)) {
msg <- c(
paste(.LOCAL$name, "/required version of Rtools not available:\n", sep=""),
paste("* Version R: ",
h.scope.mpd$r$vers.1), "\n",
paste("* Version Rtools required: ",
h.scope.mpd[[h.this]]$vers.1), "\n",
paste("* Version Rtools available: {",
paste(basename(path), collapse=", "), "}", sep="")
)
stop(msg)
}
}
if (.do.verbose) {
message(paste(.LOCAL$name, "/checking Windows PATH with respect to Rtools version ",
h.scope.mpd[[h.this]]$vers.1, " ...\n", sep=""))
}
h.scope.mpd[[h.this]]$vers.0 <- basename(path)
if (h.scope.mpd[[h.this]]$vers.1 != h.scope.mpd[[h.this]]$vers.0) {
msg <- c(
paste(.LOCAL$name, "/invalid version of Rtools specified:\n", sep=""),
paste("* Version R: ", h.scope.mpd$r$vers.1), "\n",
paste("* Version Rtools required: ", h.scope.mpd[[h.this]]$vers.1), "\n",
paste("* Version Rtools specified: ", h.scope.mpd[[h.this]]$vers.0), "\n"
)
stop(msg)
}
path <- file.path(path, c("bin", "MinGW/bin", "MinGW64/bin"))
if (!do.test) {
if (!all(file.exists(path))) {
msg <- c(
paste(.LOCAL$name, "/invalid paths:\n", sep=""),
paste("* ", path[which(!file.exists(path))], "\n", sep="")
)
stop(msg)
}
}
if (!all(sapply(path, grepl, path.0, fixed=TRUE))) {
path.0 <- pathWindowsUpdateInner(
path=path.0,
path.add=path,
version.1=h.scope.mpd[[h.this]]$vers.1,
rgx.relict=h.scope.mpd[[h.this]]$rgx,
rgx.relict.version=h.scope.mpd[[h.this]]$rgx,
do.ask=do.ask,
do.sort=do.sort,
do.test=do.test,
.do.verbose=.do.verbose
)
} else {
message(paste(.LOCAL$name, "/windows PATH is up to date\n", sep=""))
if (do.test) {
message(">>> TEST MODE <<<\nElse the following would happen:\n")
path.0 <- pathWindowsUpdateInner(
path=path.0,
path.add=path,
version.1=h.scope.mpd[[h.this]]$vers.1,
rgx.relict=h.scope.mpd[[h.this]]$rgx,
rgx.relict.version=h.scope.mpd[[h.this]]$rgx,
do.ask=do.ask,
do.sort=do.sort,
do.test=do.test,
.do.verbose=.do.verbose
)
}
}
}
# /RTOOLS ----------
# DOUBLE CHECK TO ENSURE RIGHT ORDER
# This is part of 'pathWindowsUpdateInner', but just in case ...
if (do.sort) {
collation <- c(".*/Rtools/.*", ".*/R/.*", ".*/GTK/.*")
path.temp <- NULL
for (x in collation) {
path.temp <- c(path.temp, grep(x, path.0, value=TRUE))
}
path.0 <- normalizePath(c(path.temp, setdiff(path.0, path.temp)))
}
# /
options(warn=0)
#---------------------------------------------------------------------------
# FINALIZE
#---------------------------------------------------------------------------
envirLocalTerminate(do.minimal=TRUE)
out <- list(atomic=path.0, collapsed=paste(path.0, collapse=";"))
return(out)
# /FINALIZE ----------
}, options=list(suppressUndefined=TRUE))
)