1
2#' Install a package from a SVN repository
3#'
4#' This function requires \command{svn} to be installed on your system in order to
5#' be used.
6#'
7#' It is vectorised so you can install multiple packages with
8#' a single command.
9#'
10#' @inheritParams install_git
11#' @param subdir A sub-directory within a svn repository that contains the
12#'   package we are interested in installing.
13#' @param args A character vector providing extra options to pass on to
14#'   \command{svn}.
15#' @param revision svn revision, if omitted updates to latest
16#' @param ... Other arguments passed on to [utils::install.packages()].
17#' @inheritParams install_github
18#' @family package installation
19#' @export
20#'
21#' @examples
22#' \dontrun{
23#' install_svn("https://github.com/hadley/stringr/trunk")
24#' install_svn("https://github.com/hadley/httr/branches/oauth")
25#'}
26install_svn <- function(url, subdir = NULL, args = character(0),
27                        revision = NULL,
28                        dependencies = NA,
29                        upgrade = c("default", "ask", "always", "never"),
30                        force = FALSE,
31                        quiet = FALSE,
32                        build = TRUE, build_opts = c("--no-resave-data", "--no-manual", "--no-build-vignettes"),
33                        build_manual = FALSE, build_vignettes = FALSE,
34                        repos = getOption("repos"),
35                        type = getOption("pkgType"),
36                        ...) {
37
38  remotes <- lapply(url, svn_remote, svn_subdir = subdir,
39    revision = revision, args = args)
40
41  install_remotes(remotes, args = args,
42                  dependencies = dependencies,
43                  upgrade = upgrade,
44                  force = force,
45                  quiet = quiet,
46                  build = build,
47                  build_opts = build_opts,
48                  build_manual = build_manual,
49                  build_vignettes = build_vignettes,
50                  repos = repos,
51                  type = type,
52                  ...)
53}
54
55svn_remote <- function(url, svn_subdir = NULL, revision = NULL,
56  args = character(0), ...) {
57  remote("svn",
58    url = url,
59    svn_subdir = svn_subdir,
60    revision = revision,
61    args = args
62  )
63}
64
65#' @export
66remote_download.svn_remote <- function(x, quiet = FALSE) {
67  if (!quiet) {
68    message("Downloading svn repo ", x$url)
69  }
70
71  bundle <- tempfile()
72  svn_binary_path <- svn_path()
73  url <- x$url
74
75  args <- "co"
76  if (!is.null(x$revision)) {
77    args <- c(args, "-r", x$revision)
78  }
79  args <- c(args, x$args, full_svn_url(x), bundle)
80
81  if (!quiet) { message(shQuote(svn_binary_path), " ", paste0(args, collapse = " ")) }
82  request <- system2(svn_binary_path, args, stdout = FALSE, stderr = FALSE)
83
84  # This is only looking for an error code above 0-success
85  if (request > 0) {
86    stop("There seems to be a problem retrieving this SVN-URL.", call. = FALSE)
87  }
88
89  in_dir(bundle, {
90    if (!is.null(x$revision)) {
91      request <- system2(svn_binary_path, paste("update -r", x$revision), stdout = FALSE, stderr = FALSE)
92      if (request > 0) {
93        stop("There was a problem switching to the requested SVN revision", call. = FALSE)
94      }
95    }
96  })
97  bundle
98}
99
100#' @export
101remote_metadata.svn_remote <- function(x, bundle = NULL, source = NULL, sha = NULL) {
102
103  if (!is.null(bundle)) {
104    in_dir(bundle, {
105      revision <- svn_revision()
106    })
107  } else {
108    revision <- sha
109  }
110
111  list(
112    RemoteType = "svn",
113    RemoteUrl = x$url,
114    RemoteSubdir = x$svn_subdir,
115    RemoteArgs = if (length(x$args) > 0) paste0(deparse(x$args), collapse = " "),
116    RemoteSha = revision # for compatibility with other remotes
117  )
118}
119
120svn_path <- function(svn_binary_name = NULL) {
121  # Use user supplied path
122  if (!is.null(svn_binary_name)) {
123    if (!file.exists(svn_binary_name)) {
124      stop("Path ", svn_binary_name, " does not exist", .call = FALSE)
125    }
126    return(svn_binary_name)
127  }
128
129  # Look on path
130  svn_path <- Sys.which("svn")[[1]]
131  if (svn_path != "") return(svn_path)
132
133  # On Windows, look in common locations
134  if (os_type() == "windows") {
135    look_in <- c(
136      "C:/Program Files/Svn/bin/svn.exe",
137      "C:/Program Files (x86)/Svn/bin/svn.exe"
138    )
139    found <- file.exists(look_in)
140    if (any(found)) return(look_in[found][1])
141  }
142
143  stop("SVN does not seem to be installed on your system.", call. = FALSE)
144}
145
146#' @export
147remote_package_name.svn_remote <- function(remote, ...) {
148  description_url <- file.path(full_svn_url(remote), "DESCRIPTION")
149  tmp_file <- tempfile()
150  on.exit(rm(tmp_file))
151  response <- system2(svn_path(), paste("cat", description_url), stdout = tmp_file)
152  if (!identical(response, 0L)) {
153    return(NA_character_)
154  }
155  read_dcf(tmp_file)$Package
156}
157
158#' @export
159remote_sha.svn_remote <- function(remote, ...) {
160  svn_revision(full_svn_url(remote))
161}
162
163svn_revision <- function(url = NULL, svn_binary_path = svn_path()) {
164  request <- system2(svn_binary_path, paste("info --xml", url), stdout = TRUE)
165  if (!is.null(attr(request, "status")) && !identical(attr(request, "status"), 0L)) {
166    stop("There was a problem retrieving the current SVN revision", call. = FALSE)
167  }
168  gsub(".*<commit[[:space:]]+revision=\"([[:digit:]]+)\">.*", "\\1", paste(collapse = "\n", request))
169}
170
171full_svn_url <- function(x) {
172  url <- x$url
173  if (!is.null(x$svn_subdir)) {
174    url <- file.path(url, x$svn_subdir)
175  }
176
177  url
178}
179
180format.svn_remote <- function(x, ...) {
181  "SVN"
182}
183