Mock in more environments

NEWS.md

@@ -20,11 +20,11 @@
 * New `vignette("special-files")` describes the various special files
   that testthat uses (#1638).
 
-* `with_mocked_bindings()` and `local_mocked_bindings()` can now bind in the
-  imports namespace too. This changes makes them very close in capability
-  for `with_mock()` and `local_mock()` so those functions now recommend
-  `with_mocked_bindings()` and `local_mocked_bindings()` rather than functions
-  from the mockr/mockery packages.
+* `with_mocked_bindings()` and `local_mocked_bindings()` now also bind in the
+  imports namespace and can mock S3 methods. These changes make them good 
+  substitutes for the deprecated functions `with_mock()` and `local_mock()`, so 
+  those older functions now recommend switching to the newer equivalents 
+  instead of using the mockr or mockery packages.
 
 # testthat 3.1.7
 

R/mock2.R

@@ -3,17 +3,96 @@
 #' @description
 #' `r lifecycle::badge("experimental")`
 #'
+#' `with_mocked_bindings()` and `local_mocked_bindings()` provide tools for
+#' "mocking", temporarily redefining a function so that it behaves differently
+#' during tests. This is helpful for testing functions that depend on external
+#' state (i.e. reading a value from a file or a website, or pretending a package
+#' is or isn't installed).
+#'
 #' These functions represent a second attempt at bringing mocking to testthat,
-#' incorporating what we've learned from the mockr, mockery, and mockthat package.
+#' incorporating what we've learned from the mockr, mockery, and mockthat
+#' packages.
+#'
+#' # Use
+#'
+#' There are four places that the function you are trying to mock might
+#' come from:
+#'
+#' * Internal to your package.
+#' * Imported from an external package via the `NAMESPACE`.
+#' * The base environment.
+#' * Called from an external package with `::`.
+#'
+#' They are described in turn below.
+#'
+#' ## Internal & imported functions
+#'
+#' You mock internal and imported functions the same way. For example, take
+#' this code:
+#'
+#' ```R
+#' some_function <- function() {
+#'   another_function()
+#' }
+#' ```
+#'
+#' It doesn't matter whether `another_function()` is defined by your package
+#' or you've imported it from a dependency with `@import` or `@importFrom`,
+#' you mock it the same way:
+#'
+#' ```R
+#' local_mocked_bindings(
+#'   another_function = function(...) "new_value"
+#' )
+#' ```
+#'
+#' ## Base functions
+#'
+#' Note that it's not possible to mock functions in the base namespace
+#' (i.e. functions that you can use without explicitly importing them)
+#' since currently we don't know of a way to to mock them without potentially
+#' affecting all running code. If you need to mock a base function, you'll
+#' need to create a wrapper, as described below.
+#'
+#' ## Namespaced calls
+#'
+#' It's trickier to mock functions in other packages that you call with `::`.
+#' For example, take this minor variation:
 #'
-#' `with_mocked_bindings()` and `local_mocked_bindings()` work by temporarily
-#' changing variable bindings in the namespace of namespace `.package`.
-#' Generally, it's only safe to mock packages that you own. If you mock other
-#' packages, we recommend using `skip_on_cran()` to avoid CRAN failures if the
-#' implementation changes.
+#' ```R
+#' some_function <- function() {
+#'   anotherpackage::another_function()
+#' }
+#' ```
 #'
-#' These functions do not currently affect registered S3 methods.
+#' To mock here, you'll need to modify `another_function()` inside the
+#' `anotherpackage` package. You _can_ do this by supplying the `.package`
+#' argument:
 #'
+#' ```R
+#' local_mocked_bindings(
+#'   another_function = function(...) "new_value",
+#'   .package = "anotherpackage"
+#' )
+#' ```
+#'
+#' But it's not a great idea to mock a namespace that you don't own because
+#' it affects all code in that package, not just code in your package. Instead,
+#' it's safer to either import the function into your package, or make a wrapper
+#' that you can mock:
+#'
+#' ```R
+#' some_function <- function() {
+#'   my_wrapper()
+#' }
+#' my_wrapper <- function(...) {
+#'   anotherpackage::another_function(...)
+#' }
+#'
+#' local_mocked_bindings(
+#'   my_wrapper = function(...) "new_value"
+#' )
+#' ```
 #' @export
 #' @param ... Name-value pairs providing functions to mock.
 #' @param code Code to execute with specified bindings.
@@ -30,15 +109,26 @@ local_mocked_bindings <- function(..., .package = NULL, .env = caller_env()) {
   .package <- .package %||% dev_package()
   ns_env <- ns_env(.package)
 
-  # Rebind, first looking in package namespace, then imports, then the base
-  # namespace, then the global environment
-  envs <- c(list(ns_env), env_parents(ns_env))
+  # Rebind in namespace, imports, and the global environment
+  envs <- list(ns_env, env_parent(ns_env), globalenv())
   bindings_found <- rep_named(names(bindings), FALSE)
   for (env in envs) {
-    this_bindings <- env_has(env, names(bindings)) & !bindings_found
+    local_bindings_rebind(!!!bindings, .env = env, .frame = .env)
+    bindings_found <- bindings_found | env_has(env, names(bindings))
+  }
 
-    local_bindings_unlock(!!!bindings[this_bindings], .env = env, .frame = .env)
-    bindings_found <- bindings_found | this_bindings
+  # And mock S3 methods
+  methods_env <- ns_env[[".__S3MethodsTable__."]]
+  local_bindings_rebind(!!!bindings, .env = methods_env, .frame = .env)
+
+  # If needed, also mock in the package environment so we can call directly
+  if (is_attached(paste0("package:", .package))) {
+    local_bindings_rebind(!!!bindings, .env = pkg_env(.package), .frame = .env)
+  }
+  # And in the current testing environment
+  test_env <- testthat_env$current_test_env
+  if (!is.null(test_env)) {
+    local_bindings_rebind(!!!bindings, .env = test_env, .frame = .env)
   }
 
   if (any(!bindings_found)) {
@@ -58,10 +148,13 @@ with_mocked_bindings <- function(code, ..., .package = NULL) {
 
 # helpers -----------------------------------------------------------------
 
-# Wrapper around local_bindings() that automatically unlocks and takes
-# list of bindings.
-local_bindings_unlock <- function(..., .env = .frame, .frame = caller_env()) {
+# Wrapper around local_bindings() that only rebinds existing values,
+# automatically unlocking as needed. We can only rebind because most of
+# these environments are locked, meaning we can't add new bindings.
+local_bindings_rebind <- function(..., .env = .frame, .frame = caller_env()) {
   bindings <- list2(...)
+  bindings <- bindings[env_has(.env, names(bindings))]
+
   if (length(bindings) == 0) {
     return()
   }
@@ -110,21 +203,21 @@ check_bindings <- function(x, error_call = caller_env()) {
 
 # For testing -------------------------------------------------------------
 
-test_mock_package <- function() {
-  test_mock_package2()
+test_mock_direct <- function() {
+  "y"
 }
-test_mock_package2 <- function() "y"
 
-test_mock_base <- function() {
-  identity("y")
+test_mock_internal <- function() {
+  test_mock_internal2()
 }
+test_mock_internal2 <- function() "y"
 
 test_mock_imports <- function() {
-  as.character(sym("x"))
+  as.character(sym("y"))
 }
 
 test_mock_namespaced <- function() {
-  as.character(rlang::sym("x"))
+  as.character(rlang::sym("y"))
 }
 
 test_mock_method <- function(x) {
@@ -134,3 +227,15 @@ test_mock_method <- function(x) {
 test_mock_method.integer <- function(x) {
   "y"
 }
+
+
+show_bindings <- function(name, env = caller_env()) {
+  envs <- env_parents(env)
+  has_binding <- Filter(function(env) env_has(env, name), envs)
+  lapply(has_binding, env_desc)
+  invisible()
+}
+
+env_desc <- function(env) {
+  cat(obj_address(env), ": ", env_name(env), "\n", sep = "")
+}

R/parallel.R

@@ -222,6 +222,9 @@ queue_process_setup <- function(test_package, test_dir, load_helpers, load_packa
     test_dir,
     load_package
   )
+  # record testing env for mocks
+  local_bindings(current_test_env = env, .env = testthat_env)
+
   asNamespace("testthat")$test_files_setup_state(
     test_dir = test_dir,
     test_package = test_package,

R/skip.R

@@ -202,11 +202,16 @@ skip_on_bioc <- function() {
 #' @rdname skip
 skip_if_translated <- function(msgid = "'%s' not found") {
   skip_if(
-    gettext(msgid, domain = "R") != msgid,
+    gettext(msgid) != msgid,
     paste0("\"", msgid, "\" is translated")
   )
 }
 
+gettext <- function(msgid, domain = "R") {
+  base::gettext(msgid, domain = domain)
+}
+
+
 #' Superseded skip functions
 #'
 #' @description

R/test-files.R

@@ -190,6 +190,9 @@ test_files_serial <- function(test_dir,
                        load_package = c("none", "installed", "source")) {
 
   env <- test_files_setup_env(test_package, test_dir, load_package, env)
+  # record testing env for mocks
+  local_bindings(current_test_env = env, .env = testthat_env)
+
   test_files_setup_state(test_dir, test_package, load_helpers, env)
   reporters <- test_files_reporter(reporter)
 

tests/testthat/test-mock.R

@@ -7,18 +7,18 @@ test_that("can change value of internal function", {
   local_edition(2)
 
   with_mock(
-    test_mock_package2 = function() 5,
-    expect_equal(test_mock_package(), 5)
+    test_mock_internal2 = function() 5,
+    expect_equal(test_mock_internal(), 5)
   )
 
   # and value is restored on error
   expect_error(
     with_mock(
-      test_mock_package2 = function() 5,
+      test_mock_internal2 = function() 5,
       stop("!")
     )
   )
-  expect_equal(test_mock_package(), "y")
+  expect_equal(test_mock_internal(), "y")
 })
 
 
@@ -27,8 +27,8 @@ test_that("mocks can access local variables", {
   x <- 5
 
   with_mock(
-    test_mock_package2 = function() x,
-    expect_equal(test_mock_package(), 5)
+    test_mock_internal2 = function() x,
+    expect_equal(test_mock_internal(), 5)
   )
 })