Merge branch 'f-#129-infra'

- Internal consistency checks (#114). - Added tests for invalid or closed connection argument to all methods that expect a connection as first argument (#117). - Skip patterns that don't match any of the tests now raise a warning (#84). - New `test_some()` to test individual tests (#136). - Use desc instead of devtools (#40). - All unexpected warnings are now reported as test failures (#113). - The return value for all calls to `dbGetQuery()`, `dbFetch()`, and `dbReadTable()` is now checked for consistency (all columns have the same length, length matches number of rows) (#126). - Removed stress tests that start a new session.
r-dbi · Apr 21, 2017 · 13dc482 · 13dc482
2 parents be3fce5 + 0eb487c
commit 13dc482
Show file tree

Hide file tree

Showing 48 changed files with 513 additions and 352 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -12,13 +12,13 @@ Depends:
 Imports: 
     blob,
     DBI (>= 0.4-9),
+    desc,
     hms,
     methods,
     R6,
     testthat (>= 1.0.2),
     withr
 Suggests: 
-    devtools,
     knitr,
     lintr,
     rmarkdown
@@ -84,9 +84,9 @@ Collate:
     'spec-meta.R'
     'spec-transaction.R'
     'spec-compliance.R'
-    'spec-stress-driver.R'
     'spec-stress-connection.R'
     'spec-stress.R'
+    'spec-all.R'
     'spec-.R'
     'test-all.R'
     'test-getting-started.R'

diff --git a/NAMESPACE b/NAMESPACE
@@ -13,6 +13,7 @@ export(test_driver)
 export(test_getting_started)
 export(test_meta)
 export(test_result)
+export(test_some)
 export(test_sql)
 export(test_stress)
 export(test_transaction)
@@ -60,4 +61,5 @@ importFrom(methods,getClasses)
 importFrom(methods,hasMethod)
 importFrom(methods,is)
 importFrom(stats,setNames)
+importFrom(withr,with_output_sink)
 importFrom(withr,with_temp_libpaths)
diff --git a/R/run.R b/R/run.R
@@ -12,19 +12,9 @@ run_tests <- function(ctx, tests, skip, test_suite) {
   context(test_context)
 
   tests <- tests[!vapply(tests, is.null, logical(1L))]
-  if (any(names(tests) == "")) {
-    vicinity <- sort(unique(unlist(
-      lapply(which(names(tests) == ""), "+", -1:1)
-    )))
-    vicinity <- vicinity[names(tests)[vicinity] != ""]
-
-    stop("Unnamed specs found, have you used <- instead of = ? Nearby named tests: ",
-         paste0(names(tests)[vicinity], collapse = ", "),
-         call. = FALSE)
-  }
 
-  skip_rx <- paste0(paste0("(?:^", skip, "$)"), collapse = "|")
-  skip_flag <- grepl(skip_rx, names(tests), perl = TRUE)
+  skipped <- get_skip_names(skip)
+  skip_flag <- names(tests) %in% skipped
 
   ok <- vapply(seq_along(tests), function(test_idx) {
     test_name <- names(tests)[[test_idx]]
@@ -46,11 +36,34 @@ run_tests <- function(ctx, tests, skip, test_suite) {
   ok
 }
 
+get_skip_names <- function(skip) {
+  names_all <- names(spec_all)
+  names_all <- names_all[names_all != ""]
+  skip_flags_all <- lapply(paste0("(?:^", skip, "$)"), grepl, names_all, perl = TRUE)
+  skip_used <- vapply(skip_flags_all, any, logical(1L))
+  if (!all(skip_used)) {
+    warning("Unused skip expressions: ", paste(skip[!skip_used], collapse = ", "),
+            call. = FALSE)
+  }
+
+  skip_flag_all <- Reduce(`|`, skip_flags_all)
+  skip_tests <- names_all[skip_flag_all]
+
+  skip_tests
+}
+
 patch_test_fun <- function(test_fun, desc) {
-  body_of_test_fun <- body(test_fun)
+  body_of_test_fun <- wrap_all_statements_with_expect_no_warning(body(test_fun))
+
   eval(bquote(
     function(ctx) {
       test_that(.(desc), .(body_of_test_fun))
     }
   ))
 }
+
+wrap_all_statements_with_expect_no_warning <- function(block) {
+  stopifnot(identical(block[[1]], quote(`{`)))
+  block[-1] <- lapply(block[-1], function(x) eval(bquote(quote(expect_warning(.(x), NA)))))
+  block
+}
diff --git a/R/spec-.R b/R/spec-.R
@@ -9,10 +9,11 @@
 #
 # Output: Files R/test-xxx-1.R and R/test-xxx-2.R, and @include directives to stdout
 
+##### All
+#' @include spec-all.R
 ##### Stress
 #' @include spec-stress.R
 #' @include spec-stress-connection.R
-#' @include spec-stress-driver.R
 ##### Aggregators
 #' @include spec-compliance.R
 #' @include spec-transaction.R

diff --git a/R/spec-all.R b/R/spec-all.R
@@ -0,0 +1,11 @@
+spec_all <- c(
+  spec_getting_started,
+  spec_driver,
+  spec_connection,
+  spec_result,
+  spec_sql,
+  spec_meta,
+  spec_transaction,
+  spec_compliance,
+  spec_stress
+)
diff --git a/R/spec-connection-data-type.R b/R/spec-connection-data-type.R
@@ -1,8 +1,8 @@
 spec_connection_data_type <- list(
   data_type_connection = function(ctx) {
-    con <- connect(ctx)
-    on.exit(dbDisconnect(con), add = TRUE)
-    test_data_type(ctx, con)
+    with_connection({
+      test_data_type(ctx, con)
+    })
   },
 
   NULL

diff --git a/R/spec-connection-disconnect.R b/R/spec-connection-disconnect.R
@@ -15,6 +15,20 @@ spec_connection_disconnect <- list(
     expect_invisible_true(dbDisconnect(con))
   },
 
+  #' An error is raised when attempting to disconnect from an already closed
+  disconnect_closed_connection = function(ctx) {
+    with_closed_connection({
+      expect_error(dbDisconnect(con))
+    })
+  },
+
+  #' or invalid connection.
+  disconnect_invalid_connection = function(ctx) {
+    with_invalid_connection({
+      expect_error(dbDisconnect(con))
+    })
+  },
+
   #' @section Specification:
   cannot_forget_disconnect = function(ctx) {
     expect_warning(gc(), NA)

diff --git a/R/spec-connection-get-info.R b/R/spec-connection-get-info.R
@@ -5,22 +5,21 @@
 spec_connection_get_info <- list(
   #' Return value of dbGetInfo has necessary elements
   get_info_connection = function(ctx) {
-    con <- connect(ctx)
-    on.exit(expect_error(dbDisconnect(con), NA), add = TRUE)
+    with_connection({
+      info <- dbGetInfo(con)
+      expect_is(info, "list")
+      info_names <- names(info)
 
-    info <- dbGetInfo(con)
-    expect_is(info, "list")
-    info_names <- names(info)
+      necessary_names <-
+        c("db.version", "dbname", "username", "host", "port")
 
-    necessary_names <-
-      c("db.version", "dbname", "username", "host", "port")
+      for (name in necessary_names) {
+        eval(bquote(
+          expect_true(.(name) %in% info_names)))
+      }
 
-    for (name in necessary_names) {
-      eval(bquote(
-        expect_true(.(name) %in% info_names)))
-    }
-
-    expect_false("password" %in% info_names)
+      expect_false("password" %in% info_names)
+    })
   },
 
   #' }

diff --git a/R/spec-getting-started.R b/R/spec-getting-started.R
@@ -3,12 +3,13 @@
 #' @section Definition:
 spec_getting_started <- list(
   package_dependencies = function(ctx) {
-    #' A DBI backend is an R package,
-    pkg <- get_pkg(ctx)
+    #' A DBI backend is an R package
+    pkg_path <- get_pkg_path(ctx)
 
-    pkg_imports <- devtools::parse_deps(pkg$imports)$name
+    pkg_deps_df <- desc::desc_get_deps(pkg_path)
+    pkg_imports <- pkg_deps_df[pkg_deps_df[["type"]] == "Imports", ][["package"]]
 
-    #' which should import the \pkg{DBI}
+    #' which imports the \pkg{DBI}
     expect_true("DBI" %in% pkg_imports)
     #' and \pkg{methods}
     expect_true("methods" %in% pkg_imports)

diff --git a/R/spec-meta-bind-runner.R b/R/spec-meta-bind-runner.R
@@ -59,7 +59,7 @@ run_bind_tester$fun <- function() {
     #'     - For queries issued by `dbSendQuery()`,
     #'       call [dbFetch()].
     if (is_query()) {
-      rows <- dbFetch(res)
+      rows <- check_df(dbFetch(res))
       compare(rows, values)
     } else {
       #'     - For statements issued by `dbSendStatements()`,

diff --git a/R/spec-meta-bind.R b/R/spec-meta-bind.R
@@ -291,7 +291,7 @@ spec_meta_bind <- list(
   },
 
   #' - objects of type [blob]
-  bind_raw = function(ctx) {
+  bind_blob = function(ctx) {
     if (isTRUE(ctx$tweaks$omit_blob_tests)) {
       skip("tweak: omit_blob_tests")
     }

diff --git a/R/spec-meta-column-info.R b/R/spec-meta-column-info.R
@@ -7,13 +7,16 @@ spec_meta_column_info <- list(
   column_info = function(ctx) {
     with_connection({
       query <- "SELECT 1 as a, 1.5 as b, NULL"
-      expect_warning(res <- dbSendQuery(con, query), NA)
-      on.exit(expect_error(dbClearResult(res), NA), add = TRUE)
-      ci <- dbColumnInfo(res)
-      expect_is(ci, "data.frame")
-      expect_identical(colnames(ci), c("name", "type"))
-      expect_identical(ci$name[1:2], c("a", "b"))
-      expect_is(ci$type, "character")
+      with_result(
+        dbSendQuery(con, query),
+        {
+          ci <- dbColumnInfo(res)
+          expect_is(ci, "data.frame")
+          expect_identical(colnames(ci), c("name", "type"))
+          expect_identical(ci$name[1:2], c("a", "b"))
+          expect_is(ci$type, "character")
+        }
+      )
     })
   },
 

diff --git a/R/spec-meta-get-row-count.R b/R/spec-meta-get-row-count.R
@@ -22,7 +22,7 @@ spec_meta_get_row_count <- list(
           #' the row count is initially zero.
           expect_equal(rc, 0L)
           #' After a call to [dbFetch()] without limit,
-          dbFetch(res)
+          check_df(dbFetch(res))
           rc <- dbGetRowCount(res)
           #' the row count matches the total number of rows returned.
           expect_equal(rc, 1L)
@@ -38,12 +38,12 @@ spec_meta_get_row_count <- list(
           rc <- dbGetRowCount(res)
           expect_equal(rc, 0L)
           #' Fetching a limited number of rows
-          dbFetch(res, 2L)
+          check_df(dbFetch(res, 2L))
           #' increases the number of rows by the number of rows returned,
           rc <- dbGetRowCount(res)
           expect_equal(rc, 2L)
           #' even if fetching past the end of the result set.
-          dbFetch(res, 2L)
+          check_df(dbFetch(res, 2L))
           rc <- dbGetRowCount(res)
           expect_equal(rc, 3L)
         }
@@ -61,7 +61,7 @@ spec_meta_get_row_count <- list(
           rc <- dbGetRowCount(res)
           #' zero is returned
           expect_equal(rc, 0L)
-          dbFetch(res)
+          check_df(dbFetch(res))
           rc <- dbGetRowCount(res)
           #' even after fetching.
           expect_equal(rc, 0L)
@@ -74,23 +74,23 @@ spec_meta_get_row_count <- list(
     with_connection({
       name <- random_table_name()
 
-      on.exit(try_silent(dbExecute(paste0("DROP TABLE ", name))), add = TRUE)
-
-      query <- paste0("CREATE TABLE ", name, " (a integer)")
-      with_result(
-        #' For data manipulation statements issued with
-        #' [dbSendStatement()],
-        dbSendStatement(con, query),
-        {
-          rc <- dbGetRowCount(res)
-          #' zero is returned before
-          expect_equal(rc, 0L)
-          dbFetch(res)
-          rc <- dbGetRowCount(res)
-          #' and after calling `dbFetch()`.
-          expect_equal(rc, 0L)
-        }
-      )
+      with_remove_test_table(name = name, {
+        query <- paste0("CREATE TABLE ", name, " (a integer)")
+        with_result(
+          #' For data manipulation statements issued with
+          #' [dbSendStatement()],
+          dbSendStatement(con, query),
+          {
+            rc <- dbGetRowCount(res)
+            #' zero is returned before
+            expect_equal(rc, 0L)
+            check_df(dbFetch(res))
+            rc <- dbGetRowCount(res)
+            #' and after calling `dbFetch()`.
+            expect_equal(rc, 0L)
+          }
+        )
+      })
     })
   },
 

diff --git a/R/spec-meta-get-rows-affected.R b/R/spec-meta-get-rows-affected.R
@@ -27,7 +27,7 @@ spec_meta_get_rows_affected <- list(
             rc <- dbGetRowsAffected(res)
             #' The value is available directly after the call
             expect_equal(rc, 5L)
-            dbFetch(res)
+            check_df(dbFetch(res))
             rc <- dbGetRowsAffected(res)
             #' and does not change after calling [dbFetch()].
             expect_equal(rc, 5L)
@@ -47,7 +47,7 @@ spec_meta_get_rows_affected <- list(
           rc <- dbGetRowsAffected(res)
           #' zero is returned before
           expect_equal(rc, 0L)
-          dbFetch(res)
+          check_df(dbFetch(res))
           rc <- dbGetRowsAffected(res)
           #' and after the call to `dbFetch()`.
           expect_equal(rc, 0L)

diff --git a/R/spec-meta-get-statement.R b/R/spec-meta-get-statement.R
@@ -29,19 +29,19 @@ spec_meta_get_statement <- list(
     with_connection({
       name <- random_table_name()
 
-      on.exit(try_silent(dbExecute(paste0("DROP TABLE ", name))), add = TRUE)
-
       with_connection({
-        query <- paste0("CREATE TABLE ", name, " (a integer)")
-        with_result(
-          #' or [dbSendStatement()].
-          dbSendQuery(con, query),
-          {
-            s <- dbGetStatement(res)
-            expect_is(s, "character")
-            expect_identical(s, query)
-          }
-        )
+        with_remove_test_table(name = name, {
+          query <- paste0("CREATE TABLE ", name, " (a integer)")
+          with_result(
+            #' or [dbSendStatement()].
+            dbSendQuery(con, query),
+            {
+              s <- dbGetStatement(res)
+              expect_is(s, "character")
+              expect_identical(s, query)
+            }
+          )
+        })
       })
     })
   },