Deprecate old mocking functions

hadley · hadley · commit aeaa1c7fb5d8 · 2024-08-23T16:42:40.000-05:00
diff --git a/NEWS.md b/NEWS.md
diff --git a/R/mock.R b/R/mock.R
@@ -1,14 +1,12 @@
 #' Mock functions in a package.
 #'
 #' @description
-#' `r lifecycle::badge("superseded")`
-#'
-#' `with_mock()` and `local_mock()` are superseded in favour of
+#' `with_mock()` and `local_mock()` are deprecated in favour of
 #' [with_mocked_bindings()] and [local_mocked_bindings()].
 #'
-#' These works by using some C code to temporarily modify the mocked function
-#' _in place_. This is abusive of R's internals, which makes it dangerous, and
-#' no longer recommended.
+#' These functions worked by using some C code to temporarily modify the mocked
+#'  function _in place_. This was an abuse of R's internals and it is no longer
+#' permitted.
 #'
 #' @section 3rd edition:
 #' `r lifecycle::badge("deprecated")`
@@ -26,116 +24,11 @@
 #' @return The result of the last unnamed parameter
 #' @export
 with_mock <- function(..., .env = topenv()) {
-  edition_deprecate(3, "with_mock()", "Please use with_mocked_bindings() instead")
-
-  dots <- eval(substitute(alist(...)))
-  mock_qual_names <- names(dots)
-
-  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 <- rep(TRUE, length(dots))
-  } else {
-    code_pos <- (mock_qual_names == "")
-  }
-  code <- dots[code_pos]
-
-  mock_funs <- lapply(dots[!code_pos], eval, parent.frame())
-  mocks <- extract_mocks(mock_funs, .env = .env)
-
-  on.exit(lapply(mocks, reset_mock), add = TRUE)
-  lapply(mocks, set_mock)
-
-  # Evaluate the code
-  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())
-  }
+  lifecycle::deprecate_stop("3.3.0", "with_mock()", "with_mocked_bindings()")
 }
 
 #' @export
 #' @rdname with_mock
 local_mock <- function(..., .env = topenv(), .local_envir = parent.frame()) {
-  edition_deprecate(3, "local_mock()", "Please use local_mocked_bindings() instead")
-
-  mocks <- extract_mocks(list(...), .env = .env)
-  on_exit <- bquote(
-    on.exit(lapply(.(mocks), .(reset_mock)), add = TRUE),
-  )
-
-  lapply(mocks, set_mock)
-  eval_bare(on_exit, .local_envir)
-  invisible()
-}
-
-pkg_rx <- ".*[^:]"
-colons_rx <- "::(?:[:]?)"
-name_rx <- ".*"
-pkg_and_name_rx <- sprintf("^(?:(%s)%s)?(%s)$", pkg_rx, colons_rx, name_rx)
-
-extract_mocks <- function(funs, .env) {
-  if (is.environment(.env)) {
-    .env <- environmentName(.env)
-  }
-  mock_qual_names <- names(funs)
-
-  lapply(
-    stats::setNames(nm = mock_qual_names),
-    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 == "") {
-        pkg_name <- .env
-      }
-
-      env <- asNamespace(pkg_name)
-
-      if (!exists(name, envir = env, mode = "function")) {
-        stop("Function ", name, " not found in environment ",
-          environmentName(env), ".",
-          call. = FALSE
-        )
-      }
-      mock(name = name, env = env, new = funs[[qual_name]])
-    }
-  )
-}
-
-mock <- function(name, env, new) {
-  target_value <- get(name, envir = env, mode = "function")
-  structure(
-    list(
-      env = env,
-      name = as.name(name),
-      orig_value = .Call(duplicate_, target_value), target_value = target_value,
-      new_value = new
-    ),
-    class = "mock"
-  )
-}
-
-set_mock <- function(mock) {
-  .Call(reassign_function, mock$name, mock$env, mock$target_value, mock$new_value)
-}
-
-reset_mock <- function(mock) {
-  .Call(reassign_function, mock$name, mock$env, mock$target_value, mock$orig_value)
-}
-
-is_base_pkg <- function(x) {
-  x %in% rownames(utils::installed.packages(priority = "base"))
+  lifecycle::deprecate_stop("3.3.0", "local_mock()", "local_mocked_bindings()")
 }
diff --git a/src/init.c b/src/init.c
@@ -4,13 +4,9 @@
 #include <R_ext/Rdynload.h>
 
 /* .Call calls */
-extern SEXP duplicate_(SEXP);
-extern SEXP reassign_function(SEXP, SEXP, SEXP, SEXP);
 extern SEXP run_testthat_tests(SEXP);
 
 static const R_CallMethodDef CallEntries[] = {
-    {"duplicate_",         (DL_FUNC) &duplicate_,         1},
-    {"reassign_function",  (DL_FUNC) &reassign_function,  4},
     {"run_testthat_tests", (DL_FUNC) &run_testthat_tests, 1},
     {NULL, NULL, 0}
 };
