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