Nothing
R/standalone-errors.R
In callr: Call R from R
# ---
# repo: r-lib/processx
# file: standalone-errors.R
# last-updated: 2023-01-15
# license: https://unlicense.org
# ---
#
# Standalone file for better error handling. If you can allow package
# dependencies, then you are probably better off using rlang's
# functions for errors.
#
# ## Soft-dependency
#
# - aaa-standalone-rstudio-detect.R in r-lib/cli
#
# ## Features
#
# - Throw conditions and errors with the same API.
# - Automatically captures the right calls and adds them to the conditions.
# - Sets `.Last.error`, so you can easily inspect the errors, even if they
# were not caught.
# - It only sets `.Last.error` for the errors that are not caught.
# - Hierarchical errors, to allow higher level error messages, that are
# more meaningful for the users, while also keeping the lower level
# details in the error object. (So in `.Last.error` as well.)
# - `.Last.error` always includes a stack trace. (The stack trace is
# common for the whole error hierarchy.) The trace is accessible within
# the error, e.g. `.Last.error$trace`. The trace of the last error is
# also at `.Last.error.trace`.
# - Can merge errors and traces across multiple processes.
# - Pretty-print errors and traces, if the cli package is loaded.
# - Automatically hides uninformative parts of the stack trace when
# printing.
#
# ## API
#
# ```
# new_cond(..., call. = TRUE, srcref = NULL, domain = NA)
# new_error(..., call. = TRUE, srcref = NULL, domain = NA)
# throw(cond, parent = NULL, frame = environment())
# throw_error(cond, parent = NULL, frame = environment())
# chain_error(expr, err, call = sys.call(-1))
# chain_call(.NAME, ...)
# chain_clean_call(.NAME, ...)
# onload_hook()
# add_trace_back(cond, frame = NULL)
# format$advice(x)
# format$call(call)
# format$class(x)
# format$error(x, trace = FALSE, class = FALSE, advice = !trace, ...)
# format$error_heading(x, prefix = NULL)
# format$header_line(x, prefix = NULL)
# format$srcref(call, srcref = NULL)
# format$trace(x, ...)
# ```
#
# ## Roadmap:
# - better printing of anonymous function in the trace
#
# ## Changelog
#
# ### 1.0.0 -- 2019-06-18
#
# * First release.
#
# ### 1.0.1 -- 2019-06-20
#
# * Add `rlib_error_always_trace` option to always add a trace
#
# ### 1.0.2 -- 2019-06-27
#
# * Internal change: change topenv of the functions to baseenv()
#
# ### 1.1.0 -- 2019-10-26
#
# * Register print methods via onload_hook() function, call from .onLoad()
# * Print the error manually, and the trace in non-interactive sessions
#
# ### 1.1.1 -- 2019-11-10
#
# * Only use `trace` in parent errors if they are `rlib_error`s.
# Because e.g. `rlang_error`s also have a trace, with a slightly
# different format.
#
# ### 1.2.0 -- 2019-11-13
#
# * Fix the trace if a non-thrown error is re-thrown.
# * Provide print_this() and print_parents() to make it easier to define
# custom print methods.
# * Fix annotating our throw() methods with the incorrect `base::`.
#
# ### 1.2.1 -- 2020-01-30
#
# * Update wording of error printout to be less intimidating, avoid jargon
# * Use default printing in interactive mode, so RStudio can detect the
# error and highlight it.
# * Add the rethrow_call_with_cleanup function, to work with embedded
# cleancall.
#
# ### 1.2.2 -- 2020-11-19
#
# * Add the `call` argument to `catch_rethrow()` and `rethrow()`, to be
# able to omit calls.
#
# ### 1.2.3 -- 2021-03-06
#
# * Use cli instead of crayon
#
# ### 1.2.4 -- 2021-04-01
#
# * Allow omitting the call with call. = FALSE in `new_cond()`, etc.
#
# ### 1.3.0 -- 2021-04-19
#
# * Avoid embedding calls in trace with embed = FALSE.
#
# ### 2.0.0 -- 2021-04-19
#
# * Versioned classes and print methods
#
# ### 2.0.1 -- 2021-06-29
#
# * Do not convert error messages to native encoding before printing,
# to be able to print UTF-8 error messages on Windows.
#
# ### 2.0.2 -- 2021-09-07
#
# * Do not translate error messages, as this converts them to the native
# encoding. We keep messages in UTF-8 now.
#
# ### 3.0.0 -- 2022-04-19
#
# * Major rewrite, use rlang compatible error objects. New API.
#
# ### 3.0.1 -- 2022-06-17
#
# * Remove the `rlang_error` and `rlang_trace` classes, because our new
# deparsed `call` column in the trace is not compatible with rlang.
#
# ### 3.0.2 -- 2022-08-01
#
# * Use a `procsrcref` column for processed source references.
# Otherwise testthat (and probably other rlang based packages), will
# pick up the `srcref` column, and they expect an `srcref` object there.
#
# ### 3.1.0 -- 2022-10-04
#
# * Add ANSI hyperlinks to stack traces, if we have a recent enough
# cli package that supports this.
#
# ### 3.1.1 -- 2022-11-17
#
# * Use `[[` instead of `$` to fix some partial matches.
# * Use fully qualified `base::stop()` to enable overriding `stop()`
# in a package. (Makes sense if compat files use `stop()`.
# * The `is_interactive()` function is now exported.
#
# ### 3.1.2 -- 2022-11-18
#
# * The `parent` condition can now be an interrupt.
#
# ### 3.1.3 -- 2023-01-15
#
# * Now we do not load packages when walking the trace.
#
# ### 3.1.4 -- 2023-04-13
#
# * `call.` can now be a frame environment as in `rlang::abort()`
err <- local({
# -- dependencies -----------------------------------------------------
rstudio_detect <- rstudio$detect
# -- condition constructors -------------------------------------------
#' Create a new condition
#'
#' @noRd
#' @param ... Parts of the error message, they will be converted to
#' character and then concatenated, like in [stop()].
#' @param call. A call object to include in the condition, or `TRUE`
#' or `NULL`, meaning that [throw()] should add a call object
#' automatically. If `FALSE`, then no call is added.
#' @param srcref Alternative source reference object to use instead of
#' the one of `call.`.
#' @param domain Translation domain, see [stop()]. We set this to
#' `NA` by default, which means that no translation occurs. This
#' has the benefit that the error message is not re-encoded into
#' the native locale.
#' @return Condition object. Currently a list, but you should not rely
#' on that.
new_cond <- function(..., call. = TRUE, srcref = NULL, domain = NA) {
message <- .makeMessage(..., domain = domain)
structure(
list(message = message, call = call., srcref = srcref),
class = c("condition"))
}
#' Create a new error condition
#'
#' It also adds the `rlib_error` class.
#'
#' @noRd
#' @param ... Passed to [new_cond()].
#' @param call. Passed to [new_cond()].
#' @param srcref Passed tp [new_cond()].
#' @param domain Passed to [new_cond()].
#' @return Error condition object with classes `rlib_error`, `error`
#' and `condition`.
new_error <- function(..., call. = TRUE, srcref = NULL, domain = NA) {
cond <- new_cond(..., call. = call., domain = domain, srcref = srcref)
class(cond) <- c("rlib_error_3_0", "rlib_error", "error", "condition")
cond
}
# -- throwing conditions ----------------------------------------------
#' Throw a condition
#'
#' If the condition is an error, it will also call [stop()], after
#' signalling the condition first. This means that if the condition is
#' caught by an exiting handler, then [stop()] is not called.
#'
#' @noRd
#' @param cond Condition object to throw. If it is an error condition,
#' then it calls [stop()].
#' @param parent Parent condition.
#' @param frame The throwing context. Can be used to hide frames from
#' the backtrace.
throw <- throw_error <- function(cond,
parent = NULL,
call = parent.frame(),
frame = environment()) {
if (!inherits(cond, "condition")) {
cond <- new_error(cond)
}
if (!is.null(parent) && !inherits(parent, "condition")) {
throw(new_error("Parent condition must be a condition object"))
}
if (isTRUE(cond[["call"]])) {
cond[["call"]] <- frame_call(call)
} else if (identical(cond[["call"]], FALSE)) {
cond[["call"]] <- NULL
} else if (is.environment(cond[["call"]])) {
cond[["call"]] <- frame_call(cond[["call"]])
}
cond <- process_call(cond)
if (!is.null(parent)) {
cond$parent <- process_call(parent)
}
# We can set an option to always add the trace to the thrown
# conditions. This is useful for example in context that always catch
# errors, e.g. in testthat tests or knitr. This options is usually not
# set and we signal the condition here
always_trace <- isTRUE(getOption("rlib_error_always_trace"))
.hide_from_trace <- 1L
# .error_frame <- cond
if (!always_trace) signalCondition(cond)
if (is.null(cond$`_pid`)) cond$`_pid` <- Sys.getpid()
if (is.null(cond$`_timestamp`)) cond$`_timestamp` <- Sys.time()
# If we get here that means that the condition was not caught by
# an exiting handler. That means that we need to create a trace.
# If there is a hand-constructed trace already in the error object,
# then we'll just leave it there.
if (is.null(cond$trace)) cond <- add_trace_back(cond, frame = frame)
# Set up environment to store .Last.error, it will be just before
# baseenv(), so it is almost as if it was in baseenv() itself, like
# .Last.value. We save the print methods here as well, and then they
# will be found automatically.
if (! "org:r-lib" %in% search()) {
do.call("attach", list(new.env(), pos = length(search()),
name = "org:r-lib"))
}
env <- as.environment("org:r-lib")
env$.Last.error <- cond
env$.Last.error.trace <- cond$trace
# If we always wanted a trace, then we signal the condition here
if (always_trace) signalCondition(cond)
# If this is not an error, then we'll just return here. This allows
# throwing interrupt conditions for example, with the same UI.
if (! inherits(cond, "error")) return(invisible())
.hide_from_trace <- NULL
# Top-level handler, this is intended for testing only for now,
# and its design might change.
if (!is.null(th <- getOption("rlib_error_handler")) &&
is.function(th)) {
return(th(cond))
}
# In non-interactive mode, we print the error + the traceback
# manually, to make sure that it won't be truncated by R's error
# message length limit.
out <- format(
cond,
trace = !is_interactive(),
class = FALSE,
full = !is_interactive()
)
writeLines(out, con = default_output())
# Dropping the classes and adding "duplicate_condition" is a workaround
# for the case when we have non-exiting handlers on throw()-n
# conditions. These would get the condition twice, because stop()
# will also signal it. If we drop the classes, then only handlers
# on "condition" objects (i.e. all conditions) get duplicate signals.
# This is probably quite rare, but for this rare case they can also
# recognize the duplicates from the "duplicate_condition" extra class.
class(cond) <- c("duplicate_condition", "condition")
# Turn off the regular error printing to avoid printing
# the error twice.
opts <- options(show.error.messages = FALSE)
on.exit(options(opts), add = TRUE)
base::stop(cond)
}
# -- rethrow with parent -----------------------------------------------
#' Re-throw an error with a better error message
#'
#' Evaluate `expr` and if it errors, then throw a new error `err`,
#' with the original error set as its parent.
#'
#' @noRd
#' @param expr Expression to evaluate.
#' @param err Error object or message to use for the child error.
#' @param call Call to use in the re-thrown error. See [throw()].
chain_error <- function(expr, err, call = sys.call(-1), srcref = NULL) {
.hide_from_trace <- 1
force(call)
srcref <- srcref %||% utils::getSrcref(sys.call())
withCallingHandlers({
expr
}, error = function(e) {
.hide_from_trace <- 0:1
e$srcref <- srcref
e$procsrcref <- NULL
if (!inherits(err, "condition")) {
err <- new_error(err, call. = call)
}
throw_error(err, parent = e)
})
}
# -- rethrowing conditions from C code ---------------------------------
#' Version of .Call that throw()s errors
#'
#' It re-throws error from compiled code. If the error had class
#' `simpleError`, like all errors, thrown via `error()` in C do, it also
#' adds the `c_error` class.
#'
#' @noRd
#' @param .NAME Compiled function to call, see [.Call()].
#' @param ... Function arguments, see [.Call()].
#' @return Result of the call.
chain_call <- function(.NAME, ...) {
.hide_from_trace <- 1:3 # withCallingHandlers + do.call + .handleSimpleError (?)
call <- sys.call()
call1 <- sys.call(-1)
srcref <- utils::getSrcref(call)
withCallingHandlers(
do.call(".Call", list(.NAME, ...)),
error = function(e) {
.hide_from_trace <- 0:1
e$srcref <- srcref
e$procsrcref <- NULL
e[["call"]] <- call
name <- native_name(.NAME)
err <- new_error("Native call to `", name, "` failed", call. = call1)
cerror <- if (inherits(e, "simpleError")) "c_error"
class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
throw_error(err, parent = e)
}
)
}
package_env <- topenv()
#' Version of entrace_call that supports cleancall
#'
#' This function is the same as [entrace_call()], except that it
#' uses cleancall's [.Call()] wrapper, to enable resource cleanup.
#' See https://github.com/r-lib/cleancall#readme for more about
#' resource cleanup.
#'
#' @noRd
#' @param .NAME Compiled function to call, see [.Call()].
#' @param ... Function arguments, see [.Call()].
#' @return Result of the call.
chain_clean_call <- function(.NAME, ...) {
.hide_from_trace <- 1:3
call <- sys.call()
call1 <- sys.call(-1)
srcref <- utils::getSrcref(call)
withCallingHandlers(
package_env$call_with_cleanup(.NAME, ...),
error = function(e) {
.hide_from_trace <- 0:1
e$srcref <- srcref
e$procsrcref <- NULL
e[["call"]] <- call
name <- native_name(.NAME)
err <- new_error("Native call to `", name, "` failed", call. = call1)
cerror <- if (inherits(e, "simpleError")) "c_error"
class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
throw_error(err, parent = e)
}
)
}
# -- create traceback -------------------------------------------------
#' Create a traceback
#'
#' [throw()] calls this function automatically if an error is not caught,
#' so there is currently not much use to call it directly.
#'
#' @param cond Condition to add the trace to
#' @param frame Use this context to hide some frames from the traceback.
#'
#' @return A condition object, with the trace added.
add_trace_back <- function(cond, frame = NULL) {
idx <- seq_len(sys.parent(1L))
frames <- sys.frames()[idx]
# TODO: remove embedded objects from calls
calls <- as.list(sys.calls()[idx])
parents <- sys.parents()[idx]
namespaces <- unlist(lapply(
seq_along(frames),
function(i) {
if (is_operator(calls[[i]])) {
"o"
} else {
env_label(topenvx(environment(sys.function(i))))
}
}
))
pids <- rep(cond$`_pid` %||% Sys.getpid(), length(calls))
mch <- match(format(frame), sapply(frames, format))
if (is.na(mch)) {
visibles <- TRUE
} else {
visibles <- c(rep(TRUE, mch), rep(FALSE, length(frames) - mch))
}
scopes <- vapply(idx, FUN.VALUE = character(1), function(i) {
tryCatch(
get_call_scope(calls[[i]], namespaces[[i]]),
error = function(e) ""
)
})
namespaces <- ifelse(scopes %in% c("::", ":::"), namespaces, NA_character_)
funs <- ifelse(
is.na(namespaces),
ifelse(scopes != "", paste0(scopes, " "), ""),
paste0(namespaces, scopes)
)
funs <- paste0(
funs,
vapply(calls, function(x) format_name(x[[1]])[1], character(1))
)
visibles <- visibles & mark_invisible_frames(funs, frames)
pcs <- lapply(calls, function(c) process_call(list(call = c)))
calls <- lapply(pcs, "[[", "call")
srcrefs <- I(lapply(pcs, "[[", "srcref"))
procsrcrefs <- I(lapply(pcs, "[[", "procsrcref"))
cond$trace <- new_trace(
calls,
parents,
visibles = visibles,
namespaces = namespaces,
scopes = scopes,
srcrefs = srcrefs,
procsrcrefs = procsrcrefs,
pids
)
cond
}
is_operator <- function(cl) {
is.call(cl) && length(cl) >= 1 && is.symbol(cl[[1]]) &&
grepl("^[^.a-zA-Z]", as.character(cl[[1]]))
}
mark_invisible_frames <- function(funs, frames) {
visibles <- rep(TRUE, length(frames))
hide <- lapply(frames, "[[", ".hide_from_trace")
w_hide <- unlist(mapply(seq_along(hide), hide, FUN = function(i, w) {
i + w
}, SIMPLIFY = FALSE))
w_hide <- w_hide[w_hide <= length(frames)]
visibles[w_hide] <- FALSE
hide_from <- which(funs %in% names(invisible_frames))
for (start in hide_from) {
hide_this <- invisible_frames[[ funs[start] ]]
for (i in seq_along(hide_this)) {
if (start + i > length(funs)) break
if (funs[start + i] != hide_this[i]) break
visibles[start + i] <- FALSE
}
}
visibles
}
invisible_frames <- list(
"base::source" = c("base::withVisible", "base::eval", "base::eval"),
"base::stop" = "base::.handleSimpleError",
"cli::cli_abort" = c(
"rlang::abort",
"rlang:::signal_abort",
"base::signalCondition"),
"rlang::abort" = c("rlang:::signal_abort", "base::signalCondition")
)
call_name <- function(x) {
if (is.call(x)) {
if (is.symbol(x[[1]])) {
as.character(x[[1]])
} else if (x[[1]][[1]] == quote(`::`) || x[[1]][[1]] == quote(`:::`)) {
as.character(x[[1]][[2]])
} else {
NULL
}
} else {
NULL
}
}
get_call_scope <- function(call, ns) {
if (is.na(ns)) return("global")
if (!is.call(call)) return("")
if (is.call(call[[1]]) &&
(call[[1]][[1]] == quote(`::`) || call[[1]][[1]] == quote(`:::`))) return("")
if (ns == "base") return("::")
if (! ns %in% loadedNamespaces()) return("")
name <- call_name(call)
if (! ns %in% loadedNamespaces()) return("::")
nsenv <- asNamespace(ns)$.__NAMESPACE__.
if (is.null(nsenv)) return("::")
if (is.null(nsenv$exports)) return(":::")
if (exists(name, envir = nsenv$exports, inherits = FALSE)) {
"::"
} else if (exists(name, envir = asNamespace(ns), inherits = FALSE)) {
":::"
} else {
"local"
}
}
topenvx <- function(x) {
topenv(x, matchThisEnv = err_env)
}
new_trace <- function (calls, parents, visibles, namespaces, scopes, srcrefs, procsrcrefs, pids) {
trace <- data.frame(
stringsAsFactors = FALSE,
parent = parents,
visible = visibles,
namespace = namespaces,
scope = scopes,
srcref = srcrefs,
procsrcref = procsrcrefs,
pid = pids
)
trace[["call"]] <- calls
class(trace) <- c("rlib_trace_3_0", "rlib_trace", "tbl", "data.frame")
trace
}
env_label <- function(env) {
nm <- env_name(env)
if (nzchar(nm)) {
nm
} else {
env_address(env)
}
}
env_address <- function(env) {
class(env) <- "environment"
sub("^.*(0x[0-9a-f]+)>$", "\\1", format(env), perl = TRUE)
}
env_name <- function(env) {
if (identical(env, err_env)) {
return(env_name(package_env))
}
if (identical(env, globalenv())) {
return(NA_character_)
}
if (identical(env, baseenv())) {
return("base")
}
if (identical(env, emptyenv())) {
return("empty")
}
nm <- environmentName(env)
if (isNamespace(env)) {
return(nm)
}
nm
}
# -- S3 methods -------------------------------------------------------
format_error <- function(x, trace = FALSE, class = FALSE,
advice = !trace, full = trace, header = TRUE,
...) {
if (has_cli()) {
format_error_cli(x, trace, class, advice, full, header, ...)
} else {
format_error_plain(x, trace, class, advice, full, header, ...)
}
}
print_error <- function(x, trace = TRUE, class = TRUE,
advice = !trace, ...) {
writeLines(format_error(x, trace, class, advice, ...))
}
format_trace <- function(x, ...) {
if (has_cli()) {
format_trace_cli(x, ...)
} else {
format_trace_plain(x, ...)
}
}
print_trace <- function(x, ...) {
writeLines(format_trace(x, ...))
}
cnd_message <- function(cond) {
paste(cnd_message_(cond, full = FALSE), collapse = "\n")
}
cnd_message_ <- function(cond, full = FALSE) {
if (has_cli()) {
cnd_message_cli(cond, full)
} else {
cnd_message_plain(cond, full)
}
}
# -- format API -------------------------------------------------------
format_advice <- function(x) {
if (has_cli()) {
format_advice_cli(x)
} else {
format_advice_plain(x)
}
}
format_call <- function(call) {
if (has_cli()) {
format_call_cli(call)
} else {
format_call_plain(call)
}
}
format_class <- function(x) {
if (has_cli()) {
format_class_cli(x)
} else {
format_class_plain(x)
}
}
format_error_heading <- function(x, prefix = NULL) {
if (has_cli()) {
format_error_heading_cli(x, prefix)
} else {
format_error_heading_plain(x, prefix)
}
}
format_header_line <- function(x, prefix = NULL) {
if (has_cli()) {
format_header_line_cli(x, prefix)
} else {
format_header_line_plain(x, prefix)
}
}
format_srcref <- function(call, srcref = NULL) {
if (has_cli()) {
format_srcref_cli(call, srcref)
} else {
format_srcref_plain(call, srcref)
}
}
# -- condition message with cli ---------------------------------------
cnd_message_robust <- function(cond) {
class(cond) <- setdiff(class(cond), "rlib_error_3_0")
conditionMessage(cond) %||%
(if (inherits(cond, "interrupt")) "interrupt") %||%
""
}
cnd_message_cli <- function(cond, full = FALSE) {
exp <- paste0(cli::col_yellow("!"), " ")
add_exp <- is.null(names(cond$message))
msg <- cnd_message_robust(cond)
c(
paste0(if (add_exp) exp, msg),
if (inherits(cond$parent, "condition")) {
msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
format(cond$parent,
trace = FALSE,
full = TRUE,
class = FALSE,
header = FALSE,
advice = FALSE
)
} else if (inherits(cond$parent, "interrupt")) {
"interrupt"
} else {
conditionMessage(cond$parent)
}
add_exp <- substr(cli::ansi_strip(msg[1]), 1, 1) != "!"
if (add_exp) msg[1] <- paste0(exp, msg[1])
c(format_header_line_cli(cond$parent, prefix = "Caused by error"),
msg
)
}
)
}
# -- condition message w/o cli ----------------------------------------
cnd_message_plain <- function(cond, full = FALSE) {
exp <- "! "
add_exp <- is.null(names(cond$message))
c(
paste0(if (add_exp) exp, cnd_message_robust(cond)),
if (inherits(cond$parent, "condition")) {
msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
format(cond$parent,
trace = FALSE,
full = TRUE,
class = FALSE,
header = FALSE,
advice = FALSE
)
} else if (inherits(cond$parent, "interrupt")) {
"interrupt"
} else {
conditionMessage(cond$parent)
}
add_exp <- substr(msg[1], 1, 1) != "!"
if (add_exp) {
msg[1] <- paste0(exp, msg[1])
}
c(format_header_line_plain(cond$parent, prefix = "Caused by error"),
msg
)
}
)
}
# -- printing error with cli ------------------------------------------
# Error parts:
# - "Error:" or "Error in " prefix, the latter if the error has a call
# - the call, possibly syntax highlightedm possibly trimmed (?)
# - source ref, with link to the file, potentially in a new line in cli
# - error message, just `conditionMessage()`
# - advice about .Last.error and/or .Last.error.trace
format_error_cli <- function(x, trace = TRUE, class = TRUE,
advice = !trace, full = trace,
header = TRUE, ...) {
p_class <- if (class) format_class_cli(x)
p_header <- if (header) format_header_line_cli(x)
p_msg <- cnd_message_cli(x, full)
p_advice <- if (advice) format_advice_cli(x) else NULL
p_trace <- if (trace && !is.null(x$trace)) {
c("---", "Backtrace:", format_trace_cli(x$trace))
}
c(p_class,
p_header,
p_msg,
p_advice,
p_trace)
}
format_header_line_cli <- function(x, prefix = NULL) {
p_error <- format_error_heading_cli(x, prefix)
p_call <- format_call_cli(x[["call"]])
p_srcref <- format_srcref_cli(conditionCall(x), x$procsrcref %||% x$srcref)
paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
}
format_class_cli <- function(x) {
cls <- unique(setdiff(class(x), "condition"))
cls # silence codetools
cli::format_inline("{.cls {cls}}")
}
format_error_heading_cli <- function(x, prefix = NULL) {
str_error <- if (is.null(prefix)) {
cli::style_bold(cli::col_yellow("Error"))
} else {
cli::style_bold(paste0(prefix))
}
if (is.null(conditionCall(x))) {
paste0(str_error, ": ")
} else {
paste0(str_error, " in ")
}
}
format_call_cli <- function(call) {
if (is.null(call)) {
NULL
} else {
cl <- trimws(format(call))
if (length(cl) > 1) cl <- paste0(cl[1], " ", cli::symbol$ellipsis)
cli::format_inline("{.code {cl}}")
}
}
format_srcref_cli <- function(call, srcref = NULL) {
ref <- get_srcref(call, srcref)
if (is.null(ref)) return("")
link <- if (ref$file != "") {
if (Sys.getenv("R_CLI_HYPERLINK_STYLE") == "iterm") {
cli::style_hyperlink(
cli::format_inline("{basename(ref$file)}:{ref$line}:{ref$col}"),
paste0("file://", ref$file, "#", ref$line, ":", ref$col)
)
} else {
cli::style_hyperlink(
cli::format_inline("{basename(ref$file)}:{ref$line}:{ref$col}"),
paste0("file://", ref$file),
params = c(line = ref$line, col = ref$col)
)
}
} else {
paste0("line ", ref$line)
}
cli::col_silver(paste0(" at ", link))
}
str_advice <- "Type .Last.error to see the more details."
format_advice_cli <- function(x) {
cli::col_silver(str_advice)
}
format_trace_cli <- function(x, ...) {
x$num <- seq_len(nrow(x))
scope <- ifelse(
is.na(x$namespace),
ifelse(x$scope != "", paste0(x$scope, " "), ""),
paste0(x$namespace, x$scope)
)
visible <- if ("visible" %in% names(x)) {
x$visible
} else {
rep(TRUE, nrow(x))
}
srcref <- if ("srcref" %in% names(x) || "procsrcref" %in% names(x)) {
vapply(
seq_len(nrow(x)),
function(i) format_srcref_cli(x[["call"]][[i]], x$procsrcref[[i]] %||% x$srcref[[i]]),
character(1)
)
} else {
unname(vapply(x[["call"]], format_srcref_cli, character(1)))
}
lines <- paste0(
cli::col_silver(format(x$num), ". "),
ifelse (visible, "", "| "),
scope,
vapply(seq_along(x$call), function(i) {
format_trace_call_cli(x$call[[i]], x$namespace[[i]])
}, character(1)),
srcref
)
lines[!visible] <- cli::col_silver(cli::ansi_strip(
lines[!visible],
link = FALSE
))
lines
}
format_trace_call_cli <- function(call, ns = "") {
envir <- tryCatch({
if (!ns %in% loadedNamespaces()) stop("no")
asNamespace(ns)
}, error = function(e) .GlobalEnv)
cl <- trimws(format(call))
if (length(cl) > 1) { cl <- paste0(cl[1], " ", cli::symbol$ellipsis) }
# Older cli does not have 'envir'.
if ("envir" %in% names(formals(cli::code_highlight))) {
fmc <- cli::code_highlight(cl, envir = envir)[1]
} else {
fmc <- cli::code_highlight(cl)[1]
}
cli::ansi_strtrim(fmc, cli::console_width() - 5)
}
# ----------------------------------------------------------------------
format_error_plain <- function(x, trace = TRUE, class = TRUE,
advice = !trace, full = trace, header = TRUE,
...) {
p_class <- if (class) format_class_plain(x)
p_header <- if (header) format_header_line_plain(x)
p_msg <- cnd_message_plain(x, full)
p_advice <- if (advice) format_advice_plain(x) else NULL
p_trace <- if (trace && !is.null(x$trace)) {
c("---", "Backtrace:", format_trace_plain(x$trace))
}
c(p_class,
p_header,
p_msg,
p_advice,
p_trace)
}
format_trace_plain <- function(x, ...) {
x$num <- seq_len(nrow(x))
scope <- ifelse(
is.na(x$namespace),
ifelse(x$scope != "", paste0(x$scope, " "), ""),
paste0(x$namespace, x$scope)
)
visible <- if ("visible" %in% names(x)) {
x$visible
} else {
rep(TRUE, nrow(x))
}
srcref <- if ("srcref" %in% names(x) || "procsrfref" %in% names(x)) {
vapply(
seq_len(nrow(x)),
function(i) format_srcref_plain(x[["call"]][[i]], x$procsrcref[[i]] %||% x$srcref[[i]]),
character(1)
)
} else {
unname(vapply(x[["call"]], format_srcref_plain, character(1)))
}
lines <- paste0(
paste0(format(x$num), ". "),
ifelse (visible, "", "| "),
scope,
vapply(x[["call"]], format_trace_call_plain, character(1)),
srcref
)
lines
}
format_advice_plain <- function(x, ...) {
str_advice
}
format_header_line_plain <- function(x, prefix = NULL) {
p_error <- format_error_heading_plain(x, prefix)
p_call <- format_call_plain(x[["call"]])
p_srcref <- format_srcref_plain(conditionCall(x), x$procsrcref %||% x$srcref)
paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
}
format_error_heading_plain <- function(x, prefix = NULL) {
str_error <- if (is.null(prefix)) "Error" else prefix
if (is.null(conditionCall(x))) {
paste0(str_error, ": ")
} else {
paste0(str_error, " in ")
}
}
format_class_plain <- function(x) {
cls <- unique(setdiff(class(x), "condition"))
paste0("<", paste(cls, collapse = "/"), ">")
}
format_call_plain <- function(call) {
if (is.null(call)) {
NULL
} else {
cl <- trimws(format(call))
if (length(cl) > 1) cl <- paste0(cl[1], " ...")
paste0("`", cl, "`")
}
}
format_srcref_plain <- function(call, srcref = NULL) {
ref <- get_srcref(call, srcref)
if (is.null(ref)) return("")
link <- if (ref$file != "") {
paste0(basename(ref$file), ":", ref$line, ":", ref$col)
} else {
paste0("line ", ref$line)
}
paste0(" at ", link)
}
format_trace_call_plain <- function(call) {
fmc <- trimws(format(call)[1])
if (length(fmc) > 1) { fmc <- paste0(fmc[1], " ...") }
strtrim(fmc, getOption("width") - 5)
}
# -- utilities ---------------------------------------------------------
cli_version <- function() {
# this loads cli!
package_version(asNamespace("cli")[[".__NAMESPACE__."]]$spec[["version"]])
}
has_cli <- function() {
"cli" %in% loadedNamespaces() && cli_version() >= "3.3.0"
}
`%||%` <- function(l, r) if (is.null(l)) r else l
bytes <- function(x) {
nchar(x, type = "bytes")
}
process_call <- function(cond) {
cond[c("call", "srcref", "procsrcref")] <- list(
call = if (is.null(cond[["call"]])) {
NULL
} else if (is.character(cond[["call"]])) {
cond[["call"]]
} else {
deparse(cond[["call"]], nlines = 2)
},
srcref = NULL,
procsrcref = get_srcref(cond[["call"]], cond$procsrcref %||% cond$srcref)
)
cond
}
get_srcref <- function(call, srcref = NULL) {
ref <- srcref %||% utils::getSrcref(call)
if (is.null(ref)) return(NULL)
if (inherits(ref, "processed_srcref")) return(ref)
file <- utils::getSrcFilename(ref, full.names = TRUE)[1]
if (is.na(file)) file <- ""
line <- utils::getSrcLocation(ref) %||% ""
col <- utils::getSrcLocation(ref, which = "column") %||% ""
structure(
list(file = file, line = line, col = col),
class = "processed_srcref"
)
}
is_interactive <- function() {
opt <- getOption("rlib_interactive")
if (isTRUE(opt)) {
TRUE
} else if (identical(opt, FALSE)) {
FALSE
} else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
FALSE
} else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") {
FALSE
} else if (identical(Sys.getenv("TESTTHAT"), "true")) {
FALSE
} else {
interactive()
}
}
no_sink <- function() {
sink.number() == 0 && sink.number("message") == 2
}
rstudio_stdout <- function() {
rstudio <- rstudio_detect()
rstudio$type %in% c(
"rstudio_console",
"rstudio_console_starting",
"rstudio_build_pane",
"rstudio_job",
"rstudio_render_pane"
)
}
default_output <- function() {
if ((is_interactive() || rstudio_stdout()) && no_sink()) {
stdout()
} else {
stderr()
}
}
onload_hook <- function() {
reg_env <- Sys.getenv("R_LIB_ERROR_REGISTER_PRINT_METHODS", "TRUE")
if (tolower(reg_env) != "false") {
registerS3method("format", "rlib_error_3_0", format_error, baseenv())
registerS3method("format", "rlib_trace_3_0", format_trace, baseenv())
registerS3method("print", "rlib_error_3_0", print_error, baseenv())
registerS3method("print", "rlib_trace_3_0", print_trace, baseenv())
registerS3method("conditionMessage", "rlib_error_3_0", cnd_message, baseenv())
}
}
native_name <- function(x) {
if (inherits(x, "NativeSymbolInfo")) {
x$name
} else {
format(x)
}
}
# There is no format() for 'name' in R 3.6.x and before
format_name <- function(x) {
if (is.name(x)) {
as.character(x)
} else {
format(x)
}
}
frame_call <- function(frame) {
out <- NULL
delayedAssign("out", base::sys.call(), frame)
out
}
# Useful for snapshots so that they print without an unstable backtrace.
# Call `register_testthat_print()` before running tests.
testthat_print_error <- function(x, ...) {
x[["trace"]] <- NULL
x[["srcref"]] <- NULL
x[["procsrcref"]] <- NULL
attr(x[["call"]], "srcref") <- NULL
print(x)
}
registered <- FALSE
register_testthat_print <- function() {
if (!registered) {
registerS3method(
"testthat_print",
"rlib_error",
testthat_print_error,
asNamespace("testthat")
)
registered <<- TRUE
}
}
# -- public API --------------------------------------------------------
err_env <- environment()
parent.env(err_env) <- baseenv()
structure(
list(
.internal = err_env,
new_cond = new_cond,
new_error = new_error,
throw = throw,
throw_error = throw_error,
chain_error = chain_error,
chain_call = chain_call,
chain_clean_call = chain_clean_call,
add_trace_back = add_trace_back,
process_call = process_call,
onload_hook = onload_hook,
is_interactive = is_interactive,
register_testthat_print = register_testthat_print,
format = list(
advice = format_advice,
call = format_call,
class = format_class,
error = format_error,
error_heading = format_error_heading,
header_line = format_header_line,
srcref = format_srcref,
trace = format_trace
)
),
class = c("standalone_errors", "standalone"))
})
# These are optional, and feel free to remove them if you prefer to
# call them through the `err` object.
new_cond <- err$new_cond
new_error <- err$new_error
throw <- err$throw
throw_error <- err$throw_error
chain_error <- err$chain_error
chain_call <- err$chain_call
chain_clean_call <- err$chain_clean_call
Try the callr package in your browser
Any scripts or data that you put into this service are public.
callr documentation built on June 22, 2024, 6:48 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# ---
# repo: r-lib/processx
# file: standalone-errors.R
# last-updated: 2023-01-15
# license: https://unlicense.org
# ---
#
# Standalone file for better error handling. If you can allow package
# dependencies, then you are probably better off using rlang's
# functions for errors.
#
# ## Soft-dependency
#
# - aaa-standalone-rstudio-detect.R in r-lib/cli
#
# ## Features
#
# - Throw conditions and errors with the same API.
# - Automatically captures the right calls and adds them to the conditions.
# - Sets `.Last.error`, so you can easily inspect the errors, even if they
# were not caught.
# - It only sets `.Last.error` for the errors that are not caught.
# - Hierarchical errors, to allow higher level error messages, that are
# more meaningful for the users, while also keeping the lower level
# details in the error object. (So in `.Last.error` as well.)
# - `.Last.error` always includes a stack trace. (The stack trace is
# common for the whole error hierarchy.) The trace is accessible within
# the error, e.g. `.Last.error$trace`. The trace of the last error is
# also at `.Last.error.trace`.
# - Can merge errors and traces across multiple processes.
# - Pretty-print errors and traces, if the cli package is loaded.
# - Automatically hides uninformative parts of the stack trace when
# printing.
#
# ## API
#
# ```
# new_cond(..., call. = TRUE, srcref = NULL, domain = NA)
# new_error(..., call. = TRUE, srcref = NULL, domain = NA)
# throw(cond, parent = NULL, frame = environment())
# throw_error(cond, parent = NULL, frame = environment())
# chain_error(expr, err, call = sys.call(-1))
# chain_call(.NAME, ...)
# chain_clean_call(.NAME, ...)
# onload_hook()
# add_trace_back(cond, frame = NULL)
# format$advice(x)
# format$call(call)
# format$class(x)
# format$error(x, trace = FALSE, class = FALSE, advice = !trace, ...)
# format$error_heading(x, prefix = NULL)
# format$header_line(x, prefix = NULL)
# format$srcref(call, srcref = NULL)
# format$trace(x, ...)
# ```
#
# ## Roadmap:
# - better printing of anonymous function in the trace
#
# ## Changelog
#
# ### 1.0.0 -- 2019-06-18
#
# * First release.
#
# ### 1.0.1 -- 2019-06-20
#
# * Add `rlib_error_always_trace` option to always add a trace
#
# ### 1.0.2 -- 2019-06-27
#
# * Internal change: change topenv of the functions to baseenv()
#
# ### 1.1.0 -- 2019-10-26
#
# * Register print methods via onload_hook() function, call from .onLoad()
# * Print the error manually, and the trace in non-interactive sessions
#
# ### 1.1.1 -- 2019-11-10
#
# * Only use `trace` in parent errors if they are `rlib_error`s.
# Because e.g. `rlang_error`s also have a trace, with a slightly
# different format.
#
# ### 1.2.0 -- 2019-11-13
#
# * Fix the trace if a non-thrown error is re-thrown.
# * Provide print_this() and print_parents() to make it easier to define
# custom print methods.
# * Fix annotating our throw() methods with the incorrect `base::`.
#
# ### 1.2.1 -- 2020-01-30
#
# * Update wording of error printout to be less intimidating, avoid jargon
# * Use default printing in interactive mode, so RStudio can detect the
# error and highlight it.
# * Add the rethrow_call_with_cleanup function, to work with embedded
# cleancall.
#
# ### 1.2.2 -- 2020-11-19
#
# * Add the `call` argument to `catch_rethrow()` and `rethrow()`, to be
# able to omit calls.
#
# ### 1.2.3 -- 2021-03-06
#
# * Use cli instead of crayon
#
# ### 1.2.4 -- 2021-04-01
#
# * Allow omitting the call with call. = FALSE in `new_cond()`, etc.
#
# ### 1.3.0 -- 2021-04-19
#
# * Avoid embedding calls in trace with embed = FALSE.
#
# ### 2.0.0 -- 2021-04-19
#
# * Versioned classes and print methods
#
# ### 2.0.1 -- 2021-06-29
#
# * Do not convert error messages to native encoding before printing,
# to be able to print UTF-8 error messages on Windows.
#
# ### 2.0.2 -- 2021-09-07
#
# * Do not translate error messages, as this converts them to the native
# encoding. We keep messages in UTF-8 now.
#
# ### 3.0.0 -- 2022-04-19
#
# * Major rewrite, use rlang compatible error objects. New API.
#
# ### 3.0.1 -- 2022-06-17
#
# * Remove the `rlang_error` and `rlang_trace` classes, because our new
# deparsed `call` column in the trace is not compatible with rlang.
#
# ### 3.0.2 -- 2022-08-01
#
# * Use a `procsrcref` column for processed source references.
# Otherwise testthat (and probably other rlang based packages), will
# pick up the `srcref` column, and they expect an `srcref` object there.
#
# ### 3.1.0 -- 2022-10-04
#
# * Add ANSI hyperlinks to stack traces, if we have a recent enough
# cli package that supports this.
#
# ### 3.1.1 -- 2022-11-17
#
# * Use `[[` instead of `$` to fix some partial matches.
# * Use fully qualified `base::stop()` to enable overriding `stop()`
# in a package. (Makes sense if compat files use `stop()`.
# * The `is_interactive()` function is now exported.
#
# ### 3.1.2 -- 2022-11-18
#
# * The `parent` condition can now be an interrupt.
#
# ### 3.1.3 -- 2023-01-15
#
# * Now we do not load packages when walking the trace.
#
# ### 3.1.4 -- 2023-04-13
#
# * `call.` can now be a frame environment as in `rlang::abort()`
err <- local({
# -- dependencies -----------------------------------------------------
rstudio_detect <- rstudio$detect
# -- condition constructors -------------------------------------------
#' Create a new condition
#'
#' @noRd
#' @param ... Parts of the error message, they will be converted to
#' character and then concatenated, like in [stop()].
#' @param call. A call object to include in the condition, or `TRUE`
#' or `NULL`, meaning that [throw()] should add a call object
#' automatically. If `FALSE`, then no call is added.
#' @param srcref Alternative source reference object to use instead of
#' the one of `call.`.
#' @param domain Translation domain, see [stop()]. We set this to
#' `NA` by default, which means that no translation occurs. This
#' has the benefit that the error message is not re-encoded into
#' the native locale.
#' @return Condition object. Currently a list, but you should not rely
#' on that.
new_cond <- function(..., call. = TRUE, srcref = NULL, domain = NA) {
message <- .makeMessage(..., domain = domain)
structure(
list(message = message, call = call., srcref = srcref),
class = c("condition"))
}
#' Create a new error condition
#'
#' It also adds the `rlib_error` class.
#'
#' @noRd
#' @param ... Passed to [new_cond()].
#' @param call. Passed to [new_cond()].
#' @param srcref Passed tp [new_cond()].
#' @param domain Passed to [new_cond()].
#' @return Error condition object with classes `rlib_error`, `error`
#' and `condition`.
new_error <- function(..., call. = TRUE, srcref = NULL, domain = NA) {
cond <- new_cond(..., call. = call., domain = domain, srcref = srcref)
class(cond) <- c("rlib_error_3_0", "rlib_error", "error", "condition")
cond
}
# -- throwing conditions ----------------------------------------------
#' Throw a condition
#'
#' If the condition is an error, it will also call [stop()], after
#' signalling the condition first. This means that if the condition is
#' caught by an exiting handler, then [stop()] is not called.
#'
#' @noRd
#' @param cond Condition object to throw. If it is an error condition,
#' then it calls [stop()].
#' @param parent Parent condition.
#' @param frame The throwing context. Can be used to hide frames from
#' the backtrace.
throw <- throw_error <- function(cond,
parent = NULL,
call = parent.frame(),
frame = environment()) {
if (!inherits(cond, "condition")) {
cond <- new_error(cond)
}
if (!is.null(parent) && !inherits(parent, "condition")) {
throw(new_error("Parent condition must be a condition object"))
}
if (isTRUE(cond[["call"]])) {
cond[["call"]] <- frame_call(call)
} else if (identical(cond[["call"]], FALSE)) {
cond[["call"]] <- NULL
} else if (is.environment(cond[["call"]])) {
cond[["call"]] <- frame_call(cond[["call"]])
}
cond <- process_call(cond)
if (!is.null(parent)) {
cond$parent <- process_call(parent)
}
# We can set an option to always add the trace to the thrown
# conditions. This is useful for example in context that always catch
# errors, e.g. in testthat tests or knitr. This options is usually not
# set and we signal the condition here
always_trace <- isTRUE(getOption("rlib_error_always_trace"))
.hide_from_trace <- 1L
# .error_frame <- cond
if (!always_trace) signalCondition(cond)
if (is.null(cond$`_pid`)) cond$`_pid` <- Sys.getpid()
if (is.null(cond$`_timestamp`)) cond$`_timestamp` <- Sys.time()
# If we get here that means that the condition was not caught by
# an exiting handler. That means that we need to create a trace.
# If there is a hand-constructed trace already in the error object,
# then we'll just leave it there.
if (is.null(cond$trace)) cond <- add_trace_back(cond, frame = frame)
# Set up environment to store .Last.error, it will be just before
# baseenv(), so it is almost as if it was in baseenv() itself, like
# .Last.value. We save the print methods here as well, and then they
# will be found automatically.
if (! "org:r-lib" %in% search()) {
do.call("attach", list(new.env(), pos = length(search()),
name = "org:r-lib"))
}
env <- as.environment("org:r-lib")
env$.Last.error <- cond
env$.Last.error.trace <- cond$trace
# If we always wanted a trace, then we signal the condition here
if (always_trace) signalCondition(cond)
# If this is not an error, then we'll just return here. This allows
# throwing interrupt conditions for example, with the same UI.
if (! inherits(cond, "error")) return(invisible())
.hide_from_trace <- NULL
# Top-level handler, this is intended for testing only for now,
# and its design might change.
if (!is.null(th <- getOption("rlib_error_handler")) &&
is.function(th)) {
return(th(cond))
}
# In non-interactive mode, we print the error + the traceback
# manually, to make sure that it won't be truncated by R's error
# message length limit.
out <- format(
cond,
trace = !is_interactive(),
class = FALSE,
full = !is_interactive()
)
writeLines(out, con = default_output())
# Dropping the classes and adding "duplicate_condition" is a workaround
# for the case when we have non-exiting handlers on throw()-n
# conditions. These would get the condition twice, because stop()
# will also signal it. If we drop the classes, then only handlers
# on "condition" objects (i.e. all conditions) get duplicate signals.
# This is probably quite rare, but for this rare case they can also
# recognize the duplicates from the "duplicate_condition" extra class.
class(cond) <- c("duplicate_condition", "condition")
# Turn off the regular error printing to avoid printing
# the error twice.
opts <- options(show.error.messages = FALSE)
on.exit(options(opts), add = TRUE)
base::stop(cond)
}
# -- rethrow with parent -----------------------------------------------
#' Re-throw an error with a better error message
#'
#' Evaluate `expr` and if it errors, then throw a new error `err`,
#' with the original error set as its parent.
#'
#' @noRd
#' @param expr Expression to evaluate.
#' @param err Error object or message to use for the child error.
#' @param call Call to use in the re-thrown error. See [throw()].
chain_error <- function(expr, err, call = sys.call(-1), srcref = NULL) {
.hide_from_trace <- 1
force(call)
srcref <- srcref %||% utils::getSrcref(sys.call())
withCallingHandlers({
expr
}, error = function(e) {
.hide_from_trace <- 0:1
e$srcref <- srcref
e$procsrcref <- NULL
if (!inherits(err, "condition")) {
err <- new_error(err, call. = call)
}
throw_error(err, parent = e)
})
}
# -- rethrowing conditions from C code ---------------------------------
#' Version of .Call that throw()s errors
#'
#' It re-throws error from compiled code. If the error had class
#' `simpleError`, like all errors, thrown via `error()` in C do, it also
#' adds the `c_error` class.
#'
#' @noRd
#' @param .NAME Compiled function to call, see [.Call()].
#' @param ... Function arguments, see [.Call()].
#' @return Result of the call.
chain_call <- function(.NAME, ...) {
.hide_from_trace <- 1:3 # withCallingHandlers + do.call + .handleSimpleError (?)
call <- sys.call()
call1 <- sys.call(-1)
srcref <- utils::getSrcref(call)
withCallingHandlers(
do.call(".Call", list(.NAME, ...)),
error = function(e) {
.hide_from_trace <- 0:1
e$srcref <- srcref
e$procsrcref <- NULL
e[["call"]] <- call
name <- native_name(.NAME)
err <- new_error("Native call to `", name, "` failed", call. = call1)
cerror <- if (inherits(e, "simpleError")) "c_error"
class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
throw_error(err, parent = e)
}
)
}
package_env <- topenv()
#' Version of entrace_call that supports cleancall
#'
#' This function is the same as [entrace_call()], except that it
#' uses cleancall's [.Call()] wrapper, to enable resource cleanup.
#' See https://github.com/r-lib/cleancall#readme for more about
#' resource cleanup.
#'
#' @noRd
#' @param .NAME Compiled function to call, see [.Call()].
#' @param ... Function arguments, see [.Call()].
#' @return Result of the call.
chain_clean_call <- function(.NAME, ...) {
.hide_from_trace <- 1:3
call <- sys.call()
call1 <- sys.call(-1)
srcref <- utils::getSrcref(call)
withCallingHandlers(
package_env$call_with_cleanup(.NAME, ...),
error = function(e) {
.hide_from_trace <- 0:1
e$srcref <- srcref
e$procsrcref <- NULL
e[["call"]] <- call
name <- native_name(.NAME)
err <- new_error("Native call to `", name, "` failed", call. = call1)
cerror <- if (inherits(e, "simpleError")) "c_error"
class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
throw_error(err, parent = e)
}
)
}
# -- create traceback -------------------------------------------------
#' Create a traceback
#'
#' [throw()] calls this function automatically if an error is not caught,
#' so there is currently not much use to call it directly.
#'
#' @param cond Condition to add the trace to
#' @param frame Use this context to hide some frames from the traceback.
#'
#' @return A condition object, with the trace added.
add_trace_back <- function(cond, frame = NULL) {
idx <- seq_len(sys.parent(1L))
frames <- sys.frames()[idx]
# TODO: remove embedded objects from calls
calls <- as.list(sys.calls()[idx])
parents <- sys.parents()[idx]
namespaces <- unlist(lapply(
seq_along(frames),
function(i) {
if (is_operator(calls[[i]])) {
"o"
} else {
env_label(topenvx(environment(sys.function(i))))
}
}
))
pids <- rep(cond$`_pid` %||% Sys.getpid(), length(calls))
mch <- match(format(frame), sapply(frames, format))
if (is.na(mch)) {
visibles <- TRUE
} else {
visibles <- c(rep(TRUE, mch), rep(FALSE, length(frames) - mch))
}
scopes <- vapply(idx, FUN.VALUE = character(1), function(i) {
tryCatch(
get_call_scope(calls[[i]], namespaces[[i]]),
error = function(e) ""
)
})
namespaces <- ifelse(scopes %in% c("::", ":::"), namespaces, NA_character_)
funs <- ifelse(
is.na(namespaces),
ifelse(scopes != "", paste0(scopes, " "), ""),
paste0(namespaces, scopes)
)
funs <- paste0(
funs,
vapply(calls, function(x) format_name(x[[1]])[1], character(1))
)
visibles <- visibles & mark_invisible_frames(funs, frames)
pcs <- lapply(calls, function(c) process_call(list(call = c)))
calls <- lapply(pcs, "[[", "call")
srcrefs <- I(lapply(pcs, "[[", "srcref"))
procsrcrefs <- I(lapply(pcs, "[[", "procsrcref"))
cond$trace <- new_trace(
calls,
parents,
visibles = visibles,
namespaces = namespaces,
scopes = scopes,
srcrefs = srcrefs,
procsrcrefs = procsrcrefs,
pids
)
cond
}
is_operator <- function(cl) {
is.call(cl) && length(cl) >= 1 && is.symbol(cl[[1]]) &&
grepl("^[^.a-zA-Z]", as.character(cl[[1]]))
}
mark_invisible_frames <- function(funs, frames) {
visibles <- rep(TRUE, length(frames))
hide <- lapply(frames, "[[", ".hide_from_trace")
w_hide <- unlist(mapply(seq_along(hide), hide, FUN = function(i, w) {
i + w
}, SIMPLIFY = FALSE))
w_hide <- w_hide[w_hide <= length(frames)]
visibles[w_hide] <- FALSE
hide_from <- which(funs %in% names(invisible_frames))
for (start in hide_from) {
hide_this <- invisible_frames[[ funs[start] ]]
for (i in seq_along(hide_this)) {
if (start + i > length(funs)) break
if (funs[start + i] != hide_this[i]) break
visibles[start + i] <- FALSE
}
}
visibles
}
invisible_frames <- list(
"base::source" = c("base::withVisible", "base::eval", "base::eval"),
"base::stop" = "base::.handleSimpleError",
"cli::cli_abort" = c(
"rlang::abort",
"rlang:::signal_abort",
"base::signalCondition"),
"rlang::abort" = c("rlang:::signal_abort", "base::signalCondition")
)
call_name <- function(x) {
if (is.call(x)) {
if (is.symbol(x[[1]])) {
as.character(x[[1]])
} else if (x[[1]][[1]] == quote(`::`) || x[[1]][[1]] == quote(`:::`)) {
as.character(x[[1]][[2]])
} else {
NULL
}
} else {
NULL
}
}
get_call_scope <- function(call, ns) {
if (is.na(ns)) return("global")
if (!is.call(call)) return("")
if (is.call(call[[1]]) &&
(call[[1]][[1]] == quote(`::`) || call[[1]][[1]] == quote(`:::`))) return("")
if (ns == "base") return("::")
if (! ns %in% loadedNamespaces()) return("")
name <- call_name(call)
if (! ns %in% loadedNamespaces()) return("::")
nsenv <- asNamespace(ns)$.__NAMESPACE__.
if (is.null(nsenv)) return("::")
if (is.null(nsenv$exports)) return(":::")
if (exists(name, envir = nsenv$exports, inherits = FALSE)) {
"::"
} else if (exists(name, envir = asNamespace(ns), inherits = FALSE)) {
":::"
} else {
"local"
}
}
topenvx <- function(x) {
topenv(x, matchThisEnv = err_env)
}
new_trace <- function (calls, parents, visibles, namespaces, scopes, srcrefs, procsrcrefs, pids) {
trace <- data.frame(
stringsAsFactors = FALSE,
parent = parents,
visible = visibles,
namespace = namespaces,
scope = scopes,
srcref = srcrefs,
procsrcref = procsrcrefs,
pid = pids
)
trace[["call"]] <- calls
class(trace) <- c("rlib_trace_3_0", "rlib_trace", "tbl", "data.frame")
trace
}
env_label <- function(env) {
nm <- env_name(env)
if (nzchar(nm)) {
nm
} else {
env_address(env)
}
}
env_address <- function(env) {
class(env) <- "environment"
sub("^.*(0x[0-9a-f]+)>$", "\\1", format(env), perl = TRUE)
}
env_name <- function(env) {
if (identical(env, err_env)) {
return(env_name(package_env))
}
if (identical(env, globalenv())) {
return(NA_character_)
}
if (identical(env, baseenv())) {
return("base")
}
if (identical(env, emptyenv())) {
return("empty")
}
nm <- environmentName(env)
if (isNamespace(env)) {
return(nm)
}
nm
}
# -- S3 methods -------------------------------------------------------
format_error <- function(x, trace = FALSE, class = FALSE,
advice = !trace, full = trace, header = TRUE,
...) {
if (has_cli()) {
format_error_cli(x, trace, class, advice, full, header, ...)
} else {
format_error_plain(x, trace, class, advice, full, header, ...)
}
}
print_error <- function(x, trace = TRUE, class = TRUE,
advice = !trace, ...) {
writeLines(format_error(x, trace, class, advice, ...))
}
format_trace <- function(x, ...) {
if (has_cli()) {
format_trace_cli(x, ...)
} else {
format_trace_plain(x, ...)
}
}
print_trace <- function(x, ...) {
writeLines(format_trace(x, ...))
}
cnd_message <- function(cond) {
paste(cnd_message_(cond, full = FALSE), collapse = "\n")
}
cnd_message_ <- function(cond, full = FALSE) {
if (has_cli()) {
cnd_message_cli(cond, full)
} else {
cnd_message_plain(cond, full)
}
}
# -- format API -------------------------------------------------------
format_advice <- function(x) {
if (has_cli()) {
format_advice_cli(x)
} else {
format_advice_plain(x)
}
}
format_call <- function(call) {
if (has_cli()) {
format_call_cli(call)
} else {
format_call_plain(call)
}
}
format_class <- function(x) {
if (has_cli()) {
format_class_cli(x)
} else {
format_class_plain(x)
}
}
format_error_heading <- function(x, prefix = NULL) {
if (has_cli()) {
format_error_heading_cli(x, prefix)
} else {
format_error_heading_plain(x, prefix)
}
}
format_header_line <- function(x, prefix = NULL) {
if (has_cli()) {
format_header_line_cli(x, prefix)
} else {
format_header_line_plain(x, prefix)
}
}
format_srcref <- function(call, srcref = NULL) {
if (has_cli()) {
format_srcref_cli(call, srcref)
} else {
format_srcref_plain(call, srcref)
}
}
# -- condition message with cli ---------------------------------------
cnd_message_robust <- function(cond) {
class(cond) <- setdiff(class(cond), "rlib_error_3_0")
conditionMessage(cond) %||%
(if (inherits(cond, "interrupt")) "interrupt") %||%
""
}
cnd_message_cli <- function(cond, full = FALSE) {
exp <- paste0(cli::col_yellow("!"), " ")
add_exp <- is.null(names(cond$message))
msg <- cnd_message_robust(cond)
c(
paste0(if (add_exp) exp, msg),
if (inherits(cond$parent, "condition")) {
msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
format(cond$parent,
trace = FALSE,
full = TRUE,
class = FALSE,
header = FALSE,
advice = FALSE
)
} else if (inherits(cond$parent, "interrupt")) {
"interrupt"
} else {
conditionMessage(cond$parent)
}
add_exp <- substr(cli::ansi_strip(msg[1]), 1, 1) != "!"
if (add_exp) msg[1] <- paste0(exp, msg[1])
c(format_header_line_cli(cond$parent, prefix = "Caused by error"),
msg
)
}
)
}
# -- condition message w/o cli ----------------------------------------
cnd_message_plain <- function(cond, full = FALSE) {
exp <- "! "
add_exp <- is.null(names(cond$message))
c(
paste0(if (add_exp) exp, cnd_message_robust(cond)),
if (inherits(cond$parent, "condition")) {
msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
format(cond$parent,
trace = FALSE,
full = TRUE,
class = FALSE,
header = FALSE,
advice = FALSE
)
} else if (inherits(cond$parent, "interrupt")) {
"interrupt"
} else {
conditionMessage(cond$parent)
}
add_exp <- substr(msg[1], 1, 1) != "!"
if (add_exp) {
msg[1] <- paste0(exp, msg[1])
}
c(format_header_line_plain(cond$parent, prefix = "Caused by error"),
msg
)
}
)
}
# -- printing error with cli ------------------------------------------
# Error parts:
# - "Error:" or "Error in " prefix, the latter if the error has a call
# - the call, possibly syntax highlightedm possibly trimmed (?)
# - source ref, with link to the file, potentially in a new line in cli
# - error message, just `conditionMessage()`
# - advice about .Last.error and/or .Last.error.trace
format_error_cli <- function(x, trace = TRUE, class = TRUE,
advice = !trace, full = trace,
header = TRUE, ...) {
p_class <- if (class) format_class_cli(x)
p_header <- if (header) format_header_line_cli(x)
p_msg <- cnd_message_cli(x, full)
p_advice <- if (advice) format_advice_cli(x) else NULL
p_trace <- if (trace && !is.null(x$trace)) {
c("---", "Backtrace:", format_trace_cli(x$trace))
}
c(p_class,
p_header,
p_msg,
p_advice,
p_trace)
}
format_header_line_cli <- function(x, prefix = NULL) {
p_error <- format_error_heading_cli(x, prefix)
p_call <- format_call_cli(x[["call"]])
p_srcref <- format_srcref_cli(conditionCall(x), x$procsrcref %||% x$srcref)
paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
}
format_class_cli <- function(x) {
cls <- unique(setdiff(class(x), "condition"))
cls # silence codetools
cli::format_inline("{.cls {cls}}")
}
format_error_heading_cli <- function(x, prefix = NULL) {
str_error <- if (is.null(prefix)) {
cli::style_bold(cli::col_yellow("Error"))
} else {
cli::style_bold(paste0(prefix))
}
if (is.null(conditionCall(x))) {
paste0(str_error, ": ")
} else {
paste0(str_error, " in ")
}
}
format_call_cli <- function(call) {
if (is.null(call)) {
NULL
} else {
cl <- trimws(format(call))
if (length(cl) > 1) cl <- paste0(cl[1], " ", cli::symbol$ellipsis)
cli::format_inline("{.code {cl}}")
}
}
format_srcref_cli <- function(call, srcref = NULL) {
ref <- get_srcref(call, srcref)
if (is.null(ref)) return("")
link <- if (ref$file != "") {
if (Sys.getenv("R_CLI_HYPERLINK_STYLE") == "iterm") {
cli::style_hyperlink(
cli::format_inline("{basename(ref$file)}:{ref$line}:{ref$col}"),
paste0("file://", ref$file, "#", ref$line, ":", ref$col)
)
} else {
cli::style_hyperlink(
cli::format_inline("{basename(ref$file)}:{ref$line}:{ref$col}"),
paste0("file://", ref$file),
params = c(line = ref$line, col = ref$col)
)
}
} else {
paste0("line ", ref$line)
}
cli::col_silver(paste0(" at ", link))
}
str_advice <- "Type .Last.error to see the more details."
format_advice_cli <- function(x) {
cli::col_silver(str_advice)
}
format_trace_cli <- function(x, ...) {
x$num <- seq_len(nrow(x))
scope <- ifelse(
is.na(x$namespace),
ifelse(x$scope != "", paste0(x$scope, " "), ""),
paste0(x$namespace, x$scope)
)
visible <- if ("visible" %in% names(x)) {
x$visible
} else {
rep(TRUE, nrow(x))
}
srcref <- if ("srcref" %in% names(x) || "procsrcref" %in% names(x)) {
vapply(
seq_len(nrow(x)),
function(i) format_srcref_cli(x[["call"]][[i]], x$procsrcref[[i]] %||% x$srcref[[i]]),
character(1)
)
} else {
unname(vapply(x[["call"]], format_srcref_cli, character(1)))
}
lines <- paste0(
cli::col_silver(format(x$num), ". "),
ifelse (visible, "", "| "),
scope,
vapply(seq_along(x$call), function(i) {
format_trace_call_cli(x$call[[i]], x$namespace[[i]])
}, character(1)),
srcref
)
lines[!visible] <- cli::col_silver(cli::ansi_strip(
lines[!visible],
link = FALSE
))
lines
}
format_trace_call_cli <- function(call, ns = "") {
envir <- tryCatch({
if (!ns %in% loadedNamespaces()) stop("no")
asNamespace(ns)
}, error = function(e) .GlobalEnv)
cl <- trimws(format(call))
if (length(cl) > 1) { cl <- paste0(cl[1], " ", cli::symbol$ellipsis) }
# Older cli does not have 'envir'.
if ("envir" %in% names(formals(cli::code_highlight))) {
fmc <- cli::code_highlight(cl, envir = envir)[1]
} else {
fmc <- cli::code_highlight(cl)[1]
}
cli::ansi_strtrim(fmc, cli::console_width() - 5)
}
# ----------------------------------------------------------------------
format_error_plain <- function(x, trace = TRUE, class = TRUE,
advice = !trace, full = trace, header = TRUE,
...) {
p_class <- if (class) format_class_plain(x)
p_header <- if (header) format_header_line_plain(x)
p_msg <- cnd_message_plain(x, full)
p_advice <- if (advice) format_advice_plain(x) else NULL
p_trace <- if (trace && !is.null(x$trace)) {
c("---", "Backtrace:", format_trace_plain(x$trace))
}
c(p_class,
p_header,
p_msg,
p_advice,
p_trace)
}
format_trace_plain <- function(x, ...) {
x$num <- seq_len(nrow(x))
scope <- ifelse(
is.na(x$namespace),
ifelse(x$scope != "", paste0(x$scope, " "), ""),
paste0(x$namespace, x$scope)
)
visible <- if ("visible" %in% names(x)) {
x$visible
} else {
rep(TRUE, nrow(x))
}
srcref <- if ("srcref" %in% names(x) || "procsrfref" %in% names(x)) {
vapply(
seq_len(nrow(x)),
function(i) format_srcref_plain(x[["call"]][[i]], x$procsrcref[[i]] %||% x$srcref[[i]]),
character(1)
)
} else {
unname(vapply(x[["call"]], format_srcref_plain, character(1)))
}
lines <- paste0(
paste0(format(x$num), ". "),
ifelse (visible, "", "| "),
scope,
vapply(x[["call"]], format_trace_call_plain, character(1)),
srcref
)
lines
}
format_advice_plain <- function(x, ...) {
str_advice
}
format_header_line_plain <- function(x, prefix = NULL) {
p_error <- format_error_heading_plain(x, prefix)
p_call <- format_call_plain(x[["call"]])
p_srcref <- format_srcref_plain(conditionCall(x), x$procsrcref %||% x$srcref)
paste0(p_error, p_call, p_srcref, if (!is.null(conditionCall(x))) ":")
}
format_error_heading_plain <- function(x, prefix = NULL) {
str_error <- if (is.null(prefix)) "Error" else prefix
if (is.null(conditionCall(x))) {
paste0(str_error, ": ")
} else {
paste0(str_error, " in ")
}
}
format_class_plain <- function(x) {
cls <- unique(setdiff(class(x), "condition"))
paste0("<", paste(cls, collapse = "/"), ">")
}
format_call_plain <- function(call) {
if (is.null(call)) {
NULL
} else {
cl <- trimws(format(call))
if (length(cl) > 1) cl <- paste0(cl[1], " ...")
paste0("`", cl, "`")
}
}
format_srcref_plain <- function(call, srcref = NULL) {
ref <- get_srcref(call, srcref)
if (is.null(ref)) return("")
link <- if (ref$file != "") {
paste0(basename(ref$file), ":", ref$line, ":", ref$col)
} else {
paste0("line ", ref$line)
}
paste0(" at ", link)
}
format_trace_call_plain <- function(call) {
fmc <- trimws(format(call)[1])
if (length(fmc) > 1) { fmc <- paste0(fmc[1], " ...") }
strtrim(fmc, getOption("width") - 5)
}
# -- utilities ---------------------------------------------------------
cli_version <- function() {
# this loads cli!
package_version(asNamespace("cli")[[".__NAMESPACE__."]]$spec[["version"]])
}
has_cli <- function() {
"cli" %in% loadedNamespaces() && cli_version() >= "3.3.0"
}
`%||%` <- function(l, r) if (is.null(l)) r else l
bytes <- function(x) {
nchar(x, type = "bytes")
}
process_call <- function(cond) {
cond[c("call", "srcref", "procsrcref")] <- list(
call = if (is.null(cond[["call"]])) {
NULL
} else if (is.character(cond[["call"]])) {
cond[["call"]]
} else {
deparse(cond[["call"]], nlines = 2)
},
srcref = NULL,
procsrcref = get_srcref(cond[["call"]], cond$procsrcref %||% cond$srcref)
)
cond
}
get_srcref <- function(call, srcref = NULL) {
ref <- srcref %||% utils::getSrcref(call)
if (is.null(ref)) return(NULL)
if (inherits(ref, "processed_srcref")) return(ref)
file <- utils::getSrcFilename(ref, full.names = TRUE)[1]
if (is.na(file)) file <- ""
line <- utils::getSrcLocation(ref) %||% ""
col <- utils::getSrcLocation(ref, which = "column") %||% ""
structure(
list(file = file, line = line, col = col),
class = "processed_srcref"
)
}
is_interactive <- function() {
opt <- getOption("rlib_interactive")
if (isTRUE(opt)) {
TRUE
} else if (identical(opt, FALSE)) {
FALSE
} else if (tolower(getOption("knitr.in.progress", "false")) == "true") {
FALSE
} else if (tolower(getOption("rstudio.notebook.executing", "false")) == "true") {
FALSE
} else if (identical(Sys.getenv("TESTTHAT"), "true")) {
FALSE
} else {
interactive()
}
}
no_sink <- function() {
sink.number() == 0 && sink.number("message") == 2
}
rstudio_stdout <- function() {
rstudio <- rstudio_detect()
rstudio$type %in% c(
"rstudio_console",
"rstudio_console_starting",
"rstudio_build_pane",
"rstudio_job",
"rstudio_render_pane"
)
}
default_output <- function() {
if ((is_interactive() || rstudio_stdout()) && no_sink()) {
stdout()
} else {
stderr()
}
}
onload_hook <- function() {
reg_env <- Sys.getenv("R_LIB_ERROR_REGISTER_PRINT_METHODS", "TRUE")
if (tolower(reg_env) != "false") {
registerS3method("format", "rlib_error_3_0", format_error, baseenv())
registerS3method("format", "rlib_trace_3_0", format_trace, baseenv())
registerS3method("print", "rlib_error_3_0", print_error, baseenv())
registerS3method("print", "rlib_trace_3_0", print_trace, baseenv())
registerS3method("conditionMessage", "rlib_error_3_0", cnd_message, baseenv())
}
}
native_name <- function(x) {
if (inherits(x, "NativeSymbolInfo")) {
x$name
} else {
format(x)
}
}
# There is no format() for 'name' in R 3.6.x and before
format_name <- function(x) {
if (is.name(x)) {
as.character(x)
} else {
format(x)
}
}
frame_call <- function(frame) {
out <- NULL
delayedAssign("out", base::sys.call(), frame)
out
}
# Useful for snapshots so that they print without an unstable backtrace.
# Call `register_testthat_print()` before running tests.
testthat_print_error <- function(x, ...) {
x[["trace"]] <- NULL
x[["srcref"]] <- NULL
x[["procsrcref"]] <- NULL
attr(x[["call"]], "srcref") <- NULL
print(x)
}
registered <- FALSE
register_testthat_print <- function() {
if (!registered) {
registerS3method(
"testthat_print",
"rlib_error",
testthat_print_error,
asNamespace("testthat")
)
registered <<- TRUE
}
}
# -- public API --------------------------------------------------------
err_env <- environment()
parent.env(err_env) <- baseenv()
structure(
list(
.internal = err_env,
new_cond = new_cond,
new_error = new_error,
throw = throw,
throw_error = throw_error,
chain_error = chain_error,
chain_call = chain_call,
chain_clean_call = chain_clean_call,
add_trace_back = add_trace_back,
process_call = process_call,
onload_hook = onload_hook,
is_interactive = is_interactive,
register_testthat_print = register_testthat_print,
format = list(
advice = format_advice,
call = format_call,
class = format_class,
error = format_error,
error_heading = format_error_heading,
header_line = format_header_line,
srcref = format_srcref,
trace = format_trace
)
),
class = c("standalone_errors", "standalone"))
})
# These are optional, and feel free to remove them if you prefer to
# call them through the `err` object.
new_cond <- err$new_cond
new_error <- err$new_error
throw <- err$throw
throw_error <- err$throw_error
chain_error <- err$chain_error
chain_call <- err$chain_call
chain_clean_call <- err$chain_clean_call
Try the callr package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.