1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
#' Source a file, directory of files, or various important subsets
#'
#' These are used by [test_dir()] and friends
#'
#' @param path Path to files.
#' @param pattern Regular expression used to filter files.
#' @param env Environment in which to evaluate code.
#' @param desc If not-`NULL`, will run only test with this `desc`ription.
#' @param chdir Change working directory to `dirname(path)`?
#' @param wrap Automatically wrap all code within [test_that()]? This ensures
#' that all expectations are reported, even if outside a test block.
#' @export
#' @keywords internal
source_file <- function(path,
env = test_env(),
chdir = TRUE,
desc = NULL,
wrap = TRUE,
error_call = caller_env()) {
stopifnot(file.exists(path))
stopifnot(is.environment(env))
lines <- brio::read_lines(path)
srcfile <- srcfilecopy(path, lines, file.info(path)[1, "mtime"], isFile = TRUE)
## We need to parse from a connection, because parse() has a bug,
## and converts the input to the native encoding, if the text arg is used
con <- textConnection(lines, encoding = "UTF-8")
on.exit(try(close(con), silent = TRUE), add = TRUE)
exprs <- parse(con, n = -1, srcfile = srcfile, encoding = "UTF-8")
exprs <- filter_desc(exprs, desc, error_call = error_call)
n <- length(exprs)
if (n == 0L) return(invisible())
if (chdir) {
old_dir <- setwd(dirname(path))
on.exit(setwd(old_dir), add = TRUE)
}
withr::local_options(testthat_topenv = env, testthat_path = path)
if (wrap) {
invisible(test_code(
test = NULL,
code = exprs,
env = env,
reporter = get_reporter() %||% StopReporter$new()
))
} else {
withCallingHandlers(
invisible(eval(exprs, env)),
error = function(err) {
abort(
paste0("In path: ", encodeString(path, quote = '"')),
parent = err,
call = error_call
)
}
)
}
}
filter_desc <- function(exprs, desc = NULL, error_call = caller_env()) {
if (is.null(desc)) {
return(exprs)
}
found <- FALSE
include <- rep(FALSE, length(exprs))
for (i in seq_along(exprs)) {
expr <- exprs[[i]]
if (!is_call(expr, c("test_that", "describe"), n = 2)) {
if (!found) {
include[[i]] <- TRUE
}
} else {
if (!is_string(expr[[2]]))
next
test_desc <- as.character(expr[[2]])
if (test_desc != desc)
next
if (found) {
abort("Found multiple tests with specified description", call = error_call)
}
include[[i]] <- TRUE
found <- TRUE
}
}
if (!found) {
abort("Failed to find test with specified description", call = error_call)
}
exprs[include]
}
#' @rdname source_file
#' @export
source_dir <- function(path, pattern = "\\.[rR]$", env = test_env(),
chdir = TRUE, wrap = TRUE) {
files <- normalizePath(sort(dir(path, pattern, full.names = TRUE)))
lapply(files, function(path) {
source_file(path, env = env, chdir = chdir, wrap = wrap)
})
}
#' @rdname source_file
#' @export
source_test_helpers <- function(path = "tests/testthat", env = test_env()) {
source_dir(path, "^helper.*\\.[rR]$", env = env, wrap = FALSE)
}
#' @rdname source_file
#' @export
source_test_setup <- function(path = "tests/testthat", env = test_env()) {
source_dir(path, "^setup.*\\.[rR]$", env = env, wrap = FALSE)
}
#' @rdname source_file
#' @export
source_test_teardown <- function(path = "tests/testthat", env = test_env()) {
source_dir(path, "^teardown.*\\.[rR]$", env = env, wrap = FALSE)
}
|
