Re-enter the mocking game (#1739)

Author: hadley

DESCRIPTION

@@ -56,4 +56,4 @@ Config/testthat/edition: 3
 Config/testthat/start-first: watcher, parallel*
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE, r6 = FALSE)
-RoxygenNote: 7.2.1.9000
+RoxygenNote: 7.2.3

NAMESPACE

@@ -15,6 +15,7 @@ S3method(format,expectation_success)
 S3method(format,mismatch_character)
 S3method(format,mismatch_numeric)
 S3method(is_informative_error,default)
+S3method(mockable_generic,integer)
 S3method(output_replay,character)
 S3method(output_replay,error)
 S3method(output_replay,message)
@@ -148,6 +149,7 @@ export(is_testing)
 export(is_true)
 export(local_edition)
 export(local_mock)
+export(local_mocked_bindings)
 export(local_reproducible_output)
 export(local_snapshotter)
 export(local_test_context)
@@ -210,6 +212,7 @@ export(use_catch)
 export(verify_output)
 export(watch)
 export(with_mock)
+export(with_mocked_bindings)
 export(with_reporter)
 import(rlang)
 importFrom(R6,R6Class)

NEWS.md

@@ -1,5 +1,8 @@
 # testthat (development version)
 
+* Experimental new `with_mocked_bindings()` and `local_mocked_bindings()` 
+  (#1739).
+
 # testthat 3.1.6
 
 * The embedded version of Catch no longer uses `sprintf()`.

R/mock2.R

@@ -0,0 +1,91 @@
+#' Mocking tools
+#'
+#' @description
+#' `r lifecycle::badge("experimental")`
+#'
+#' These functions represent a second attempt at bringing mocking to testthat,
+#' incorporating what we've learned from the mockr, mockery, and mockthat package.
+#'
+#' `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.
+#'
+#' These functions do not currently affect registered S3 methods.
+#'
+#' @export
+#' @param ... Name-value pairs providing functions to mock.
+#' @param code Code to execute with specified bindings.
+#' @param .env Environment that defines effect scope. For expert use only.
+#' @param .package The name of the package where mocked functions should be
+#'   inserted. Generally, you should not need to supply this as it will be
+#'   automatically detected when whole package tests are run or when there's
+#'   one package under active development (i.e. loaded with
+#'   [pkgload::load_all()]).
+local_mocked_bindings <- function(..., .package = NULL, .env = caller_env()) {
+  bindings <- list2(...)
+  check_bindings(bindings)
+
+  .package <- .package %||% dev_package()
+  ns_env <- ns_env(.package)
+
+  # Unlock bindings and set values
+  nms <- names(bindings)
+  locked <- env_binding_unlock(ns_env, nms)
+  withr::defer(env_binding_lock(ns_env, nms[locked]), envir = .env)
+  local_bindings(!!!bindings, .env = ns_env, .frame = .env)
+
+  invisible()
+}
+
+#' @rdname local_mocked_bindings
+#' @export
+with_mocked_bindings <- function(code, ..., .package = NULL) {
+  local_mocked_bindings(..., .package = .package)
+  code
+}
+
+# helpers -----------------------------------------------------------------
+
+dev_package <- function() {
+  if (is_testing() && testing_package() != "") {
+    testing_package()
+  } else {
+    loaded <- loadedNamespaces()
+    is_dev <- map_lgl(loaded, function(x) !is.null(pkgload::dev_meta(x)))
+    if (sum(is_dev) == 0) {
+      cli::cli_abort("No packages loaded with pkgload")
+    } else if (sum(is_dev) == 1) {
+      loaded[is_dev]
+    } else {
+      cli::cli_abort("Multiple packages loaded with pkgload")
+    }
+  }
+}
+
+check_bindings <- function(x, error_call = caller_env()) {
+  if (!is_named(x)) {
+    cli::cli_abort(
+      "All elements of {.arg ...} must be named.",
+      call = error_call
+    )
+  }
+
+  is_fun <- map_lgl(x, is.function)
+  if (!any(is_fun)) {
+    cli::cli_abort(
+      "All elements of {.arg ...} must be functions.",
+      call = error_call
+    )
+  }
+}
+
+# In package
+mockable_generic <- function(x) {
+  UseMethod("mockable_generic")
+}
+#' @export
+mockable_generic.integer <- function(x) {
+  1
+}

_pkgdown.yml

@@ -64,6 +64,10 @@ reference:
   contents:
   - ends_with("Reporter")
 
+- title: Mocking
+  contents:
+  - with_mocked_bindings
+
 - title: Expectation internals
   contents:
   - expect

man/local_mocked_bindings.Rd

@@ -0,0 +1,13 @@
+# with_mocked_bindings() validates its inputs
+
+    Code
+      with_mocked_bindings(1 + 1, function() 2)
+    Condition
+      Error in `local_mocked_bindings()`:
+      ! All elements of `...` must be named.
+    Code
+      with_mocked_bindings(1 + 1, x = 2)
+    Condition
+      Error in `local_mocked_bindings()`:
+      ! All elements of `...` must be functions.
+

tests/testthat/_snaps/mock2.md

@@ -0,0 +1,45 @@
+test_that("with_mocked_bindings affects local bindings", {
+  out <- with_mocked_bindings(test_mock1(), test_mock2 = function() "x")
+  expect_equal(out, "x")
+
+  expect_equal(test_mock1(), 10)
+})
+
+test_that("local_mocked_bindings affects local bindings", {
+  local({
+    local_mocked_bindings(test_mock2 = function() "x")
+    expect_equal(test_mock1(), "x")
+  })
+
+  expect_equal(test_mock1(), 10)
+})
+
+test_that("local_mocked_bindings affects S3 methods", {
+  skip("currently fails")
+
+  local({
+    local_mocked_bindings(mockable_generic.integer = function(x) 2)
+    expect_equal(mockable_generic(1L), 2)
+  })
+  expect_equal(mockable_generic(1L), 1)
+})
+
+test_that("can make wrapper", {
+  local_mock_x <- function(env = caller_env()) {
+    local_mocked_bindings(test_mock2 = function() "x", .env = env)
+  }
+
+  local({
+    local_mock_x()
+    expect_equal(test_mock1(), "x")
+  })
+
+  expect_equal(test_mock1(), 10)
+})
+
+test_that("with_mocked_bindings() validates its inputs", {
+  expect_snapshot(error = TRUE, {
+    with_mocked_bindings(1 + 1, function() 2)
+    with_mocked_bindings(1 + 1, x = 2)
+  })
+})