1
2make_vanilla_script_expr <- function(expr_file, res, error,
3                                     pre_hook = NULL, post_hook = NULL,
4                                     messages = FALSE) {
5
6  ## Code to handle errors in the child
7  ## This will inserted into the main script
8  err <- if (error == "error") {
9    substitute({
10      callr_data <- as.environment("tools:callr")$`__callr_data__`
11      err <- callr_data$err
12
13      assign(".Traceback", .traceback(4), envir = callr_data)
14
15      dump.frames("__callr_dump__")
16      assign(".Last.dump", .GlobalEnv$`__callr_dump__`, envir = callr_data)
17      rm("__callr_dump__", envir = .GlobalEnv)
18
19      # callr_remote_error does have conditionMessage and conditionCall
20      # methods that refer to $error, but in the subprocess callr is not
21      # loaded, maybe, and these methods are not defined. So we do add
22      # the message and call of the original error
23      e$call <- deparse(conditionCall(e), nlines = 6)
24      e2 <- err$new_error(conditionMessage(e), call. = conditionCall(e))
25      class(e2) <- c("callr_remote_error", class(e2))
26      e2$error <- e
27      # To find the frame of the evaluated function, we search for
28      # do.call in the stack, and then skip one more frame, the other
29      # do.call. This method only must change if the eval code changes,
30      # obviously. Also, it might fail if the pre-hook has do.call() at
31      # the top level.
32      calls <- sys.calls()
33      dcframe <- which(vapply(
34        calls,
35        function(x) length(x) >= 1 && identical(x[[1]], quote(do.call)),
36        logical(1)))[1]
37      if (!is.na(dcframe)) e2$`_ignore` <- list(c(1, dcframe + 1L))
38      e2$`_pid` <- Sys.getpid()
39      e2$`_timestamp` <- Sys.time()
40      if (inherits(e, "rlib_error_2_0")) e2$parent <- e$parent
41      e2 <- err$add_trace_back(e2, embed = FALSE)
42      saveRDS(list("error", e2), file = paste0(`__res__`, ".error")) },
43      list(`__res__` = res)
44    )
45
46  } else if (error %in% c("stack", "debugger")) {
47    substitute(
48      {
49        callr_data <- as.environment("tools:callr")$`__callr_data__`
50        assign(".Traceback", .traceback(4), envir = callr_data)
51        dump.frames("__dump__")         # nocov start
52        saveRDS(
53          list(`__type__`, e, .GlobalEnv$`__dump__`),
54          file = paste0(`__res__`, ".error")
55        )                               # nocov end
56      },
57      list(
58        "__type__" = error,
59        "__res__" = res
60      )
61    )
62  } else {
63    throw(new_error("Unknown `error` argument: `", error, "`"))
64  }
65
66  if (messages) {
67    message <- function() {
68      substitute({
69        pxlib <- as.environment("tools:callr")$`__callr_data__`$pxlib
70        if (is.null(e$code)) e$code <- "301"
71        msg <- paste0("base64::", pxlib$base64_encode(serialize(e, NULL)))
72        data <- paste0(e$code, " ", nchar(msg), "\n", msg)
73        pxlib$write_fd(3L, data)
74
75        if (inherits(e, "cli_message") &&
76            !is.null(findRestart("cli_message_handled"))) {
77          invokeRestart("cli_message_handled")
78        } else if (inherits(e, "message") &&
79                   !is.null(findRestart("muffleMessage"))) {
80          invokeRestart("muffleMessage")
81        }
82      })
83    }
84  } else {
85    message <- function() substitute(signalCondition(e))
86  }
87
88  ## The function to run and its arguments are saved as a list:
89  ## list(fun, args). args itself is a list.
90  ## So the first do.call will create the call: do.call(fun, args)
91  ## The second do.call will perform fun(args).
92  ##
93  ## The c() is needed because the first .GlobalEnv is itself
94  ## an argument to the do.call within the do.call.
95  ##
96  ## It is important that we do not create any temporary variables,
97  ## the function is called from an empty global environment.
98  substitute(
99     {
100      tryCatch(                         # nocov start
101        withCallingHandlers(
102          {
103            `__pre_hook__`
104            saveRDS(
105              do.call(
106                do.call,
107                c(readRDS(`__expr_file__`), list(envir = .GlobalEnv, quote = TRUE)),
108                envir = .GlobalEnv,
109                quote = TRUE
110              ),
111              file = `__res__`
112            )
113            flush(stdout())
114            flush(stderr())
115            `__post_hook__`
116            invisible()
117          },
118          error = function(e) { `__error__` },
119          interrupt = function(e) { `__error__` },
120          callr_message = function(e) { try(`__message__`) }
121        ),
122
123        ## We need to `stop()` here again, otherwise the error message
124        ## is not printed to stderr. See
125        ## https://github.com/r-lib/callr/issues/80
126        ## However, on R 3.1 and R 3.2 throwing an error here
127        ## will crash the R process. With `try()` the error is still
128        ## printed to stderr, but no real error is thrown.
129        error = function(e) { `__post_hook__`; try(stop(e)) },
130        interrupt = function(e) {  `__post_hook__`; e }
131      )                                 # nocov end
132    },
133
134    list(`__error__` = err, `__expr_file__` = expr_file, `__res__` = res,
135         `__pre_hook__` = pre_hook, `__post_hook__` = post_hook,
136         `__message__` = message())
137  )
138}
139
140make_vanilla_script_file <- function(expr_file, res, error) {
141  expr <- make_vanilla_script_expr(expr_file, res, error)
142  script <- deparse(expr)
143
144  tmp <- tempfile("callr-scr-")
145  cat(script, file = tmp, sep = "\n")
146  tmp
147}
148