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