1
2setup_script_files <- function(options) {
3  within(options, {
4    func_file   <- save_function_to_temp(options)
5    result_file <- tempfile("callr-res-")
6    script_file <- make_vanilla_script_file(
7      func_file, result_file, options$error)
8    tmp_files <- c(tmp_files, func_file, script_file, result_file)
9  })
10}
11
12save_function_to_temp <- function(options) {
13  tmp <- tempfile("callr-fun-")
14  options$func <- transport_fun(options$func, options$package)
15  # Once we start saving the function environments, we might get
16  # "'package:x' may not be available when loading" warnings
17  suppressWarnings(saveRDS(list(options$func, options$args), file = tmp))
18  tmp
19}
20
21transport_fun <- function(fun, package,
22                          source_refs = getOption("callr.keep.source")) {
23  if (!isTRUE(source_refs)) fun <- remove_source(fun)
24
25  if (isTRUE(package)) {
26    # Do nothing
27  } else if (identical(package, FALSE)) {
28    environment(fun) <- .GlobalEnv
29  } else if (is_string(package)) {
30    environment(fun) <- asNamespace(package)
31  } else {
32    stop("Invalid `package` value for callr function")
33  }
34
35  fun
36}
37
38setup_context <- function(options) {
39
40  ## Avoid R CMD check warning...
41  repos <- libpath <- system_profile <- user_profile <- load_hook <- NULL
42
43  make_path <- function(x) paste(x, collapse = .Platform$path.sep)
44
45  within(options, {
46    ## profiles
47    profiles <- make_profiles(system_profile, user_profile, repos, libpath,
48                             load_hook, env)
49    tmp_files <- c(tmp_files, profiles)
50
51    ## environment files
52    envs <- make_environ(profiles, libpath, env)
53    tmp_files <- c(tmp_files, envs)
54
55    ## environment variables
56
57    ## First, save these, so we can restore them exactly in the subprocess,
58    ## and sub-subprocesses are not affected by our workarounds
59    save_env <- c("R_ENVIRON", "R_ENVIRON_USER", "R_PROFILE",
60                  "R_PROFILE_USER", "R_LIBS", "R_LIBS_USER", "R_LIBS_SITE")
61    keep_set <- save_env %in% names(env)
62    save_set <- !keep_set & save_env %in% names(Sys.getenv())
63    save_nms <- paste0("CALLR_", save_env, "_BAK")
64    env[save_nms[keep_set]] <- env[save_env[keep_set]]
65    env[save_nms[save_set]] <- Sys.getenv(save_env[save_set])
66    env <- env[setdiff(names(env), save_nms[!keep_set & !save_set])]
67
68    if (is.na(env["R_ENVIRON"])) env["R_ENVIRON"] <- envs[[1]]
69    if (is.na(env["R_ENVIRON_USER"])) env["R_ENVIRON_USER"] <- envs[[2]]
70    if (is.na(env["R_PROFILE"])) env["R_PROFILE"] <- profiles[[1]]
71    if (is.na(env["R_PROFILE_USER"])) env["R_PROFILE_USER"] <- profiles[[2]]
72
73    if (is.na(env["R_LIBS"])) env["R_LIBS"] <- make_path(libpath)
74    if (is.na(env["R_LIBS_USER"])) env["R_LIBS_USER"] <- make_path(libpath)
75    if (is.na(env["R_LIBS_SITE"])) env["R_LIBS_SITE"] <- make_path(.Library.site)
76  })
77}
78
79make_profiles <- function(system, user, repos, libpath, load_hook, env) {
80
81  profile_system <- tempfile("callr-spr-")
82  profile_user <- tempfile("callr-upr-")
83
84  ## Create file2
85  cat("", file = profile_system)
86  cat("", file = profile_user)
87
88  ## Add profiles
89  if (system) {
90    sys <- env["R_PROFILE"]
91    if (is.na(sys)) {
92      sys <- Sys.getenv(
93        "R_PROFILE",
94        file.path(R.home("etc"), "Rprofile.site")
95      )
96    }
97    sys <- path.expand(sys)
98    if (file.exists(sys)) file.append(profile_system, sys)
99  }
100
101  if (identical(user, "project")) {
102    local <- ".Rprofile"
103    if (file.exists(local)) user <- local else user <- NA_character_
104  } else if (user) {
105    user <- env["R_PROFILE_USER"]
106    if (is.na(user)) user <- Sys.getenv("R_PROFILE_USER", NA_character_)
107    local <- ".Rprofile"
108    home  <- path.expand("~/.Rprofile")
109    if (is.na(user) && file.exists(local)) user <- local
110    if (is.na(user) && file.exists(home)) user <- home
111  } else {
112    user <- NA_character_
113  }
114
115  if (!is.na(user) && file.exists(user)) {
116    xpr <- substitute(
117      if (file.exists(user)) source(user, local = TRUE),
118      list(user = user)
119    )
120    cat(deparse(xpr), file = profile_user, append = TRUE, sep = "\n")
121  }
122
123  ## Override repos, as requested
124  for (p in c(profile_system, profile_user)) {
125    cat("options(repos=", deparse(repos), ")\n", sep = "", file = p,
126        append = TRUE)
127  }
128
129  ## Set .Library.site
130  cat(".Library.site <- ", deparse(.Library.site),
131      "\n.libPaths(.libPaths())\n", file = profile_system, append = TRUE)
132
133  ## Set .libPaths()
134  for (p in c(profile_system, profile_user))  {
135    cat(".libPaths(", deparse(libpath), ")\n", sep = "", file = p,
136        append = TRUE)
137  }
138
139  if (!is.null(load_hook)) {
140    cat(load_hook, sep = "",  file = profile_user, append = TRUE)
141  }
142
143  c(profile_system, profile_user)
144}
145
146make_environ <- function(profiles, libpath, env) {
147
148  env_sys <- tempfile("callr-sev-")
149  env_user <- tempfile("callr-uev-")
150
151  for (ef in c(env_sys, env_user)) {
152    cat("CALLR_CHILD_R_LIBS=\"${R_LIBS}\"\n",
153        "CALLR_CHILD_R_LIBS_USER=\"${R_LIBS_USER}\"\n",
154        "CALLR_CHILD_R_LIBS_SITE=\"${R_LIBS_SITE}\"\n",
155        file = ef, append = TRUE)
156  }
157
158  sys <- env["R_ENVIRON"]
159  if (is.na(sys)) sys <- Sys.getenv("R_ENVIRON", NA_character_)
160  if (is.na(sys)) sys <- file.path(R.home("etc"), "Renviron.site")
161  if (!is.na(sys) && file.exists(sys)) file.append(env_sys, sys)
162
163  user <- env["R_ENVIRON_USER"]
164  if (is.na(user)) user <- Sys.getenv("R_ENVIRON_USER", NA_character_)
165  local <- ".Renviron"
166  home <- "~/.Renviron"
167  if (is.na(user) && file.exists(local)) user <- local
168  if (is.na(user) && file.exists(home)) user <- home
169  if (!is.na(user) && file.exists(user)) file.append(env_user, user)
170
171  for (ef in c(env_sys, env_user)) {
172    cat("R_PROFILE=\"", profiles[[1]], "\"\n", file = ef,
173        append = TRUE, sep = "")
174    cat("R_PROFILE_USER=\"", profiles[[2]], "\"\n", file = ef,
175        append = TRUE, sep = "")
176    cat("R_LIBS_SITE=\"${CALLR_CHILD_R_LIBS_SITE:-",
177        paste(.Library.site, collapse = .Platform$path.sep), "}\"\n",
178        file = ef, append = TRUE, sep = "")
179    cat("R_LIBS=\"${CALLR_CHILD_R_LIBS:-",
180        paste(libpath, collapse = .Platform$path.sep), "}\"\n",
181        file = ef, append = TRUE, sep = "")
182    cat("R_LIBS_USER=\"${CALLR_CHILD_R_LIBS_USER:-",
183        paste(libpath, collapse = .Platform$path.sep), "}\"\n",
184        file = ef, append = TRUE, sep = "")
185  }
186
187  c(env_sys, env_user)
188}
189
190setup_callbacks <- function(options) {
191
192  ## We cannot easily use `within` here, because the
193  ## functions we create will have the wrong environment
194
195  cb <- options$callback
196  block_cb <- options$block_callback
197
198  ## This is cumbersome, because we cannot easily set a named list
199  ## element to NULL
200  options <- append(
201    options,
202    list("real_block_callback" =
203           if (!is.null(block_cb)) function(x, proc) block_cb(x))
204  )
205
206  callback_factory <- function(stream) {
207    ## Need to evaluate it when the callback is created
208    force(stream)
209
210    ## In case there is no output, we create an empty file here
211    if (!is.null(stream) && stream != "2>&1") cat("", file = stream)
212
213    if (!is.null(cb)) {
214      function(x, proc) {
215        if (!is.null(stream)) cat(x, file = stream, sep = "\n", append = TRUE)
216        cb(x)
217      }
218
219    } else {
220      function(x, proc) {
221        if (!is.null(stream)) cat(x, file = stream, sep = "\n", append = TRUE)
222      }
223    }
224  }
225
226  options <- append(options, list("real_callback" = callback_factory))
227  options
228}
229
230setup_r_binary_and_args <- function(options, script_file = TRUE) {
231  options$arch <- options$arch %||% "same"
232  if (grepl("[/\\\\]", options$arch)) {
233    path <- options$arch
234
235  } else if (options$arch != "same") {
236    path <- file.path(
237      R.home(),
238      "bin",
239      options$arch,
240      if (os_platform() == "windows") "Rterm" else "R"
241    )
242
243  } else {
244    exec <- if (os_platform() == "windows") "Rterm" else "R"
245    path <- file.path(R.home("bin"), exec)
246  }
247
248  if (!file.exists(path) &&
249      !file.exists(paste0(path, ".exe"))) {
250    stop("Cannot find R executable at `", path, "`")
251  }
252
253  options$bin <- path
254  options$real_cmdargs <-
255    c(options$cmdargs, if (script_file) c("-f", options$script_file))
256  options
257}
258
259setup_rcmd_binary_and_args <- function(options) {
260
261  if (os_platform() == "windows") {
262    options$bin <- file.path(R.home("bin"), "Rcmd.exe")
263    options$real_cmdargs <- c(options$cmd, options$cmdargs)
264
265  } else {
266    options$bin <- file.path(R.home("bin"), "R")
267    options$real_cmdargs <- c("CMD", options$cmd, options$cmdargs)
268  }
269
270  options
271}
272
273setup_rscript_binary_and_args <- function(options) {
274
275  if(os_platform() == "windows") {
276    options$bin <- file.path(R.home("bin"), "Rscript.exe")
277
278  } else {
279    options$bin <- file.path(R.home("bin"), "Rscript")
280  }
281
282  options$real_cmdargs <- c(options$script, options$cmdargs)
283  options
284}
285