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