Nothing
test_that("throw() is standalone", {
stenv <- environment(throw)
objs <- ls(stenv, all.names = TRUE)
funs <- Filter(function(x) is.function(stenv[[x]]), objs)
funobjs <- mget(funs, stenv)
for (f in funobjs) expect_identical(environmentName(topenv(f)), "base")
expect_message(
withCallingHandlers(
res <- mapply(codetools::checkUsage, funobjs, funs,
MoreArgs = list(report = message)),
message = function(c) {
if (grepl(".hide_from_trace", c$message)) {
invokeRestart("muffleMessage")
}
}
),
NA
)
})
test_that("new_cond", {
c <- new_cond("foo", "bar")
expect_identical(class(c), "condition")
expect_identical(c$message, "foobar")
})
test_that("new_error", {
c <- new_error("foo", "bar")
expect_identical(
class(c),
c("rlib_error_3_0", "rlib_error", "error", "condition")
)
expect_identical(c$message, "foobar")
})
test_that("throw() works with condition objects or strings", {
expect_error(
throw("foobar"), "foobar",
class = "rlib_error")
expect_error(
throw(new_error("foobar")), "foobar",
class = "rlib_error")
})
test_that("parent must be an error object", {
expect_error(
throw(new_error("foobar"), parent = "nope"),
"Parent condition must be a condition object",
class = "rlib_error")
})
test_that("throw() adds the proper call, if requested", {
f <- function() throw(new_error("ooops"))
err <- tryCatch(f(), error = function(e) e)
expect_s3_class(err, "rlib_error")
expect_identical(err$call, "f()")
g <- function() throw(new_error("ooops", call. = FALSE))
err <- tryCatch(g(), error = function(e) e)
expect_s3_class(err, "rlib_error")
expect_null(err$call)
})
test_that("throw() only stops for errors", {
f <- function() throw(new_cond("nothing important"))
expect_error(f(), NA)
})
test_that("caught conditions have no trace", {
f <- function() throw(new_error("nothing important"))
cond <- tryCatch(f(), condition = function(e) e)
expect_null(cond$trace)
})
test_that("un-caught condition has trace", {
skip_on_cran()
# We need to run this in a separate script, because
# testthat catches all conditions. We also cannot run it in callr::r()
# or similar, because those catch conditions as well.
sf <- tempfile(fileext = ".R")
op <- sub("\\.R$", ".rds", sf)
so <- paste0(sf, "out")
se <- paste0(sf, "err")
on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
expr <- substitute({
f <- function() g()
g <- function() processx:::throw(processx:::new_error("oooops"))
options(rlib_error_handler = function(c) {
saveRDS(c, file = `__op__`)
})
f()
}, list("__op__" = op))
cat(deparse(expr), file = sf, sep = "\n")
callr::rscript(sf, stdout = so, stderr = se)
cond <- readRDS(op)
expect_s3_class(cond, "rlib_error")
expect_s3_class(cond$trace, "rlib_trace")
})
test_that("chain_call", {
do <- function() {
chain_call(c_processx_base64_encode, "foobar")
}
cond <- tryCatch(
do(),
error = function(e) e
)
expect_equal(cond$call, "do()")
expect_s3_class(cond, "c_error")
expect_s3_class(cond, "rlib_error")
})
test_that("errors from subprocess", {
skip_if_not_installed("callr", minimum_version = "3.7.0")
if (packageVersion("callr") != "3.7.0") skip("only with callr 3.7.0")
err <- tryCatch(
callr::r(function() 1 + "a"),
error = function(e) e)
expect_s3_class(err, "rlib_error")
expect_s3_class(err$parent, "error")
expect_false(is.null(err$parent$trace))
})
test_that("errors from subprocess", {
skip_if_not_installed("callr", minimum_version = "3.7.0.9000")
err <- tryCatch(
callr::r(function() 1 + "a"),
error = function(e) e)
expect_s3_class(err, "rlib_error")
expect_s3_class(err$parent, "error")
expect_false(is.null(err$parent_trace))
})
test_that("error trace from subprocess", {
skip_on_cran()
skip_if_not_installed("callr", minimum_version = "3.7.0")
if (packageVersion("callr") != "3.7.0") skip("only with callr 3.7.0")
sf <- tempfile(fileext = ".R")
op <- sub("\\.R$", ".rds", sf)
so <- paste0(sf, "out")
se <- paste0(sf, "err")
on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
expr <- substitute({
h <- function() callr::r(function() 1 + "a")
options(rlib_error_handler = function(c) {
saveRDS(c, file = `__op__`)
# quit after the first, because the other one is caught here as well
q()
})
h()
}, list("__op__" = op))
cat(deparse(expr), file = sf, sep = "\n")
callr::rscript(sf, stdout = so, stderr = se)
cond <- readRDS(op)
expect_s3_class(cond, "rlib_error")
expect_s3_class(cond$parent, "error")
expect_s3_class(cond$trace, "rlib_trace")
expect_equal(length(cond$trace$nframe), 2)
expect_true(cond$trace$nframe[1] < cond$trace$nframe[2])
expect_match(cond$trace$messages[[1]], "subprocess failed: non-numeric")
expect_match(cond$trace$messages[[2]], "non-numeric argument")
})
test_that("error trace from subprocess", {
skip_on_cran()
skip_if_not_installed("callr", minimum_version = "3.7.0.9000")
sf <- tempfile(fileext = ".R")
op <- sub("\\.R$", ".rds", sf)
so <- paste0(sf, "out")
se <- paste0(sf, "err")
on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
expr <- substitute({
h <- function() callr::r(function() 1 + "a")
options(rlib_error_handler = function(c) {
saveRDS(c, file = `__op__`)
# quit after the first, because the other one is caught here as well
q()
})
h()
}, list("__op__" = op))
cat(deparse(expr), file = sf, sep = "\n")
callr::rscript(sf, stdout = so, stderr = se)
cond <- readRDS(op)
expect_s3_class(cond, "rlib_error")
expect_s3_class(cond$parent, "error")
expect_s3_class(cond$trace, "rlib_trace")
})
test_that("error trace from throw() in subprocess", {
skip_on_cran()
skip_if_not_installed("callr", minimum_version = "3.7.0")
if (packageVersion("callr") != "3.7.0") skip("only with callr 3.7.0")
sf <- tempfile(fileext = ".R")
op <- sub("\\.R$", ".rds", sf)
so <- paste0(sf, "out")
se <- paste0(sf, "err")
on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
expr <- substitute({
h <- function() callr::r(function() processx::run("does-not-exist---"))
options(rlib_error_handler = function(c) {
saveRDS(c, file = `__op__`)
# quit after the first, because the other one is caught here as well
q()
})
h()
}, list("__op__" = op))
cat(deparse(expr), file = sf, sep = "\n")
callr::rscript(sf, stdout = so, stderr = se)
cond <- readRDS(op)
expect_s3_class(cond, "rlib_error")
expect_s3_class(cond$parent, "rlib_error")
expect_s3_class(cond$trace, "rlib_trace")
expect_equal(length(cond$trace$nframe), 2)
expect_true(cond$trace$nframe[1] < cond$trace$nframe[2])
expect_match(cond$trace$messages[[1]], "subprocess failed: .*processx\\.c")
expect_match(cond$trace$messages[[2]], "@.*processx\\.c")
})
test_that("error trace from throw() in subprocess", {
skip_on_cran()
skip_if_not_installed("callr", minimum_version = "3.7.0.9000")
sf <- tempfile(fileext = ".R")
op <- sub("\\.R$", ".rds", sf)
so <- paste0(sf, "out")
se <- paste0(sf, "err")
on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
expr <- substitute({
h <- function() callr::r(function() processx::run("does-not-exist---"))
options(rlib_error_handler = function(c) {
saveRDS(c, file = `__op__`)
# quit after the first, because the other one is caught here as well
q()
})
h()
}, list("__op__" = op))
cat(deparse(expr), file = sf, sep = "\n")
callr::rscript(sf, stdout = so, stderr = se)
cond <- readRDS(op)
expect_s3_class(cond, "rlib_error")
expect_s3_class(cond$parent, "rlib_error")
expect_s3_class(cond$trace, "rlib_trace")
})
test_that("trace is not overwritten", {
skip_on_cran()
withr::local_options(list(rlib_error_always_trace = TRUE))
err <- new_error("foobar")
err$trace <- "not really"
err2 <- tryCatch(throw(err), error = function(e) e)
expect_identical(err2$trace, "not really")
})
test_that("error is printed on error", {
skip_on_cran()
sf <- tempfile(fileext = ".R")
op <- sub("\\.R$", ".rds", sf)
so <- paste0(sf, "out")
se <- paste0(sf, "err")
on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
expr <- substitute({
options(rlib_interactive = TRUE)
processx::run(basename(tempfile()))
})
cat(deparse(expr), file = sf, sep = "\n")
callr::rscript(
sf,
stdout = so,
stderr = se,
fail_on_status = FALSE,
show = FALSE
)
selines <- readLines(so)
expect_true(
any(grepl("No such file or directory", selines)) ||
any(grepl("Command .* not found", selines))
)
expect_false(any(grepl("Stack trace", selines)))
})
test_that("trace is printed on error in non-interactive sessions", {
sf <- tempfile(fileext = ".R")
so <- paste0(sf, "out")
se <- paste0(sf, "err")
on.exit(unlink(c(sf, so, se), recursive = TRUE), add = TRUE)
expr <- substitute({
processx::run(basename(tempfile()))
})
cat(deparse(expr), file = sf, sep = "\n")
callr::rscript(
sf,
stdout = so,
stderr = se,
fail_on_status = FALSE,
show = FALSE
)
selines <- readLines(se)
expect_true(
any(grepl("No such file or directory", selines)) ||
any(grepl("Command .* not found", selines))
)
expect_true(any(grepl("Backtrace", selines)))
})
test_that("can pass frame as error call in `new_error()`", {
check_bar <- function(call = parent.frame()) {
check_foo(call = call)
}
check_foo <- function(call = parent.frame()) {
throw(new_error("my message", call. = call))
}
f <- function() check_bar()
g <- function() check_foo()
expect_snapshot({
(expect_error(f()))
(expect_error(g()))
})
})
test_that("can pass frame as error call in `throw()`", {
check_bar <- function(call = parent.frame()) {
check_foo(call = call)
}
check_foo <- function(call = parent.frame()) {
throw(new_error("my message"), call = call)
}
f <- function() check_bar()
g <- function() check_foo()
expect_snapshot({
(expect_error(f()))
(expect_error(g()))
})
})
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.