1
2enc2path <- function(x) {
3  if (is_windows()) {
4    enc2utf8(x)
5  } else {
6    enc2native(x)
7  }
8}
9
10`%||%` <- function(l, r) if (is.null(l)) r else l
11
12os_type <- function() {
13  .Platform$OS.type
14}
15
16is_windows <- function() {
17  .Platform$OS.type == "windows"
18}
19
20is_linux <- function() {
21  identical(tolower(Sys.info()[["sysname"]]), "linux")
22}
23
24last_char <- function(x) {
25  nc <- nchar(x)
26  substring(x, nc, nc)
27}
28
29# Given a filename, return an absolute path to that file. This has two important
30# differences from normalizePath(). (1) The file does not need to exist, and (2)
31# the path is merely absolute, whereas normalizePath() returns a canonical path,
32# which resolves symbolic links, gives canonical case, and, on Windows, may give
33# short names.
34#
35# On Windows, the returned path includes the drive ("C:") or network server
36# ("//myserver").
37full_path <- function(path) {
38  assert_that(is_string(path))
39
40  # Try expanding "~"
41  path <- path.expand(path)
42
43  # If relative path, prepend current dir. On Windows, also record current
44  # drive.
45  if (is_windows()) {
46    path <- gsub("\\", "/", path, fixed = TRUE)
47
48    if (grepl("^[a-zA-Z]:", path)) {
49      drive <- substring(path, 1, 2)
50      path <- substring(path, 3)
51
52    } else if (substring(path, 1, 2) == "//") {
53      # Extract server name, like "//server", and use as drive.
54      pos <- regexec("^(//[^/]*)(.*)", path)[[1]]
55      drive <- substring(path, pos[2], attr(pos, "match.length", exact = TRUE)[2])
56      path <- substring(path, pos[3])
57
58      # Must have a name, like "//server"
59      if (drive == "//")
60        throw(new_error("Server name not found in network path."))
61
62    } else {
63      drive <- substring(getwd(), 1, 2)
64
65      if (substr(path, 1, 1) != "/")
66        path <- substring(file.path(getwd(), path), 3)
67    }
68
69  } else {
70    if (substr(path, 1, 1) != "/")
71      path <- file.path(getwd(), path)
72  }
73
74  parts <- strsplit(path, "/")[[1]]
75
76  # Collapse any "..", ".", and "" in path.
77  i <- 2
78  while (i <= length(parts)) {
79    if (parts[i] == "." || parts[i] == "") {
80      parts <- parts[-i]
81
82    } else if (parts[i] == "..") {
83      if (i == 2) {
84        parts <- parts[-i]
85      } else {
86        parts <- parts[-c(i-1, i)]
87        i <- i-1
88      }
89    } else {
90      i <- i+1
91    }
92  }
93
94  new_path <- paste(parts, collapse = "/")
95  if (new_path == "")
96    new_path <- "/"
97
98  if (is_windows())
99    new_path <- paste0(drive, new_path)
100
101  new_path
102}
103
104vcapply <- function (X, FUN, ..., USE.NAMES = TRUE) {
105  vapply(X, FUN, FUN.VALUE = character(1), ..., USE.NAMES = USE.NAMES)
106}
107
108do_echo_cmd <- function(command, args) {
109  quoted <- sh_quote_smart(c("Running", command, args))
110
111  out <- str_wrap_words(quoted, width = getOption("width") - 3)
112
113  if ((len <- length(out)) > 1) {
114    out[1:(len - 1)] <- paste0(out[1:(len - 1)], " \\")
115  }
116  cat(out, sep = "\n")
117}
118
119sh_quote_smart <- function(x) {
120  if (!length(x)) return(x)
121  ifelse(grepl("^[-a-zA-Z0-9/_\\.]*$", x), x, shQuote(x))
122}
123
124strrep <- function(x, times) {
125  x <- as.character(x)
126  if (length(x) == 0L) return(x)
127  r <- .mapply(
128    function(x, times) {
129      if (is.na(x) || is.na(times)) return(NA_character_)
130      if (times <= 0L) return("")
131      paste0(replicate(times, x), collapse = "")
132    },
133    list(x = x, times = times),
134    MoreArgs = list()
135  )
136
137  unlist(r, use.names = FALSE)
138}
139
140str_wrap_words <- function(words, width, indent = 0, exdent = 2) {
141  word_widths <- nchar(words, type = "width")
142  out <- character()
143
144  current_width <- indent
145  current_line <- strrep(" ", indent)
146  first_word <- TRUE
147
148  i <- 1
149  while (i <= length(words)) {
150    if (first_word) {
151      current_width <- current_width + word_widths[i]
152      current_line <- paste0(current_line, words[i])
153      first_word <- FALSE
154      i <- i + 1
155
156    } else if (current_width + 1 + word_widths[i] <= width) {
157      current_width <- current_width + word_widths[i] + 1
158      current_line <- paste0(current_line, " ", words[i])
159      i <- i + 1
160
161    } else {
162      out <- c(out, current_line)
163      current_width <- exdent
164      current_line <- strrep(" ", exdent)
165      first_word <- TRUE
166    }
167  }
168
169  if (!first_word) out <- c(out, current_line)
170
171  out
172}
173
174set_names <- function(x, n) {
175  names(x) <- n
176  x
177}
178
179get_private <- function(x) {
180  x$.__enclos_env__$private
181}
182
183get_tool <- function(prog) {
184  if (os_type() == "windows") prog <- paste0(prog, ".exe")
185  exe <- system.file(package = "processx", "bin", .Platform$r_arch, prog)
186  if (exe == "") {
187    pkgpath <- system.file(package = "processx")
188    if (basename(pkgpath) == "inst") pkgpath <- dirname(pkgpath)
189    exe <- file.path(pkgpath, "src", "tools", prog)
190    if (!file.exists(exe)) return("")
191  }
192  exe
193}
194
195get_id <- function() {
196  paste0(
197    "PS",
198    paste(sample(c(LETTERS, 0:9), 10, replace = TRUE), collapse = ""),
199    "_", as.integer(asNamespace("base")$.Internal(Sys.time()))
200  )
201}
202
203format_unix_time <- function(z) {
204  structure(z, class = c("POSIXct", "POSIXt"), tzone = "GMT")
205}
206
207file_size <- function(x) {
208  if (getRversion() >= "3.2.0") {
209    file.info(x, extra_cols = FALSE)$size
210  } else {
211    file.info(x)$size
212  }
213}
214
215disable_crash_dialog <- function() {
216  rethrow_call(c_processx_disable_crash_dialog)
217}
218
219has_package <- function(pkg) {
220  requireNamespace(pkg, quietly = TRUE)
221}
222
223tty_echo_off <- function() {
224  rethrow_call(c_processx__echo_off)
225}
226
227tty_echo_on <- function() {
228  rethrow_call(c_processx__echo_on)
229}
230
231str_trim <- function(x) {
232  sub("^\\s+", "", sub("\\s+$", "", x))
233}
234
235new_not_implemented_error <- function(message, call) {
236  add_class(new_error(message, call. = call),
237            c("not_implemented_error", "not_implemented"))
238}
239
240add_class <- function(obj, class) {
241  class(obj) <- c(class, class(obj))
242  obj
243}
244
245is_interactive <- function() {
246  opt <- getOption("rlib_interactive")
247  if (isTRUE(opt)) {
248    TRUE
249  } else if (identical(opt, FALSE)) {
250    FALSE
251  } else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
252    FALSE
253  } else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") {
254    FALSE
255  } else if (identical(Sys.getenv("TESTTHAT"), "true")) {
256    FALSE
257  } else {
258    interactive()
259  }
260}
261
262make_buffer <- function() {
263  con <- file(open = "w+b")
264  size <- 0L
265  list(
266    push = function(text) {
267      size <<- size + nchar(text, type = "bytes")
268      cat(text, file = con)
269    },
270    read = function() {
271      readChar(con, size, useBytes = TRUE)
272    },
273    done = function() {
274      close(con)
275    }
276  )
277}
278
279update_vector <- function(x, y = NULL) {
280  if (length(y) == 0L) return(x)
281  c(x[!(names(x) %in% names(y))], y)
282}
283
284process_env <- function(env) {
285  current <- env == "current" & names(env) == ""
286  if (any(current)) env <- update_vector(Sys.getenv(), env[!current])
287  enc2path(paste(names(env), sep = "=", env))
288}
289