Lean into localCheck() + use minimal defer()

DESCRIPTION

@@ -16,13 +16,12 @@ URL: https://github.com/rstudio/pool, http://rstudio.github.io/pool/
 BugReports: https://github.com/rstudio/pool/issues
 Depends:
     methods,
-    R (>= 3.0.0)
+    R (>= 3.6.0)
 Imports:
     DBI,
     later (>= 1.0.0),
     R6,
-    rlang (>= 1.0.0),
-    withr
+    rlang (>= 1.0.0)
 Suggests:
     covr,
     dbplyr (>= 2.0.0),
@@ -40,4 +39,4 @@ Config/Needs/website: tidyverse/tidytemplate
 Config/testthat/edition: 3
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.0

NAMESPACE

@@ -61,5 +61,6 @@ exportMethods(sqlParseVariables)
 import(DBI)
 import(methods)
 import(rlang)
+importFrom(DBI,dbBreak)
 importFrom(R6,R6Class)
 importFrom(later,later)

NEWS.md

@@ -1,5 +1,7 @@
 # pool (development version)
 
+* No longer depends on the withr package, by instead requiring R 3.6.
+
 * Add wrappers for dbplyr generics `db_col_types()` (#171) and 
   `db_copy_to()` (#172).
 

R/DBI-transactions.R

@@ -78,8 +78,7 @@
 #'   message("Please install the 'RSQLite' package to run this example")
 #' }
 poolWithTransaction <- function(pool, func) {
-  conn <- poolCheckout(pool)
-  on.exit(poolReturn(conn))
+  conn <- localCheckout(pool)
   DBI::dbWithTransaction(conn, func(conn))
 }
 

R/DBI-wrap.R

@@ -68,8 +68,7 @@ DBI_wrap <- function(fun_name) {
   recall <- call2(ns_fun, !!!call_args)
 
   body <- expr({
-    db_con <- poolCheckout(!!con_arg)
-    on.exit(poolReturn(db_con))
+    db_con <- localCheckout(!!con_arg)
 
     !!recall
   })

R/dbplyr.R

@@ -48,8 +48,7 @@ copy_to.Pool <- function(dest,
   }
 
   local({
-    db_con <- poolCheckout(dest)
-    on.exit(poolReturn(db_con))
+    db_con <- localCheckout(dest)
 
     dplyr::copy_to(
       dest = db_con,
@@ -115,8 +114,7 @@ dbplyr_wrap <- function(fun_name) {
   body <- expr({
     !!!temporary
 
-    db_con <- poolCheckout(con)
-    on.exit(poolReturn(db_con))
+    db_con <- localCheckout(con)
 
     !!recall
   })

R/pool-methods.R

@@ -119,6 +119,6 @@ setMethod("poolReturn", "ANY", function(object) {
 #'   use only.
 localCheckout <- function(pool, env = parent.frame()) {
   obj <- poolCheckout(pool)
-  withr::defer(poolReturn(obj), envir = env)
+  defer(poolReturn(obj), envir = env)
   obj
 }

R/utils.R

@@ -20,3 +20,8 @@ pool_metadata <- function(x,
   meta
 }
 
+# Lightweight equivalent of withr::defer()
+defer <- function(expr, envir = parent.frame(), after = FALSE) {
+  thunk <- as.call(list(function() expr))
+  do.call(on.exit, list(thunk, TRUE, after), envir = envir)
+}

tests/testthat/_snaps/DBI-wrap.md

@@ -5,8 +5,7 @@
     Output
       function (conn, statement, ...) 
       {
-          db_con <- poolCheckout(conn)
-          on.exit(poolReturn(db_con))
+          db_con <- localCheckout(conn)
           DBI::dbExecute(conn = db_con, statement = statement, ... = ...)
       }
       <environment: namespace:pool>

tests/testthat/_snaps/dbplyr.md

@@ -35,8 +35,7 @@
     Output
       function (con, sql, n = -1, warn_incomplete = TRUE, ...) 
       {
-          db_con <- poolCheckout(con)
-          on.exit(poolReturn(db_con))
+          db_con <- localCheckout(con)
           dbplyr::db_collect(con = db_con, sql = sql, n = n, warn_incomplete = warn_incomplete, 
               ... = ...)
       }
@@ -50,8 +49,7 @@
           in_transaction = TRUE) 
       {
           stop_if_temporary(temporary)
-          db_con <- poolCheckout(con)
-          on.exit(poolReturn(db_con))
+          db_con <- localCheckout(con)
           dbplyr::db_compute(con = db_con, table = table, sql = sql, 
               ... = ..., overwrite = overwrite, temporary = temporary, 
               unique_indexes = unique_indexes, indexes = indexes, analyze = analyze, 

tests/testthat/helper.R

@@ -1,6 +1,6 @@
 local_db_pool <- function(env = parent.frame()) {
   pool <- dbPool(RSQLite::SQLite())
-  withr::defer(poolClose(pool), envir = env)
+  defer(poolClose(pool), envir = env)
   pool
 }
 

tests/testthat/test-DBI.R

@@ -2,7 +2,7 @@ test_that("can set options on creation", {
   pool <- dbPool(RSQLite::SQLite(), onCreate = function(con) {
     DBI::dbExecute(con, "PRAGMA journal_mode = TRUNCATE")
   })
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   res <- DBI::dbGetQuery(pool, "PRAGMA journal_mode")[[1]]
   expect_equal(res, "truncate")

tests/testthat/test-hooks.R

@@ -3,8 +3,7 @@ test_that("onValidate() caches query", {
   # reset cache from initial creation + validation
   pool$state$validateQuery <- NULL
 
-  con <- poolCheckout(pool)
-  withr::defer(poolReturn(con))
+  con <- localCheckout(pool)
   onValidate(con)
   expect_equal(pool$state$validateQuery, "SELECT 1")
 })

tests/testthat/test-pool-methods.R

@@ -1,6 +1,6 @@
 test_that("localCheckout works", {
   pool <- poolCreate(function(x) 1)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   f <- function() {
     localCheckout(pool)

tests/testthat/test-pool.R

@@ -27,7 +27,7 @@ test_that("pool can't fetch or close after close", {
 
 test_that("can fetch and release", {
   pool <- poolCreate(function() 1)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   obj <- poolCheckout(pool)
   expect_equal(obj, 1, ignore_attr = TRUE)
@@ -39,7 +39,7 @@ test_that("can fetch and release", {
 
 test_that("max size is enforced", {
   pool <- poolCreate(MockPooledObj$new, maxSize = 2)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   obj1 <- poolCheckout(pool)
   obj2 <- poolCheckout(pool)
@@ -52,7 +52,7 @@ test_that("max size is enforced", {
 
 test_that("idle objects are reaped", {
   pool <- poolCreate(MockPooledObj$new, idleTimeout = 0)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   obj1 <- poolCheckout(pool)
   obj2 <- poolCheckout(pool)
@@ -66,7 +66,7 @@ test_that("idle objects are reaped", {
 
 test_that("validates (only) when needed", {
   pool <- poolCreate(MockPooledObj$new, validationInterval = 0.1)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   last_validated <- function(pool) {
     obj <- localCheckout(pool)
@@ -89,7 +89,7 @@ test_that("validates (only) when needed", {
 
 test_that("warns if validation fails once, creates new object and tries again", {
   pool <- poolCreate(MockPooledObj$new, validationInterval = 0.1)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   check_valid_object <- function(x) {
     # Sneak into private methods
@@ -111,7 +111,7 @@ test_that("warns if validation fails once, creates new object and tries again",
 
   # now force all validations to fail so we get an error
   failOnValidate <<- TRUE
-  withr::defer(failOnValidate <<- FALSE)
+  defer(failOnValidate <<- FALSE)
 
   Sys.sleep(pool$validationInterval + .1)
   expect_snapshot(check_valid_object(obj), error = TRUE)
@@ -123,7 +123,7 @@ test_that("warns if validation fails once, creates new object and tries again",
 
 test_that("can't return the same object twice", {
   pool <- poolCreate(MockPooledObj$new)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   obj <- poolCheckout(pool)
   poolReturn(obj)
@@ -155,7 +155,7 @@ test_that("poolReturn() errors if object is not valid", {
 
 test_that("pool has useful print method", {
   pool <- poolCreate(function() 10)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   expect_snapshot({
     pool
@@ -173,7 +173,7 @@ test_that("pool has useful print method", {
 
 test_that("empty pool has useful print method", {
   pool <- poolCreate(function() 10, minSize = 0)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   expect_snapshot({
     pool
@@ -184,11 +184,11 @@ test_that("empty pool has useful print method", {
 
 test_that("useful warning if onDestroy fails", {
   pool <- poolCreate(MockPooledObj$new, idleTimeout = 0)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   checkCounts(pool, free = 1, taken = 0)
   failOnDestroy <<- TRUE
-  withr::defer(failOnDestroy <<- FALSE)
+  defer(failOnDestroy <<- FALSE)
 
   a <- poolCheckout(pool)
   b <- poolCheckout(pool)
@@ -205,32 +205,32 @@ test_that("useful warning if onDestroy fails", {
 
 test_that("throws if onPassivate fails", {
   pool <- poolCreate(MockPooledObj$new)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   obj <- poolCheckout(pool)
   failOnPassivate <<- TRUE
-  withr::defer(failOnPassivate <<- FALSE)
+  defer(failOnPassivate <<- FALSE)
 
   expect_snapshot(poolReturn(obj), error = TRUE)
 })
 
 test_that("throws if onActivate fails", {
   pool <- poolCreate(MockPooledObj$new)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   failOnActivate <<- TRUE
-  withr::defer(failOnActivate <<- FALSE)
+  defer(failOnActivate <<- FALSE)
 
   expect_snapshot(poolCheckout(pool), error = TRUE)
   checkCounts(pool, free = 0, taken = 0)
 })
 
 test_that("throws if onValidate fails", {
   pool <- poolCreate(MockPooledObj$new)
-  withr::defer(poolClose(pool))
+  defer(poolClose(pool))
 
   failOnValidate <<- TRUE
-  withr::defer(failOnValidate <<- FALSE)
+  defer(failOnValidate <<- FALSE)
   expect_snapshot(poolCheckout(pool), error = TRUE)
   checkCounts(pool, free = 0, taken = 0)
 })