diff --git a/src/reassign.c b/src/reassign.c
diff --git a/tests/testthat/_snaps/R4.4/snapshot-file/version.txt b/tests/testthat/_snaps/R4.4/snapshot-file/version.txt
@@ -0,0 +1 @@
+R4.4
diff --git a/tests/testthat/_snaps/R4.4/snapshot.md b/tests/testthat/_snaps/R4.4/snapshot.md
@@ -0,0 +1,7 @@
+# variants save different values
+
+    Code
+      r_version()
+    Output
+      [1] "R4.4"
+
diff --git a/tests/testthat/_snaps/mock.md b/tests/testthat/_snaps/mock.md
@@ -0,0 +1,15 @@
+# now defunct
+
+    Code
+      local_mock()
+    Condition
+      Error:
+      ! `local_mock()` was deprecated in testthat 3.3.0 and is now defunct.
+      i Please use `local_mocked_bindings()` instead.
+    Code
+      with_mock(is_testing = function() FALSE)
+    Condition
+      Error:
+      ! `with_mock()` was deprecated in testthat 3.3.0 and is now defunct.
+      i Please use `with_mocked_bindings()` instead.
+
diff --git a/tests/testthat/test-examples.R b/tests/testthat/test-examples.R
@@ -1,7 +1,5 @@
 test_that("test_examples works with installed packages", {
-  local_edition(2)
-
-  local_mock(test_rd = identity)
+  local_mocked_bindings(test_rd = identity)
   expect_true(length(test_examples()) > 1)
 })
 
diff --git a/tests/testthat/test-mock.R b/tests/testthat/test-mock.R
@@ -1,150 +1,6 @@
-test_that("deprecated in 3rd edition", {
-  expect_warning(local_mock(), "deprecated")
-  expect_warning(with_mock(is_testing = function() FALSE), "deprecated")
-})
-
-test_that("can change value of internal function", {
-  local_edition(2)
-
-  with_mock(
-    test_mock_internal2 = function() 5,
-    expect_equal(test_mock_internal(), 5)
-  )
-
-  # and value is restored on error
-  expect_error(
-    with_mock(
-      test_mock_internal2 = function() 5,
-      stop("!")
-    )
-  )
-  expect_equal(test_mock_internal(), "y")
-})
-
-
-test_that("mocks can access local variables", {
-  local_edition(2)
-  x <- 5
-
-  with_mock(
-    test_mock_internal2 = function() x,
-    expect_equal(test_mock_internal(), 5)
-  )
-})
-
-test_that("non-empty mock with return value", {
-  local_edition(2)
-  expect_true(with_mock(
-    compare = function(x, y, ...) list(equal = TRUE, message = "TRUE"),
-    TRUE
-  ))
-})
-
-test_that("nested mock", {
-  local_edition(2)
-  with_mock(
-    all.equal = function(x, y, ...) TRUE,
-    {
-      with_mock(
-        expect_warning = expect_error,
-        {
-          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", {
-  local_edition(2)
-  expect_error(with_mock(..bogus.. = identity, TRUE), "Function [.][.]bogus[.][.] not found in environment testthat")
-})
-
-test_that("can't mock non-function", {
-  local_edition(2)
-  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", {
-  local_edition(2)
-  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
-  )
-})
-
-test_that("visibility", {
-  local_edition(2)
-  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", {
-  local_edition(2)
-  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", {
-  local_edition(2)
-  x <- 5
-  expect_equal(with_mock(x, compare = function() {}), 5)
-})
-
-test_that("can mock if package is not loaded", {
-  local_edition(2)
-  if ("package:curl" %in% search()) {
-    skip("curl is loaded")
-  }
-  skip_if_not_installed("curl")
-  with_mock(`curl::curl` = identity, expect_identical(curl::curl, identity))
-})
-
-test_that("changes to variables are preserved between calls and visible outside", {
-  local_edition(2)
-  x <- 1
-  with_mock(
-    show_menu = function() {},
-    x <- 3,
-    expect_equal(x, 3)
-  )
-  expect_equal(x, 3)
-})
-
-test_that("mock extraction", {
-  local_edition(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
-  )
-})
-# local_mock --------------------------------------------------------------
-
-test_that("local_mock operates locally", {
-  local_edition(2)
-  f <- function() {
-    local_mock(compare = function(x, y) FALSE)
-    compare(1, 1)
-  }
-
-  expect_false(f())
-  expect_equal(compare(1, 1), no_difference())
+test_that("now defunct", {
+  expect_snapshot(error = TRUE, {
+    local_mock()
+    with_mock(is_testing = function() FALSE)
+  })
 })
diff --git a/tests/testthat/test-reporter-debug.R b/tests/testthat/test-reporter-debug.R
@@ -1,7 +1,7 @@
 test_that("produces consistent output", {
   withr::local_options(testthat.edition_ignore = TRUE)
   local_edition(2)
-  local_mock(
+  local_mocked_bindings(
     show_menu = function(choices, title = NULL) {
       cat(paste0(format(seq_along(choices)), ": ", choices, sep = "\n"), "\n", sep = "")
       0L
@@ -22,7 +22,7 @@ get_frame_from_debug_reporter <- function(choice, fun, envir = parent.frame()) {
   force(choice)
   test_debug_reporter_parent_frame <- NULL
 
-  with_mock(
+  with_mocked_bindings(
     show_menu = function(choices, title = NULL) {
       # if (choice > 0) print(choices)
       my_choice <- choice
@@ -178,4 +178,3 @@ test_that("browser() is called for the correct frame for skips", {
   expect_equal(get_vars_from_debug_reporter(3, fun_3), "g")
   expect_equal(get_vars_from_debug_reporter(4, fun_3), character())
 })
-
