1#' Run \code{system2()} and mark its character output as UTF-8 if appropriate
2#'
3#' This is a wrapper function based on \code{system2()}. If \code{system2()}
4#' returns character output (e.g., with the argument \code{stdout = TRUE}),
5#' check if the output is encoded in UTF-8. If it is, mark it with UTF-8
6#' explicitly.
7#' @param ... Passed to \code{\link{system2}()}.
8#' @return The value returned by \code{system2()}.
9#' @export
10#' @examplesIf interactive()
11#' a = shQuote(c('-e', 'print(intToUtf8(c(20320, 22909)))'))
12#' x2 = system2('Rscript', a, stdout = TRUE)
13#' Encoding(x2)  # unknown
14#'
15#' x3 = xfun::system3('Rscript', a, stdout = TRUE)
16#' # encoding of x3 should be UTF-8 if the current locale is UTF-8
17#' !l10n_info()[['UTF-8']] || Encoding(x3) == 'UTF-8'  # should be TRUE
18system3 = function(...) {
19  res = system2(...)
20  if (is.character(res)) {
21    if (all(is_utf8(res))) Encoding(res) = 'UTF-8'
22  }
23  if (is.integer(res) && res == 0) invisible(res) else res
24}
25
26#' Run OptiPNG on all PNG files under a directory
27#'
28#' Call the command \command{optipng} via \code{system2()} to optimize all PNG
29#' files under a directory.
30#' @param dir Path to a directory.
31#' @param files Alternatively, you can choose the specific files to optimize.
32#' @param ... Arguments to be passed to \code{system2()}.
33#' @references OptiPNG: \url{http://optipng.sourceforge.net}.
34#' @export
35optipng = function(
36  dir = '.', files = list.files(dir, '[.]png$', recursive = TRUE, full.names = TRUE), ...
37) {
38  if (Sys.which('optipng') != '') for (f in files) system2('optipng', shQuote(f), ...)
39}
40
41#' Run the commands \command{Rscript} and \command{R CMD}
42#'
43#' Wrapper functions to run the commands \command{Rscript} and \command{R CMD}.
44#' @param args A character vector of command-line arguments.
45#' @param ... Other arguments to be passed to \code{\link{system2}()}.
46#' @export
47#' @return A value returned by \code{system2()}.
48#' @examples library(xfun)
49#' Rscript(c('-e', '1+1'))
50#' Rcmd(c('build', '--help'))
51Rscript = function(args, ...) {
52  # unset R_TESTS for the new R session: https://stackoverflow.com/a/27994299
53  if (is_R_CMD_check()) {
54    v = set_envvar(c(R_TESTS = NA)); on.exit(set_envvar(v), add = TRUE)
55  }
56  system2(file.path(R.home('bin'), 'Rscript'), args, ...)
57}
58
59#' @rdname Rscript
60#' @export
61Rcmd = function(args, ...) {
62  system2(file.path(R.home('bin'), 'R'), c('CMD', args), ...)
63}
64
65#' Call a function in a new R session via \code{Rscript()}
66#'
67#' Save the argument values of a function in a temporary RDS file, open a new R
68#' session via \code{\link{Rscript}()}, read the argument values, call the
69#' function, and read the returned value back to the current R session.
70#' @param fun A function, or a character string that can be parsed and evaluated
71#'   to a function.
72#' @param args A list of argument values.
73#' @param options A character vector of options to passed to
74#'   \code{\link{Rscript}}, e.g., \code{"--vanilla"}.
75#' @param ...,wait Arguments to be passed to \code{\link{system2}()}.
76#' @param fail The desired error message when an error occurred in calling the
77#'   function.
78#' @export
79#' @return The returned value of the function in the new R session.
80#' @examples factorial(10)
81#' # should return the same value
82#' xfun::Rscript_call('factorial', list(10))
83#'
84#' # the first argument can be either a character string or a function
85#' xfun::Rscript_call(factorial, list(10))
86#'
87#' # Run Rscript starting a vanilla R session
88#' xfun::Rscript_call(factorial, list(10), options = c("--vanilla"))
89Rscript_call = function(
90  fun, args = list(), options = NULL, ..., wait = TRUE,
91  fail = sprintf("Failed to run '%s' in a new R session.", deparse(substitute(fun))[1])
92) {
93  f = replicate(2, tempfile(fileext = '.rds'))
94  on.exit(unlink(if (wait) f else f[2]), add = TRUE)
95  saveRDS(list(fun, args), f[1])
96  Rscript(
97    c(options, shQuote(c(pkg_file('scripts', 'call-fun.R'), f)))
98    ,..., wait = wait
99  )
100  if (wait) if (file_exists(f[2])) readRDS(f[2]) else stop(fail, call. = FALSE)
101}
102
103# call a function in a background process
104Rscript_bg = function(fun, args = list(), timeout = 10) {
105  pid = tempfile()  # to store the process ID of the new R session
106  saveRDS(NULL, pid)
107
108  Rscript_call(function() {
109    saveRDS(Sys.getpid(), pid)
110    # remove this pid file when the function finishes
111    on.exit(unlink(pid), add = TRUE)
112    do.call(fun, args)
113  }, wait = FALSE)
114
115  id = NULL  # read the above process ID into this R session
116  res = list(pid = id, is_alive = function() FALSE)
117
118  # check if the pid file still exists; if not, the process has ended
119  if (!file_exists(pid)) return(res)
120
121  t0 = Sys.time()
122  while (difftime(Sys.time(), t0, units = 'secs') < timeout) {
123    Sys.sleep(.1)
124    if (!file_exists(pid)) return(res)
125    if (length(id <- readRDS(pid)) == 1) break
126  }
127  if (length(id) == 0) stop(
128    'Failed to launch the background process in ', timeout, ' seconds (timeout).'
129  )
130
131  list(pid = id, is_alive = function() file_exists(pid))
132}
133
134#' Kill a process and (optionally) all its child processes
135#'
136#' Run the command \command{taskkill /f /pid} on Windows and \command{kill} on
137#' Unix, respectively, to kill a process.
138#' @param pid The process ID.
139#' @param recursive Whether to kill the child processes of the process.
140#' @param ... Arguments to be passed to \code{\link{system2}()} to run the
141#'   command to kill the process.
142#' @return The status code returned from \code{system2()}.
143#' @export
144proc_kill = function(pid, recursive = TRUE, ...) {
145  if (is_windows()) {
146    system2('taskkill', c(if (recursive) '/t', '/f', '/pid', pid), ...)
147  } else {
148    system2('kill', c(pid, if (recursive) child_pids(pid)), ...)
149  }
150}
151
152# obtain pids of all child processes (recursively)
153child_pids = function(id) {
154  x = system2('sh', shQuote(c(pkg_file('scripts', 'child-pids.sh'), id)), stdout = TRUE)
155  grep('^[0-9]+$', x, value = TRUE)
156}
157
158powershell = function(command) {
159  if (Sys.which('powershell') == '') return()
160  command = paste(command, collapse = ' ')
161  system2('powershell', c('-Command', shQuote(command)), stdout = TRUE)
162}
163
164# start a background process via the PowerShell cmdlet and return its pid
165ps_process = function(command, args = character(), verbose = FALSE) {
166  powershell(c(
167    'echo (Start-Process', '-FilePath', shQuote(command), '-ArgumentList',
168    ps_quote(args), '-PassThru', '-WindowStyle',
169    sprintf('%s).ID', if (verbose) 'Normal' else 'Hidden')
170  ))
171}
172
173# quote PowerShell arguments properly
174ps_quote = function(x) {
175  x = gsub('"', '""', x)  # '""' mean a literal '"'
176  # if an argument contains a space, surround it with escaped double quotes `"`"
177  i = grep('\\s', x)
178  x[i] = sprintf('`"%s`"', x[i])
179  sprintf('"%s"', paste(x, collapse = ' '))
180}
181
182#' Start a background process
183#'
184#' Start a background process using the PowerShell cmdlet \command{Start-Process
185#' -PassThru} on Windows or the ampersand \command{&} on Unix, and return the
186#' process ID.
187#' @param command,args The system command and its arguments. They do not need to
188#'   be quoted, since they will be quoted via \code{\link{shQuote}()}
189#'   internally.
190#' @param verbose If \code{FALSE}, suppress the output from \verb{stdout} (and
191#'   also \verb{stderr} on Windows). The default value of this argument can be
192#'   set via a global option, e.g., \code{options(xfun.bg_process.verbose =
193#'   TRUE)}.
194#' @return The process ID as a character string.
195#' @note On Windows, if PowerShell is not available, try to use
196#'   \code{\link{system2}(wait = FALSE)} to start the background process
197#'   instead. The process ID will be identified from the output of the command
198#'   \command{tasklist}. This method of looking for the process ID may not be
199#'   reliable. If the search is not successful in 30 seconds, it will throw an
200#'   error (timeout). If a longer time is needed, you may set
201#'   \code{options(xfun.bg_process.timeout)} to a larger value, but it should be
202#'   very rare that a process cannot be started in 30 seconds. When you reach
203#'   the timeout, it is more likely that the command actually failed.
204#' @export
205#' @seealso \code{\link{proc_kill}()} to kill a process.
206bg_process = function(
207  command, args = character(), verbose = getOption('xfun.bg_process.verbose', FALSE)
208) {
209  throw_error = function(...) stop(
210    'Failed to run the command', ..., ' in the background: ',
211    paste(shQuote(c(command, args)), collapse = ' '), call. = FALSE
212  )
213
214  # check the possible pid returned from system2()
215  check_pid = function(res) {
216    if (is.null(res)) return(res)
217    if (!is.null(attr(res, 'status'))) throw_error()
218    if (length(res) == 1 && grepl('^[0-9]+$', res)) return(res)
219    throw_error()
220  }
221
222  if (is_windows()) {
223    # first try 'Start-Process -PassThrough' to start a background process; if
224    # PowerShell is unavailable, fall back to system2(wait = FALSE), and the
225    # method to find out the pid is not 100% reliable
226    if (length(pid <- check_pid(ps_process(command, args, verbose))) == 1) return(pid)
227
228    message(
229      'It seems you do not have PowerShell installed. The process ID may be inaccurate.'
230    )
231    # format of task list: hugo.exe    4592 Console      1     35,188 K
232    tasklist = function() system2('tasklist', stdout = TRUE)
233    pid1 = tasklist()
234    system2(command, shQuote(args), wait = FALSE)
235
236    get_pid = function() {
237      # make sure the command points to an actual executable (e.g., resolve 'R'
238      # to 'R.exe')
239      if (!file_exists(command)) {
240        if (Sys.which(command) != '') command = Sys.which(command)
241      }
242      cmd = basename(command)
243
244      pid2 = setdiff(tasklist(), pid1)
245      # the process's info should start with the command name
246      pid2 = pid2[substr(pid2, 1, nchar(cmd)) == cmd]
247      if (length(pid2) == 0) return()
248      m = regexec('\\s+([0-9]+)\\s+', pid2)
249      for (v in regmatches(pid2, m)) if (length(v) >= 2) return(v[2])
250    }
251
252    t0 = Sys.time(); id = NULL; timeout = getOption('xfun.bg_process.timeout', 30)
253    while (difftime(Sys.time(), t0, units = 'secs') < timeout) {
254      if (length(id <- get_pid()) > 0) break
255    }
256
257    if (length(id) > 0) return(id)
258
259    system2(command, args, timeout = timeout)  # see what the error is
260    throw_error(' in ', timeout, ' second(s)')
261  } else {
262    pid = tempfile(); on.exit(unlink(pid), add = TRUE)
263    code = paste(c(
264      shQuote(c(command, args)), if (!verbose) '> /dev/null', '& echo $! >', shQuote(pid)
265    ), collapse = ' ')
266    system2('sh', c('-c', shQuote(code)))
267    return(check_pid(readLines(pid)))
268  }
269}
270
271#' Upload to an FTP server via \command{curl}
272#'
273#' The function \code{upload_ftp()} runs the command \command{curl -T file
274#' server} to upload a file to an FTP server if the system command
275#' \command{curl} is available, otherwise it uses the R package \pkg{curl}. The
276#' function \code{upload_win_builder()} uses \code{upload_ftp()} to upload
277#' packages to the win-builder server.
278#'
279#' These functions were written mainly to save package developers the trouble of
280#' going to the win-builder web page and uploading packages there manually.
281#' @param file Path to a local file.
282#' @param server The address of the FTP server. For \code{upload_win_builder()},
283#'   \code{server = 'https'} means uploading to
284#'   \code{'https://win-builder.r-project.org/upload.aspx'}.
285#' @param dir The remote directory to which the file should be uploaded.
286#' @param version The R version(s) on win-builder.
287#' @return Status code returned from \code{\link{system2}()} or
288#'   \code{curl::curl_fetch_memory()}.
289#' @export
290upload_ftp = function(file, server, dir = '') {
291  if (dir != '') dir = gsub('/*$', '/', dir)
292  server = paste0(server, dir)
293  if (Sys.which('curl') == '') {
294    curl::curl_upload(file, server)$status_code
295  } else {
296    system2('curl', shQuote(c('-T', file, server)))
297  }
298}
299
300#' @param solaris Whether to also upload the package to the Rhub server to check
301#'   it on Solaris.
302#' @rdname upload_ftp
303#' @export
304upload_win_builder = function(
305  file = pkg_build(), version = c("R-devel", "R-release", "R-oldrelease"),
306  server = c('ftp', 'https'), solaris = pkg_available('rhub')
307) {
308  if (missing(file)) on.exit(file.remove(file), add = TRUE)
309  if (system2('git', 'status', stderr = FALSE) == 0) system2('git', 'pull')
310  server = server[1]
311  server = switch(
312    server,
313    'ftp'   = paste0(server, '://win-builder.r-project.org/'),
314    'https' = paste0(server, '://win-builder.r-project.org/upload.aspx'),
315    server
316  )
317  res = if (grepl('^ftp://', server)) {
318    lapply(version, upload_ftp, file = file, server = server)
319  } else {
320    vers = c('R-devel' = 2, 'R-release' = 1, 'R-oldrelease' = 3)
321    params = list(
322      FileUpload = file,
323      Button = 'Upload File',
324      # perhaps we should read these tokens dynamically from
325      # https://win-builder.r-project.org/upload.aspx
326      `__VIEWSTATE` = '/wEPDwULLTE0OTY5NTg0MTUPZBYCAgIPFgIeB2VuY3R5cGUFE211bHRpcGFydC9mb3JtLWRhdGFkZFHMrNH6JjHTyJ00T0dAADGf4oa0',
327      `__VIEWSTATEGENERATOR` = '69164837',
328      `__EVENTVALIDATION` = '/wEWBQKksYbrBgKM54rGBgK7q7GGCAKF2fXbAwLWlM+bAqR2dARbCNfKVu0vDawqWYgB5kKI'
329    )
330    lapply(version, function(i) {
331      names(params)[1:2] = paste0(names(params)[1:2], vers[i])
332      if (Sys.which('curl') == '') {
333        h = curl::new_handle()
334        params[[1]] = curl::form_file(params[[1]])
335        curl::handle_setform(h, .list = params)
336        curl::curl_fetch_memory(server, h)$status_code
337      } else {
338        params[1] = paste0('@', params[1])
339        system2('curl', shQuote(c(
340          rbind('-F', paste(names(params), params, sep = '=')),
341          server
342        )), stdout = FALSE)
343      }
344    })
345  }
346
347  if (solaris) rhub::check_on_solaris(
348    file, check_args = '--no-manual', show_status = FALSE,
349    env_vars = c(`_R_CHECK_FORCE_SUGGESTS_` = 'false')
350  )
351
352  setNames(unlist(res), version)
353}
354