local_unexport_signal_abort()
test_that("errors are signalled with backtrace", {
fn <- function() abort("")
err <- expect_error(fn())
expect_s3_class(err$trace, "rlang_trace")
})
test_that("can pass classed strings as error message", {
message <- structure("foo", class = c("glue", "character"))
err <- expect_error(abort(message))
expect_identical(err$message, message)
})
test_that("errors are saved", {
# `outFile` argument
skip_if(getRversion() < "3.4")
file <- tempfile()
on.exit(unlink(file))
local_options(
`rlang::::force_unhandled_error` = TRUE,
`rlang:::message_file` = tempfile()
)
try(abort("foo", "bar"), outFile = file)
expect_true(inherits_all(last_error(), c("bar", "rlang_error")))
try(cnd_signal(error_cnd("foobar")), outFile = file)
expect_true(inherits_all(last_error(), c("foobar", "rlang_error")))
})
test_that("No backtrace is displayed with top-level active bindings", {
local_options(
rlang_trace_top_env = current_env()
)
env_bind_active(current_env(), foo = function() abort("msg"))
expect_error(foo, "^msg$")
})
test_that("Invalid on_error option resets itself", {
local_options(
`rlang::::force_unhandled_error` = TRUE,
`rlang:::message_file` = tempfile(),
rlang_backtrace_on_error = NA
)
expect_snapshot({
(expect_warning(tryCatch(abort("foo"), error = identity)))
})
expect_null(peek_option("rlang_backtrace_on_error"))
})
test_that("format_onerror_backtrace handles empty and size 1 traces", {
local_options(rlang_backtrace_on_error = "branch")
trace <- new_trace(list(), int())
expect_null(format_onerror_backtrace(trace))
trace <- new_trace(list(quote(foo)), int(0))
expect_null(format_onerror_backtrace(trace))
trace <- new_trace(list(quote(foo), quote(bar)), int(0, 1))
expect_match(format_onerror_backtrace(error_cnd(trace = trace)), "foo.*bar")
})
test_that("error is printed with backtrace", {
skip_if_stale_backtrace()
run_error_script <- function(envvars = chr()) {
run_script(test_path("fixtures", "error-backtrace.R"), envvars = envvars)
}
default_interactive <- run_error_script(envvars = "rlang_interactive=true")
default_non_interactive <- run_error_script()
reminder <- run_error_script(envvars = "rlang_backtrace_on_error=reminder")
branch <- run_error_script(envvars = "rlang_backtrace_on_error=branch")
collapse <- run_error_script(envvars = "rlang_backtrace_on_error=collapse")
full <- run_error_script(envvars = "rlang_backtrace_on_error=full")
rethrown_interactive <- run_script(
test_path("fixtures", "error-backtrace-rethrown.R"),
envvars = "rlang_interactive=true"
)
rethrown_non_interactive <- run_script(
test_path("fixtures", "error-backtrace-rethrown.R")
)
expect_snapshot({
cat_line(default_interactive)
cat_line(default_non_interactive)
cat_line(reminder)
cat_line(branch)
cat_line(collapse)
cat_line(full)
cat_line(rethrown_interactive)
cat_line(rethrown_non_interactive)
})
})
test_that("empty backtraces are not printed", {
skip_if_stale_backtrace()
run_error_script <- function(envvars = chr()) {
run_script(test_path("fixtures", "error-backtrace-empty.R"), envvars = envvars)
}
branch_depth_0 <- run_error_script(envvars = c("rlang_backtrace_on_error=branch", "trace_depth=0"))
full_depth_0 <- run_error_script(envvars = c("rlang_backtrace_on_error=full", "trace_depth=0"))
branch_depth_1 <- run_error_script(envvars = c("rlang_backtrace_on_error=branch", "trace_depth=1"))
full_depth_1 <- run_error_script(envvars = c("rlang_backtrace_on_error=full", "trace_depth=1"))
expect_snapshot({
cat_line(branch_depth_0)
cat_line(full_depth_0)
cat_line(branch_depth_1)
cat_line(full_depth_1)
})
})
test_that("parent errors are not displayed in error message and backtrace", {
skip_if_stale_backtrace()
run_error_script <- function(envvars = chr()) {
run_script(
test_path("fixtures", "error-backtrace-parent.R"),
envvars = envvars
)
}
non_interactive <- run_error_script()
interactive <- run_error_script(envvars = "rlang_interactive=true")
expect_snapshot({
cat_line(interactive)
cat_line(non_interactive)
})
})
test_that("backtrace reminder is displayed when called from `last_error()`", {
local_options(
rlang_trace_format_srcrefs = FALSE,
rlang_trace_top_env = current_env()
)
f <- function() g()
g <- function() h()
h <- function() abort("foo")
err <- catch_error(f())
poke_last_error(err)
expect_snapshot({
"Normal case"
print(err)
"From `last_error()`"
print(last_error())
"Saved from `last_error()`"
{
saved <- last_error()
print(saved)
}
"Saved from `last_error()`, but no longer last"
{
poke_last_error(error_cnd("foo"))
print(saved)
}
})
})
local({
local_options(
rlang_trace_format_srcrefs = FALSE,
rlang_trace_top_env = current_env()
)
throw <- NULL
low1 <- function() low2()
low2 <- function() low3()
low3 <- NULL
high3_catch <- function(..., chain, stop_helper) {
tryCatch(
low1(),
error = function(err) {
parent <- if (chain) err else NA
if (stop_helper) {
stop1("high-level", parent = err)
} else {
abort("high-level", parent = err)
}
}
)
}
high3_call <- function(..., chain, stop_helper) {
withCallingHandlers(
low1(),
error = function(err) {
parent <- if (chain) err else NA
if (stop_helper) {
stop1("high-level", parent = err)
} else {
abort("high-level", parent = err)
}
}
)
}
high3_fetch <- function(..., chain, stop_helper) {
try_fetch(
low1(),
error = function(err) {
parent <- if (chain) err else NA
if (stop_helper) {
stop1("high-level", parent = err)
} else {
abort("high-level", parent = err)
}
}
)
}
high1 <- function(...) high2(...)
high2 <- function(...) high3(...)
high3 <- NULL
stop1 <- function(..., call = caller_env()) stop2(..., call = call)
stop2 <- function(..., call = caller_env()) stop3(..., call = call)
stop3 <- function(..., call = caller_env()) abort(..., call = call)
throwers <- list(
"stop()" = function() stop("low-level"),
"abort()" = function() abort("low-level"),
"warn = 2" = function() {
local_options(warn = 2)
warning("low-level")
}
)
handlers <- list(
"tryCatch()" = high3_catch,
"withCallingHandlers()" = high3_call,
"try_fetch()" = high3_fetch
)
for (i in seq_along(throwers)) {
for (j in seq_along(handlers)) {
case_name <- paste0(
"Backtrace on rethrow: ",
names(throwers)[[i]], " - ", names(handlers)[[j]]
)
low3 <- throwers[[i]]
high3 <- handlers[[j]]
# Use `print()` because `testthat_print()` (called implicitly in
# snapshots) doesn't print backtraces
test_that(case_name, {
expect_snapshot({
print(catch_error(high1(chain = TRUE, stop_helper = TRUE)))
print(catch_error(high1(chain = TRUE, stop_helper = FALSE)))
print(catch_error(high1(chain = FALSE, stop_helper = TRUE)))
print(catch_error(high1(chain = FALSE, stop_helper = FALSE)))
})
})
}
}
})
test_that("abort() displays call in error prefix", {
skip_if_not_installed("rlang", "0.4.11.9001")
expect_snapshot(
run("{
options(cli.unicode = FALSE, crayon.enabled = FALSE)
rlang::abort('foo', call = quote(bar(baz)))
}")
)
# errorCondition()
skip_if_not_installed("base", "3.6.0")
expect_snapshot(
run("{
options(cli.unicode = FALSE, crayon.enabled = FALSE)
rlang::cnd_signal(errorCondition('foo', call = quote(bar(baz))))
}")
)
})
test_that("abort() accepts environment as `call` field.", {
check_required2 <- function(arg, call = caller_call()) {
check_required(arg, call = call)
}
f <- function(x) g(x)
g <- function(x) h(x)
h <- function(x) check_required2(x, call = environment())
expect_snapshot((expect_error(f())))
})
test_that("format_error_arg() formats argument", {
exp <- format_arg("foo")
expect_equal(format_error_arg("foo"), exp)
expect_equal(format_error_arg(sym("foo")), exp)
expect_equal(format_error_arg(chr_get("foo", 0L)), exp)
expect_equal(format_error_arg(quote(foo())), format_arg("foo()"))
expect_error(format_error_arg(c("foo", "bar")), "must be a string or an expression")
expect_error(format_error_arg(function() NULL), "must be a string or an expression")
})
test_that("local_error_call() works", {
foo <- function() {
bar()
}
bar <- function() {
local_error_call(quote(expected()))
baz()
}
baz <- function() {
local_error_call("caller")
abort("tilt")
}
expect_snapshot((expect_error(foo())))
})
test_that("can disable error call inference for unexported functions", {
foo <- function() abort("foo")
expect_snapshot({
(expect_error(foo()))
local({
local_options("rlang:::restrict_default_error_call" = TRUE)
(expect_error(foo()))
})
local({
local_options("rlang:::restrict_default_error_call" = TRUE)
(expect_error(dots_list(.homonyms = "k")))
})
})
})
test_that("error call flag is stripped", {
e <- env(.__error_call__. = quote(foo(bar)))
expect_equal(error_call(e), quote(foo(bar)))
expect_equal(format_error_call(e), "`foo()`")
})
test_that("NSE doesn't interfere with error call contexts", {
# Snapshots shouldn't show `eval()` as context
expect_snapshot({
(expect_error(local(arg_match0("f", "foo"))))
(expect_error(eval_bare(quote(arg_match0("f", "foo")))))
(expect_error(eval_bare(quote(arg_match0("f", "foo")), env())))
})
})
test_that("error_call() requires a symbol in function position", {
expect_null(format_error_call(quote((function() NULL)())))
expect_null(format_error_call(call2(function() NULL)))
})
test_that("error_call() preserves index calls", {
expect_equal(format_error_call(quote(foo$bar(...))), "`foo$bar()`")
})
test_that("error_call() preserves `if` (r-lib/testthat#1429)", {
call <- quote(if (foobar) TRUE else FALSE)
expect_equal(
error_call(call),
call
)
expect_equal(
format_error_call(call),
"`if (foobar) ...`"
)
})
test_that("error_call() and format_error_call() preserve special syntax ops", {
expect_equal(
error_call(quote(1 + 2)),
quote(1 + 2)
)
expect_snapshot(format_error_call(quote(1 + 2)))
expect_equal(
error_call(quote(for (x in y) NULL)),
quote(for (x in y) NULL)
)
expect_snapshot(format_error_call(quote(for (x in y) NULL)))
expect_snapshot(format_error_call(quote(a %||% b)))
expect_snapshot(format_error_call(quote(`%||%`()))) # Suboptimal
})
test_that("error_call() preserves srcrefs", {
eval_parse("{
f <- function() g()
g <- function() h()
h <- function() abort('Foo.')
}")
out <- error_call(catch_error(f())$call)
expect_s3_class(attr(out, "srcref"), "srcref")
})
test_that("withCallingHandlers() wrappers don't throw off trace capture on rethrow", {
local_options(
rlang_trace_top_env = current_env(),
rlang_trace_format_srcrefs = FALSE
)
variant <- if (getRversion() < "3.6.0") "pre-3.6.0" else "current"
low1 <- function() low2()
low2 <- function() low3()
low3 <- function() abort("Low-level message")
wch <- function(expr, ...) {
withCallingHandlers(expr, ...)
}
handler1 <- function(err, call = caller_env()) {
handler2(err, call = call)
}
handler2 <- function(err, call = caller_env()) {
abort("High-level message", parent = err, call = call)
}
high1 <- function() high2()
high2 <- function() high3()
high3 <- function() {
wch(
low1(),
error = function(err) handler1(err)
)
}
err <- expect_error(high1())
expect_snapshot(variant = variant, {
"`abort()` error"
print(err)
summary(err)
})
# Avoid `:::` vs `::` ambiguity depending on loadall
fail <- errorcall
low3 <- function() fail(NULL, "Low-level message")
err <- expect_error(high1())
expect_snapshot(variant = variant, {
"C-level error"
print(err)
summary(err)
})
})
test_that("headers and body are stored in respective fields", {
local_use_cli() # Just to be explicit
cnd <- catch_cnd(abort(c("a", "b", i = "c")), "error")
expect_equal(cnd$message, set_names("a", ""))
expect_equal(cnd$body, c("b", i = "c"))
})
test_that("`abort()` uses older bullets formatting by default", {
local_use_cli(format = FALSE)
expect_snapshot_error(abort(c("foo", "bar")))
})
test_that("abort() preserves `call`", {
err <- catch_cnd(abort("foo", call = quote(1 + 2)), "error")
expect_equal(err$call, quote(1 + 2))
})
test_that("format_error_call() preserves I() inputs", {
expect_equal(
format_error_call(I(quote(.data[[1]]))),
"`.data[[1]]`"
)
})
test_that("format_error_call() detects non-syntactic names", {
expect_equal(
format_error_call(quote(`[[.foo`())),
"`[[.foo`"
)
})
test_that("generic call is picked up in methods", {
g <- function(call = caller_env()) {
abort("foo", call = call)
}
f1 <- function(x) {
UseMethod("f1")
}
f1.default <- function(x) {
g()
}
f2 <- function(x) {
UseMethod("f2")
}
f2.NULL <- function(x) {
NextMethod()
}
f2.default <- function(x) {
g()
}
f3 <- function(x) {
UseMethod("f3")
}
f3.foo <- function(x) {
NextMethod()
}
f3.bar <- function(x) {
NextMethod()
}
f3.default <- function(x) {
g()
}
expect_snapshot({
err(f1())
err(f2())
err(f3())
})
})
test_that("errors are fully displayed (parents, calls) in knitted files", {
skip_if_not_installed("knitr")
skip_if_not_installed("rmarkdown")
skip_if_not(rmarkdown::pandoc_available())
expect_snapshot({
writeLines(render_md("test-parent-errors.Rmd"))
})
})
test_that("can supply bullets both through `message` and `body`", {
local_use_cli(format = FALSE)
expect_snapshot({
(expect_error(abort("foo", body = c("a", "b"))))
(expect_error(abort(c("foo", "bar"), body = c("a", "b"))))
})
})
test_that("can supply bullets both through `message` and `body` (cli case)", {
local_use_cli(format = TRUE)
expect_snapshot({
(expect_error(abort("foo", body = c("a", "b"))))
(expect_error(abort(c("foo", "bar"), body = c("a", "b"))))
})
})
test_that("setting `.internal` adds footer bullet", {
expect_snapshot({
err(abort(c("foo", "x" = "bar"), .internal = TRUE))
err(abort("foo", body = c("x" = "bar"), .internal = TRUE))
})
})
test_that("setting `.internal` adds footer bullet (fallback)", {
local_use_cli(format = FALSE)
expect_snapshot({
err(abort(c("foo", "x" = "bar"), .internal = TRUE))
err(abort("foo", body = c("x" = "bar"), .internal = TRUE))
})
})
test_that("must pass character `body` when `message` is > 1", {
expect_snapshot({
# This is ok because `message` is length 1
err(abort("foo", body = function(cnd, ...) c("i" = "bar")))
# This is an internal error
err(abort(c("foo", "bar"), body = function() "baz"))
})
})
test_that("must pass character `body` when `message` is > 1 (non-cli case)", {
local_use_cli(format = FALSE)
expect_snapshot({
# This is ok because `message` is length 1
err(abort("foo", body = function(cnd, ...) c("i" = "bar")))
# This is an internal error
err(abort(c("foo", "bar"), body = function() "baz"))
})
})
test_that("can supply `footer`", {
local_error_call(call("f"))
expect_snapshot({
err(abort("foo", body = c("i" = "bar"), footer = c("i" = "baz")))
err(abort("foo", body = function(cnd, ...) c("i" = "bar"), footer = function(cnd, ...) c("i" = "baz")))
})
})
test_that("can supply `footer` (non-cli case)", {
local_use_cli(format = FALSE)
local_error_call(call("f"))
expect_snapshot({
err(abort("foo", body = c("i" = "bar"), footer = c("i" = "baz")))
err(abort("foo", body = function(cnd, ...) c("i" = "bar"), footer = function(cnd, ...) c("i" = "baz")))
})
})
test_that("can't supply both `footer` and `.internal`", {
expect_snapshot({
err(abort("foo", .internal = TRUE, call = quote(f())))
err(abort("foo", footer = "bar", .internal = TRUE, call = quote(f())))
})
})
test_that("caller of withCallingHandlers() is used as default `call`", {
low <- function() {
# Intervening `withCallingHandlers()` is not picked up
withCallingHandlers(stop("low"))
}
high <- function() {
withCallingHandlers(
low(),
error = function(cnd) abort("high", parent = cnd)
)
}
err <- catch_error(high())
expect_equal(err$call, quote(high()))
# Named case
handler <- function(cnd) abort("high", parent = cnd)
high <- function() {
withCallingHandlers(
low(),
error = handler
)
}
err <- catch_error(high())
expect_equal(err$call, quote(high()))
# Wrapped case
handler1 <- function(cnd) handler2(cnd)
handler2 <- function(cnd) abort("high", parent = cnd)
high <- function() {
try_fetch(
low(),
error = handler1
)
}
err <- catch_error(high())
expect_equal(err$call, quote(high()))
function(cnd) abort("high", parent = cnd)
})
test_that("`cli.condition_unicode_bullets` is supported by fallback formatting", {
local_use_cli(format = FALSE)
local_options(
cli.unicode = TRUE,
cli.condition_unicode_bullets = FALSE
)
expect_snapshot_error(
rlang::abort(c("foo", "i" = "bar"))
)
})
test_that("call can be a quosure or contain quosures", {
err <- catch_error(abort("foo", call = quo(f(!!quo(g())))))
expect_equal(err$call, quote(f(g())))
})
test_that("`parent = NA` signals a non-chained rethrow", {
variant <- if (getRversion() < "3.6.0") "pre-3.6.0" else "current"
local_options(
rlang_trace_top_env = current_env(),
rlang_trace_format_srcrefs = FALSE
)
ff <- function() gg()
gg <- function() hh()
foo <- function() bar()
bar <- function() baz()
baz <- function() stop("bar")
expect_snapshot(variant = variant, {
"Absent parent causes bad trace bottom"
hh <- function() {
withCallingHandlers(foo(), error = function(cnd) {
abort(cnd_header(cnd))
})
}
print(err(ff()))
"Missing parent allows correct trace bottom"
hh <- function() {
withCallingHandlers(foo(), error = function(cnd) {
abort(cnd_header(cnd), parent = NA)
})
}
print(err(ff()))
"Wrapped handler"
handler1 <- function(cnd, call = caller_env()) handler2(cnd, call)
handler2 <- function(cnd, call) abort(cnd_header(cnd), parent = NA, call = call)
hh <- function() {
withCallingHandlers(
foo(),
error = function(cnd) handler1(cnd)
)
}
print(err(ff()))
"Wrapped handler, `try_fetch()`"
hh <- function() {
try_fetch(
foo(),
error = function(cnd) handler1(cnd)
)
}
print(err(ff()))
"Wrapped handler, incorrect `call`"
hh <- function() {
withCallingHandlers(
foo(),
error = handler1
)
}
print(err(ff()))
})
})
test_that("can rethrow outside handler", {
local_options(rlang_trace_format_srcrefs = FALSE)
parent <- error_cnd(message = "Low-level", call = call("low"))
foo <- function() bar()
bar <- function() baz()
baz <- function() abort("High-level", parent = parent)
expect_snapshot({
print(err(foo()))
})
})
test_that("if `call` is older than handler caller, use that as bottom", {
local_options(
rlang_trace_format_srcrefs = FALSE
)
f <- function() helper()
helper <- function(call = caller_env()) {
try_fetch(
low_level(call),
error = function(cnd) abort(
"Problem.",
parent = cnd,
call = call
)
)
}
expect_snapshot({
low_level <- function(call) {
abort("Tilt.", call = call)
}
print(expect_error(f()))
low_level <- function(call) {
abort("Tilt.", call = list(NULL, frame = call))
}
print(expect_error(f()))
})
})
test_that("is_calling_handler_inlined_call() doesn't fail with OOB subsetting", {
expect_false(is_calling_handler_inlined_call(call2(function() NULL)))
})
test_that("base causal errors include full user backtrace", {
local_options(
rlang_trace_format_srcrefs = FALSE,
rlang_trace_top_env = current_env()
)
my_verb <- function(expr) {
with_chained_errors(expr)
}
with_chained_errors <- function(expr, call = caller_env()) {
try_fetch(
expr,
error = function(cnd) {
abort(
"Problem during step.",
parent = cnd,
call = call
)
}
)
}
add <- function(x, y) x + y
expect_snapshot({
print(expect_error(my_verb(add(1, ""))))
})
})
test_that("can chain errors at top-level (#1405)", {
out <- run_code("
tryCatch(
error = function(err) rlang::abort('bar', parent = err),
rlang::abort('foo')
)
")
expect_true(any(grepl("foo", out$output)))
expect_true(any(grepl("bar", out$output)))
out <- run_code("
withCallingHandlers(
error = function(err) rlang::abort('bar', parent = err),
rlang::abort('foo')
)
")
expect_true(any(grepl("foo", out$output)))
expect_true(any(grepl("bar", out$output)))
})
test_that("backtrace_on_error = 'collapse' is deprecated.", {
local_options("rlang_backtrace_on_error" = "collapse")
expect_warning(peek_backtrace_on_error(), "deprecated")
expect_equal(peek_option("rlang_backtrace_on_error"), "none")
})
test_that("can supply header method via `message`", {
expect_snapshot(error = TRUE, {
abort(~ "foo")
abort(function(cnd, ...) "foo")
})
msg <- function(cnd, ...) "foo"
cnd <- catch_error(abort(msg))
expect_identical(cnd$header, msg)
expect_error(
abort(function(cnd) "foo"),
"must take"
)
})
test_that("newlines are preserved by cli (#1535)", {
expect_snapshot(error = TRUE, {
abort("foo\nbar", use_cli_format = TRUE)
abort("foo\fbar", use_cli_format = TRUE)
})
})
test_that("`show.error.messages` is respected by `abort()` (#1630)", {
run_error_script <- function(envvars = chr()) {
run_script(test_path("fixtures", "error-show-messages.R"), envvars = envvars)
}
with_messages <- run_error_script(envvars = c("show_error_messages=TRUE"))
without_messages <- run_error_script(envvars = c("show_error_messages=FALSE"))
expect_snapshot({
cat_line(with_messages)
cat_line(without_messages)
})
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.