1
2context("errors.R")
3
4test_that("throw() is standalone", {
5  stenv <- environment(throw)
6  objs <- ls(stenv, all.names = TRUE)
7  funs <- Filter(function(x) is.function(stenv[[x]]), objs)
8  funobjs <- mget(funs, stenv)
9  for (f in funobjs) expect_identical(environmentName(topenv(f)), "base")
10
11  expect_message(
12    mapply(codetools::checkUsage, funobjs, funs,
13           MoreArgs = list(report = message)),
14    NA)
15})
16
17test_that("new_cond", {
18  c <- new_cond("foo", "bar")
19  expect_identical(class(c), "condition")
20  expect_identical(c$message, "foobar")
21})
22
23test_that("new_error", {
24  c <- new_error("foo", "bar")
25  expect_identical(
26    class(c),
27    c("rlib_error_2_0", "rlib_error", "error", "condition")
28  )
29  expect_identical(c$message, "foobar")
30})
31
32test_that("throw() needs condition objects", {
33  expect_error(
34    throw("foobar"), "can only throw conditions",
35    class = "rlib_error")
36  expect_error(
37    throw(new_error("foobar"), parent = "nope"),
38    "Parent condition must be a condition object",
39    class = "rlib_error")
40})
41
42test_that("throw() adds the proper call, if requested", {
43  f <- function() throw(new_error("ooops"))
44  err <- tryCatch(f(), error = function(e) e)
45  expect_s3_class(err, "rlib_error")
46  expect_identical(err$call, quote(f()))
47
48  g <- function() throw(new_error("ooops", call. = FALSE))
49  err <- tryCatch(g(), error = function(e) e)
50  expect_s3_class(err, "rlib_error")
51  expect_null(err$call)
52})
53
54test_that("throw() only stops for errors", {
55  f <- function() throw(new_cond("nothing important"))
56
57  cond <- tryCatch(f(), condition = function(e) e)
58  expect_s3_class(cond, "condition")
59
60  expect_error(f(), NA)
61})
62
63test_that("caught conditions have no trace", {
64  f <- function() throw(new_error("nothing important"))
65
66  cond <- tryCatch(f(), condition = function(e) e)
67  expect_null(cond$trace)
68})
69
70test_that("un-caught condition has trace", {
71
72  skip_on_cran()
73
74  # We need to run this in a separate script, because
75  # testthat catches all conditions. We also cannot run it in callr::r()
76  # or similar, because those catch conditions as well.
77
78  sf <- tempfile(fileext = ".R")
79  op <- sub("\\.R$", ".rds", sf)
80  so <- paste0(sf, "out")
81  se <- paste0(sf, "err")
82  on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
83
84  expr <- substitute({
85    f <- function() g()
86    g <- function() processx:::throw(processx:::new_error("oooops"))
87    options(rlib_error_handler = function(c) {
88      saveRDS(c, file = `__op__`)
89    })
90    f()
91  }, list("__op__" = op))
92
93  cat(deparse(expr), file = sf, sep = "\n")
94
95  callr::rscript(sf, stdout = so, stderr = se)
96
97  cond <- readRDS(op)
98  expect_s3_class(cond, "rlib_error")
99  expect_s3_class(cond$trace, "rlib_trace")
100})
101
102test_that("catch_rethow", {
103
104  h <- function() h2()
105  h2 <- function() throw(new_error("oops"))
106
107  f <- function() g()
108  g <- function() {
109    err$catch_rethrow(
110      h(),
111      error = function(e) throw(new_error("oops2"), parent = e))
112  }
113
114  cond <- tryCatch(g(), error = function(e) e)
115  expect_s3_class(cond, "rlib_error")
116  expect_equal(cond$call, quote(g()))
117  expect_s3_class(cond$parent, "rlib_error")
118  expect_equal(cond$parent$call, quote(h2()))
119  expect_true(is.integer(cond$`_nframe`))
120  expect_true(is.integer(cond$parent$`_nframe`))
121  expect_true(cond$`_nframe` < cond$parent$`_nframe`)
122})
123
124test_that("rethrow", {
125  h <- function() h2()
126  h2 <- function() throw(new_error("oops"))
127
128  f <- function() g()
129  g <- function() rethrow(h(), new_error("oops2"))
130
131  cond <- tryCatch(g(), error = function(e) e)
132  expect_s3_class(cond, "rlib_error")
133  expect_equal(cond$call, quote(g()))
134  expect_s3_class(cond$parent, "rlib_error")
135  expect_equal(cond$parent$call, quote(h2()))
136  expect_true(is.integer(cond$`_nframe`))
137  expect_true(is.integer(cond$parent$`_nframe`))
138  expect_true(cond$`_nframe` < cond$parent$`_nframe`)
139})
140
141test_that("rethrow without call", {
142  h <- function() h2()
143  h2 <- function() throw(new_error("oops"))
144
145  f <- function() g()
146  g <- function() rethrow(h(), new_error("oops2"), call = FALSE)
147
148  cond <- tryCatch(g(), error = function(e) e)
149  expect_s3_class(cond, "rlib_error")
150  expect_null(cond$call)
151  expect_s3_class(cond$parent, "rlib_error")
152  expect_equal(cond$parent$call, quote(h2()))
153  expect_true(is.integer(cond$`_nframe`))
154  expect_true(is.integer(cond$parent$`_nframe`))
155  expect_true(cond$`_nframe` < cond$parent$`_nframe`)
156})
157
158test_that("rethrow_call", {
159
160  cond <- tryCatch(
161    rethrow_call(c_processx_base64_encode, "foobar"),
162    error = function(e) e)
163  expect_equal(cond$call[[1]], quote(rethrow_call))
164  expect_s3_class(cond, "c_error")
165  expect_s3_class(cond, "rlib_error")
166})
167
168test_that("trace when rethrowing", {
169
170  skip_on_cran()
171
172  sf <- tempfile(fileext = ".R")
173  op <- sub("\\.R$", ".rds", sf)
174  so <- paste0(sf, "out")
175  se <- paste0(sf, "err")
176  on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
177
178  expr <- substitute({
179    f <- function() g()
180    g <- function() processx:::throw(processx:::new_error("oooops"))
181    h <- function() processx:::rethrow(f(), processx:::new_error("and again"))
182    options(rlib_error_handler = function(c) {
183      saveRDS(c, file = `__op__`)
184      # quit after the first, because the other one is caught here as well
185      q()
186    })
187    h()
188  }, list("__op__" = op))
189
190  cat(deparse(expr), file = sf, sep = "\n")
191
192  callr::rscript(sf, stdout = so, stderr = se)
193
194  cond <- readRDS(op)
195
196  expect_s3_class(cond, "rlib_error")
197  expect_s3_class(cond$parent, "rlib_error")
198  expect_s3_class(cond$trace, "rlib_trace")
199  expect_null(cond$parent$trace)
200
201  expect_equal(length(cond$trace$nframe), 2)
202  expect_true(cond$trace$nframe[1] < cond$trace$nframe[2])
203  expect_equal(cond$trace$messages, list("and again", "oooops"))
204  expect_equal(cond$trace$calls[[cond$trace$nframe[1]-1]], "h()")
205  expect_equal(cond$trace$calls[[cond$trace$nframe[2]-1]], "g()")
206})
207
208test_that("rethrowing non rlib errors", {
209  skip_on_cran()
210
211  sf <- tempfile(fileext = ".R")
212  op <- sub("\\.R$", ".rds", sf)
213  so <- paste0(sf, "out")
214  se <- paste0(sf, "err")
215  on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
216
217  expr <- substitute({
218    f <- function() g()
219    g <- function() stop("oooopsie")
220    h <- function() processx:::rethrow(f(), processx:::new_error("and again"))
221    options(rlib_error_handler = function(c) {
222      saveRDS(c, file = `__op__`)
223      # quit after the first, because the other one is caught here as well
224      q()
225    })
226    h()
227  }, list("__op__" = op))
228
229  cat(deparse(expr), file = sf, sep = "\n")
230
231  callr::rscript(sf, stdout = so, stderr = se)
232
233  cond <- readRDS(op)
234
235  expect_s3_class(cond, "rlib_error")
236  expect_s3_class(cond$parent, "simpleError")
237  expect_false(inherits(cond$parent, "rlib_error"))
238  expect_s3_class(cond$trace, "rlib_trace")
239  expect_null(cond$parent$trace)
240
241  expect_equal(length(cond$trace$nframe), 2)
242  expect_true(cond$trace$nframe[1] < cond$trace$nframe[2])
243  expect_equal(cond$trace$messages, list("and again", "oooopsie"))
244  expect_equal(cond$trace$calls[[cond$trace$nframe[1]-1]], "h()")
245})
246
247test_that("errors from subprocess", {
248  skip_if_not_installed("callr", minimum_version = "3.2.0.9001")
249  err <- tryCatch(
250    callr::r(function() 1 + "a"),
251    error = function(e) e)
252  expect_s3_class(err, "rlib_error")
253  expect_s3_class(err$parent, "error")
254  expect_false(is.null(err$parent$trace))
255})
256
257test_that("error trace from subprocess", {
258  skip_on_cran()
259  skip_if_not_installed("callr", minimum_version = "3.2.0.9001")
260
261  sf <- tempfile(fileext = ".R")
262  op <- sub("\\.R$", ".rds", sf)
263  so <- paste0(sf, "out")
264  se <- paste0(sf, "err")
265  on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
266
267  expr <- substitute({
268    h <- function() callr::r(function() 1 + "a")
269    options(rlib_error_handler = function(c) {
270      saveRDS(c, file = `__op__`)
271      # quit after the first, because the other one is caught here as well
272      q()
273    })
274    h()
275  }, list("__op__" = op))
276
277  cat(deparse(expr), file = sf, sep = "\n")
278
279  callr::rscript(sf, stdout = so, stderr = se)
280
281  cond <- readRDS(op)
282
283  expect_s3_class(cond, "rlib_error")
284  expect_s3_class(cond$parent, "error")
285  expect_s3_class(cond$trace, "rlib_trace")
286
287  expect_equal(length(cond$trace$nframe), 2)
288  expect_true(cond$trace$nframe[1] < cond$trace$nframe[2])
289  expect_match(cond$trace$messages[[1]], "subprocess failed: non-numeric")
290  expect_match(cond$trace$messages[[2]], "non-numeric argument")
291})
292
293test_that("error trace from throw() in subprocess", {
294  skip_on_cran()
295  skip_if_not_installed("callr", minimum_version = "3.2.0.9001")
296
297  sf <- tempfile(fileext = ".R")
298  op <- sub("\\.R$", ".rds", sf)
299  so <- paste0(sf, "out")
300  se <- paste0(sf, "err")
301  on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
302
303  expr <- substitute({
304    h <- function() callr::r(function() processx::run("does-not-exist---"))
305    options(rlib_error_handler = function(c) {
306      saveRDS(c, file = `__op__`)
307      # quit after the first, because the other one is caught here as well
308      q()
309    })
310    h()
311  }, list("__op__" = op))
312
313  cat(deparse(expr), file = sf, sep = "\n")
314
315  callr::rscript(sf, stdout = so, stderr = se)
316
317  cond <- readRDS(op)
318
319  expect_s3_class(cond, "rlib_error")
320  expect_s3_class(cond$parent, "rlib_error")
321  expect_s3_class(cond$trace, "rlib_trace")
322
323  expect_equal(length(cond$trace$nframe), 2)
324  expect_true(cond$trace$nframe[1] < cond$trace$nframe[2])
325  expect_match(cond$trace$messages[[1]], "subprocess failed: .*processx\\.c")
326  expect_match(cond$trace$messages[[2]], "@.*processx\\.c")
327})
328
329test_that("trace is not overwritten", {
330  skip_on_cran()
331  withr::local_options(list(rlib_error_always_trace = TRUE))
332  err <- new_error("foobar")
333  err$trace <- "not really"
334
335  err2 <- tryCatch(throw(err), error = function(e) e)
336  expect_identical(err2$trace, "not really")
337})
338
339test_that("error is printed on error", {
340  skip_on_cran()
341
342  sf <- tempfile(fileext = ".R")
343  op <- sub("\\.R$", ".rds", sf)
344  so <- paste0(sf, "out")
345  se <- paste0(sf, "err")
346  on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
347
348  expr <- substitute({
349    options(rlib_interactive = TRUE)
350    processx::run(basename(tempfile()))
351  })
352
353  cat(deparse(expr), file = sf, sep = "\n")
354
355  callr::rscript(
356    sf,
357    stdout = so,
358    stderr = se,
359    fail_on_status = FALSE,
360    show = FALSE
361  )
362
363  selines <- readLines(se)
364  expect_true(
365    any(grepl("No such file or directory", selines)) ||
366    any(grepl("Command .* not found", selines))
367  )
368  expect_false(any(grepl("Stack trace", selines)))
369})
370
371test_that("trace is printed on error in non-interactive sessions", {
372
373  sf <- tempfile(fileext = ".R")
374  op <- sub("\\.R$", ".rds", sf)
375  so <- paste0(sf, "out")
376  se <- paste0(sf, "err")
377  on.exit(unlink(c(sf, op, so, se), recursive = TRUE), add = TRUE)
378
379  expr <- substitute({
380    processx::run(basename(tempfile()))
381  })
382
383  cat(deparse(expr), file = sf, sep = "\n")
384
385  callr::rscript(
386    sf,
387    stdout = so,
388    stderr = se,
389    fail_on_status = FALSE,
390    show = FALSE
391  )
392
393  selines <- readLines(se)
394  expect_true(
395    any(grepl("No such file or directory", selines)) ||
396      any(grepl("Command .* not found", selines))
397  )
398  expect_true(any(grepl("Stack trace", selines)))
399})
400