Use our own fake functions

tests/testthat/helper-mock.R

@@ -0,0 +1,110 @@
+fake <- local({
+  fake_through_tree <- function(tree, what, how) {
+    for (d in tree) {
+      for (parent in d) {
+        parent_env <- parent[["parent_env"]]
+        func_dict <- parent[["funcs"]]
+        for (func_name in ls(func_dict, all.names = TRUE)) {
+          func <- func_dict[[func_name]]
+          func_env <- new.env(parent = environment(func))
+
+          what <- override_seperators(what, func_env)
+          where_name <- override_seperators(func_name, parent_env)
+
+          if (!is.function(how)) {
+            assign(what, function(...) how, func_env)
+          } else {
+            assign(what, how, func_env)
+          }
+
+          environment(func) <- func_env
+          locked <- exists(where_name, parent_env, inherits = FALSE) &&
+            bindingIsLocked(where_name, parent_env)
+          if (locked) {
+            baseenv()$unlockBinding(where_name, parent_env)
+          }
+          assign(where_name, func, parent_env)
+          if (locked) {
+            lockBinding(where_name, parent_env)
+          }
+        }
+      }
+    }
+  }
+
+  override_seperators <- function(name, env) {
+    mangled_name <- NULL
+    for (sep in c("::", "$")) {
+      if (grepl(sep, name, fixed = TRUE)) {
+        elements <- strsplit(name, sep, fixed = TRUE)
+        mangled_name <- paste(
+          elements[[1L]][1L],
+          elements[[1L]][2L],
+          sep = "XXX"
+        )
+
+        stub_list <- c(mangled_name)
+        if ("stub_list" %in% names(attributes(get(sep, env)))) {
+          stub_list <- c(stub_list, attributes(get(sep, env))[["stub_list"]])
+        }
+
+        create_new_name <- create_create_new_name_function(
+          stub_list,
+          env,
+          sep
+        )
+        assign(sep, create_new_name, env)
+      }
+    }
+    mangled_name %||% name
+  }
+
+  backtick <- function(x) {
+    encodeString(x, quote = "`", na.encode = FALSE)
+  }
+
+  create_create_new_name_function <- function(stub_list, env, sep) {
+    force(stub_list)
+    force(env)
+    force(sep)
+
+    create_new_name <- function(pkg, func) {
+      pkg_name <- deparse(substitute(pkg))
+      func_name <- deparse(substitute(func))
+      for (stub in stub_list) {
+        if (paste(pkg_name, func_name, sep = "XXX") == stub) {
+          return(eval(parse(text = backtick(stub)), env))
+        }
+      }
+
+      # used to avoid recursively calling the replacement function
+      eval_env <- new.env(parent = parent.frame())
+      assign(sep, eval(parse(text = paste0("`", sep, "`"))), eval_env)
+
+      code <- paste(pkg_name, backtick(func_name), sep = sep)
+      return(eval(parse(text = code), eval_env))
+    }
+    attributes(create_new_name) <- list(stub_list = stub_list)
+    create_new_name
+  }
+
+  build_function_tree <- function(test_env, where, where_name) {
+    func_dict <- new.env()
+    func_dict[[where_name]] <- where
+    tree <- list(
+      list(
+        list(parent_env = test_env, funcs = func_dict)
+      )
+    )
+
+    tree
+  }
+
+  fake <- function(where, what, how) {
+    where_name <- deparse(substitute(where))
+    stopifnot(is.character(what), length(what) == 1)
+    test_env <- parent.frame()
+    tree <- build_function_tree(test_env, where, where_name)
+    fake_through_tree(tree, what, how)
+  }
+})

tests/testthat/test-platform.R

@@ -110,11 +110,11 @@ test_that("platform_match", {
 
 test_that("check_platform", {
   # load_all() is fine without data
-  local_mocked_bindings(file.exists = function(...) FALSE)
+  fake(check_platform, "file.exists", function(...) FALSE)
   expect_silent(check_platform(".", "."))
 
   # during installation?
-  local_mocked_bindings(file.exists = function(...) TRUE)
+  fake(check_platform, "file.exists", function(...) TRUE)
   withr::with_envvar(
     c(R_PACKAGE_DIR = "foobar"),
     expect_silent(check_platform(".", "."))

tests/testthat/test-repo.R

@@ -53,9 +53,7 @@ test_that("Old URL", {
     for (i in seq_len(nrow(tsts))) {
       cu <- get_curl(repo, tsts$pkg_type[i], tsts$rver[i])
       av <- available.packages(cu, filters = list(), ignore_repo_cache = TRUE)
-      local_mocked_bindings(
-        getRversion = function() package_version(tsts$rver[i])
-      )
+      fake(rver_flt, "getRversion", package_version(tsts$rver[i]))
       res <- rver_flt(av)
 
       expect_equal(nrow(res), 1L)
@@ -115,9 +113,7 @@ test_that("New URL", {
 
       cu <- get_curl(repo, tsts$pkg_type[i], tsts$rver[i])
       av <- available.packages(cu, filters = list(), ignore_repo_cache = TRUE)
-      local_mocked_bindings(
-        getRversion = function() package_version(tsts$rver[i])
-      )
+      fake(rver_flt, "getRversion", package_version(tsts$rver[i]))
       res <- rver_flt(av)
 
       expect_equal(nrow(res), 1L)