Don't allow base packages to be mocked (#553)

Fixes #546

NEWS.md

@@ -1,5 +1,7 @@
 # testthat 1.0.2.9000
 
+* `with_mock()` disallows mocking of functions in base packages, because this doesn't work with the current development version of R (#553).
+
 * `expect_reference()` checks if two names point to the same object (#622).
 
 * Output expectations (`expect_output()`, `expect_message()`, 

R/mock.R

@@ -9,8 +9,8 @@
 #' On exit (regular or error), all functions are restored to their previous state.
 #' This is somewhat abusive of R's internals, and is still experimental, so use with care.
 #'
-#' Primitives (such as [base::interactive()]) cannot be mocked, but this can be
-#' worked around easily by defining a wrapper function with the same name.
+#' Functions in base packages cannot be mocked, but this can be
+#' worked around easily by defining a wrapper function.
 #'
 #' @param ... named parameters redefine mocked functions, unnamed parameters
 #'   will be evaluated after mocking the functions
@@ -21,29 +21,29 @@
 #' @references Suraj Gupta (2012): \href{http://obeautifulcode.com/R/How-R-Searches-And-Finds-Stuff}{How R Searches And Finds Stuff}
 #' @export
 #' @examples
+#' add_one <- function(x) x + 1
+#' expect_equal(add_one(2), 3)
 #' with_mock(
-#'   all.equal = function(x, y, ...) TRUE,
-#'   expect_equal(2 * 3, 4),
-#'   .env = "base"
+#'   add_one = function(x) x - 1,
+#'   expect_equal(add_one(2), 1)
 #' )
-#' with_mock(
-#'   `base::identical` = function(x, y, ...) TRUE,
-#'   `base::all.equal` = function(x, y, ...) TRUE,
-#'   expect_equal(x <- 3 * 3, 6),
-#'   expect_identical(x + 4, 9)
+#' square_add_one <- function(x) add_one(x) ^ 2
+#' expect_equal(square_add_one(2), 9)
+#' expect_equal(
+#'   with_mock(
+#'     add_one = function(x) x - 1,
+#'     square_add_one(2)
+#'   ),
+#'   1
 #' )
-#' \dontrun{
-#' expect_equal(3, 5)
-#' expect_identical(3, 5)
-#' }
 with_mock <- function(..., .env = topenv()) {
   new_values <- eval(substitute(alist(...)))
   mock_qual_names <- names(new_values)
 
   if (all(mock_qual_names == "")) {
     warning("Not mocking anything. Please use named parameters to specify the functions you want to mock.",
             call. = FALSE)
-    code_pos <- TRUE
+    code_pos <- rep(TRUE, length(new_values))
   } else {
     code_pos <- (mock_qual_names == "")
   }
@@ -55,13 +55,16 @@ with_mock <- function(..., .env = topenv()) {
   lapply(mocks, set_mock)
 
   # Evaluate the code
-  ret <- invisible(NULL)
-  for (expression in code) {
-    ret <- eval(expression, parent.frame())
+  if (length(code) > 0) {
+    for (expression in code[-length(code)]) {
+      eval(expression, parent.frame())
+    }
+    # Isolate last item for visibility
+    eval(code[[length(code)]], parent.frame())
   }
-  ret
 }
 
+
 pkg_rx <- ".*[^:]"
 colons_rx <- "::(?:[:]?)"
 name_rx <- ".*"
@@ -77,6 +80,11 @@ extract_mocks <- function(new_values, .env, eval_env = parent.frame()) {
     function(qual_name) {
       pkg_name <- gsub(pkg_and_name_rx, "\\1", qual_name)
 
+      if (is_base_pkg(pkg_name)) {
+        stop("Can't mock functions in base packages (", pkg_name, ")",
+          call. = FALSE)
+      }
+
       name <- gsub(pkg_and_name_rx, "\\2", qual_name)
 
       if (pkg_name == "")
@@ -92,6 +100,10 @@ extract_mocks <- function(new_values, .env, eval_env = parent.frame()) {
   )
 }
 
+is_base_pkg <- function(x) {
+  x %in% rownames(installed.packages(priority = "base"))
+}
+
 mock <- function(name, env, new) {
   target_value <- get(name, envir = env, mode = "function")
   structure(list(

R/recover.R

@@ -27,7 +27,7 @@ recover2 <- function(start_frame = 1L, end_frame = sys.nframe())
 
   calls <- utils::limitedLabels(calls[start_frame:from])
   repeat {
-    which <- utils::menu(calls, title = "\nEnter a frame number, or 0 to exit  ")
+    which <- show_menu(calls, "\nEnter a frame number, or 0 to exit  ")
     if (which) {
       frame <- sys.frame(start_frame - 2 + which)
       browse_frame(frame, skip = 7 - which)
@@ -36,6 +36,10 @@ recover2 <- function(start_frame = 1L, end_frame = sys.nframe())
   }
 }
 
+show_menu <- function(choices, title = NULL) {
+  utils::menu(choices, title = title)
+}
+
 browse_frame <- function(frame, skip) {
   eval(substitute(browser(skipCalls = skip), list(skip = skip)),
        envir = frame)

R/reporter-debug.R

@@ -12,7 +12,7 @@ DebugReporter <- R6::R6Class("DebugReporter", inherit = Reporter,
   public = list(
     add_result = function(context, test, result) {
       if (!expectation_success(result)) {
-        if (sink.number() > 0) {
+        if (sink_number() > 0) {
           sink(self$out)
           on.exit(sink(), add = TRUE)
         }
@@ -23,3 +23,7 @@ DebugReporter <- R6::R6Class("DebugReporter", inherit = Reporter,
     }
   )
 )
+
+sink_number <- function() {
+  sink.number(type = "output")
+}

tests/testthat/test-debug-reporter.R

@@ -10,7 +10,7 @@ get_frame_from_debug_reporter <- function(choice, fun, envir = parent.frame()) {
   test_debug_reporter_parent_frame <- NULL
 
   with_mock(
-    `utils::menu` = function(choices, graphics = FALSE, title = NULL) {
+    show_menu = function(choices, title = NULL) {
       #if (choice > 0) print(choices)
       my_choice <- choice
       choice <<- 0L
@@ -19,7 +19,7 @@ get_frame_from_debug_reporter <- function(choice, fun, envir = parent.frame()) {
     browse_frame = function(frame, skip) {
       test_debug_reporter_parent_frame <<- frame
     },
-    `base::sink.number` = function() 0L,
+    sink_number = function() 0L,
     with_reporter(
       "debug",
       test_that("debug_reporter_test", fun())

tests/testthat/test-mock.R

@@ -41,66 +41,41 @@ test_that("nested mock", {
   expect_warning(warning("test"))
 })
 
-test_that("qualified mock names", {
-  with_mock(
-    expect_warning = expect_error,
-    `base::all.equal` = function(x, y, ...) TRUE,
-    {
-      expect_warning(stopifnot(!compare(3, "a")$equal))
-    }
-  )
-  with_mock(
-    `testthat::expect_warning` = expect_error,
-    all.equal = function(x, y, ...) TRUE,
-    {
-      expect_warning(stopifnot(!compare(3, "a")$equal))
-    },
-    .env = asNamespace("base")
-  )
-  expect_false(isTRUE(all.equal(3, 5)))
-  expect_warning(warning("test"))
-})
-
 test_that("can't mock non-existing", {
-  expect_error(with_mock(`base::..bogus..` = identity, TRUE), "Function [.][.]bogus[.][.] not found in environment base")
   expect_error(with_mock(..bogus.. = identity, TRUE), "Function [.][.]bogus[.][.] not found in environment testthat")
 })
 
 test_that("can't mock non-function", {
-  expect_error(with_mock(.bg_colours = FALSE, TRUE), "Function [.]bg_colours not found in environment testthat")
+  expect_error(with_mock(pkg_and_name_rx = FALSE, TRUE), "Function pkg_and_name_rx not found in environment testthat")
 })
 
 test_that("empty or no-op mock", {
-  suppressWarnings({
-    expect_that(with_mock(), equals(invisible(NULL)))
-    expect_that(with_mock(TRUE), equals(TRUE))
-    expect_that(with_mock(invisible(5)), equals(invisible(5)))
-  })
+  expect_warning(
+    expect_null(with_mock()),
+    "Not mocking anything. Please use named parameters to specify the functions you want to mock.",
+    fixed = TRUE
+  )
+  expect_warning(
+    expect_true(with_mock(TRUE)),
+    "Not mocking anything. Please use named parameters to specify the functions you want to mock.",
+    fixed = TRUE
+  )
+})
 
-  expect_that(with_mock(), gives_warning("Not mocking anything."))
-  expect_that(with_mock(TRUE), gives_warning("Not mocking anything."))
-  expect_that(with_mock(invisible(5)), gives_warning("Not mocking anything."))
+test_that("visibility", {
+  expect_warning(expect_false(withVisible(with_mock())$visible))
+  expect_true(withVisible(with_mock(compare = function() {}, TRUE))$visible)
+  expect_false(withVisible(with_mock(compare = function() {}, invisible(5)))$visible)
 })
 
 test_that("multiple return values", {
-  expect_true(with_mock(FALSE, TRUE, `base::identity` = identity))
-  expect_equal(with_mock(3, `base::identity` = identity, 5), 5)
+  expect_true(with_mock(FALSE, TRUE, compare = function() {}))
+  expect_equal(with_mock(3, compare = function() {}, 5), 5)
 })
 
 test_that("can access variables defined in function", {
   x <- 5
-  suppressWarnings(expect_equal(with_mock(x), 5))
-})
-
-test_that("can mock both qualified and unqualified functions", {
-  with_mock(`stats::acf` = identity, expect_identical(stats::acf, identity))
-  with_mock(`stats::acf` = identity, expect_identical(acf, identity))
-  with_mock(acf = identity, expect_identical(stats::acf, identity), .env = "stats")
-  with_mock(acf = identity, expect_identical(acf, identity), .env = "stats")
-})
-
-test_that("can mock hidden functions", {
-  with_mock(`stats:::add1.default` = identity, expect_identical(stats:::add1.default, identity))
+  expect_equal(with_mock(x, compare = function() {}), 5)
 })
 
 test_that("can mock if package is not loaded", {
@@ -113,38 +88,33 @@ test_that("can mock if package is not loaded", {
 test_that("changes to variables are preserved between calls and visible outside", {
   x <- 1
   with_mock(
-    `base::identity` = identity,
+    show_menu = function() {},
     x <- 3,
     expect_equal(x, 3)
   )
   expect_equal(x, 3)
 })
 
-test_that("can mock function imported from other package", {
-  with_mock(`testthat::setRefClass` = identity, expect_identical(setRefClass, identity))
-  with_mock(`methods::setRefClass` = identity, expect_identical(setRefClass, identity))
-})
-
 test_that("mock extraction", {
-  expect_identical(extract_mocks(list(identity = identity), asNamespace("base"))$identity$name, as.name("identity"))
-  expect_error(extract_mocks(list(..bogus.. = identity), asNamespace("base")),
-               "Function [.][.]bogus[.][.] not found in environment base")
-  expect_identical(extract_mocks(list(`base::identity` = identity), NULL)[[1]]$name, as.name("identity"))
-  expect_identical(extract_mocks(list(`base::identity` = identity), NULL)[[1]]$env, asNamespace("base"))
-  expect_identical(extract_mocks(list(identity = stop), "base")[[1]]$env, asNamespace("base"))
-  expect_identical(extract_mocks(list(identity = stop), asNamespace("base"))[[1]]$env, asNamespace("base"))
-  expect_identical(extract_mocks(list(`base::identity` = stop), NULL)[[1]]$orig_value, identity)
-  expect_identical(extract_mocks(list(`base::identity` = stop), NULL)[[1]]$new_value, stop)
-  expect_identical(extract_mocks(list(`base::identity` = stop), "stats")[[1]]$new_value, stop)
-  expect_identical(extract_mocks(list(acf = identity), "stats")[[1]]$new_value, identity)
-  expect_equal(length(extract_mocks(list(not = identity, `base::!` = identity), "testthat")), 2)
+  expect_identical(
+    extract_mocks(list(compare = compare), .env = asNamespace("testthat"))$compare$name,
+    as.name("compare")
+  )
+  expect_error(
+    extract_mocks(list(..bogus.. = identity), "testthat"),
+    "Function [.][.]bogus[.][.] not found in environment testthat"
+  )
+  expect_equal(
+    length(extract_mocks(list(not = identity, show_menu = identity), "testthat")),
+    2
+  )
 })
 
 test_that("mocks can access local variables", {
-  value <- TRUE
+  value <- compare(0, 0)
 
   with_mock(
     expect_equal(2 * 3, 4),
-    all.equal = function(x, y, ...) {value}
+    compare = function(x, y, ...) {value}
   )
 })

tests/testthat/test-reporter.R

@@ -57,12 +57,12 @@ test_that("reporters produce consistent output", {
   }
 
   with_mock(
-    `utils::menu` = function(choices, graphics = FALSE, title = NULL) {
+    show_menu = function(choices, title = NULL) {
       cat(paste0(format(seq_along(choices)), ": ", choices, sep = "\n"), "\n",
           sep = "")
       0L
     },
-    `base::sink.number` = function() 0L,
+    sink_number = function() 0L,
     save_report("debug")
   )
   save_report("check", error_regexp = NULL)