diff --git a/DESCRIPTION b/DESCRIPTION index 3ba7c7d16..6507af716 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,20 +55,21 @@ Imports: bit64, blob (>= 1.2.0), DBI (>= 1.1.0), + DBItest, memoise, methods, pkgconfig, - Rcpp (>= 1.0.7) + Rcpp (>= 1.0.7), + rlang Suggests: callr, - DBItest (>= 1.7.0), gert, gh, knitr, rmarkdown, hms, rvest, - testthat, + testthat (>= 2.0.0), xml2 LinkingTo: plogr (>= 0.2.0), @@ -79,6 +80,7 @@ Encoding: UTF-8 Roxygen: list(markdown = TRUE) RoxygenNote: 7.2.1 Collate: + 'RSQLite-package.R' 'RcppExports.R' 'SQLiteConnection.R' 'SQLKeywords_SQLiteConnection.R' @@ -147,3 +149,4 @@ Collate: 'zzz.R' Config/autostyle/scope: line_breaks Config/autostyle/strict: false +Config/testthat/edition: 2 diff --git a/NAMESPACE b/NAMESPACE index 640cc0a4c..30e469375 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -72,8 +72,58 @@ exportMethods(show) exportMethods(sqlData) import(DBI) import(methods) +importFrom(DBItest,check_df) +importFrom(DBItest,connect) +importFrom(DBItest,dbi_generics) +importFrom(DBItest,expect_all_args_have_default_values) +importFrom(DBItest,expect_ellipsis_in_formals) +importFrom(DBItest,expect_equal_df) +importFrom(DBItest,expect_has_class_method) +importFrom(DBItest,expect_invisible_true) +importFrom(DBItest,get_default_context) +importFrom(DBItest,get_key_methods) +importFrom(DBItest,get_penguins) +importFrom(DBItest,get_pkg_path) +importFrom(DBItest,get_placeholder_funs) +importFrom(DBItest,get_texts) +importFrom(DBItest,has_utf8_or_ascii_encoding) +importFrom(DBItest,local_connection) +importFrom(DBItest,local_remove_test_table) +importFrom(DBItest,local_result) +importFrom(DBItest,new_bind_tester_extra) +importFrom(DBItest,package_name) +importFrom(DBItest,random_table_name) +importFrom(DBItest,s4_methods) +importFrom(DBItest,sql_union) +importFrom(DBItest,test_data_type) +importFrom(DBItest,test_select) +importFrom(DBItest,test_select_bind) +importFrom(DBItest,test_select_with_null) +importFrom(DBItest,test_table_roundtrip) +importFrom(DBItest,test_table_roundtrip_one) +importFrom(DBItest,trivial_df) +importFrom(DBItest,trivial_query) +importFrom(DBItest,trivial_values) +importFrom(DBItest,try_silent) +importFrom(DBItest,unrowname) importFrom(Rcpp,sourceCpp) importFrom(bit64,integer64) importFrom(bit64,is.integer64) importFrom(blob,blob) +importFrom(rlang,"%||%") +importFrom(rlang,":=") +importFrom(rlang,abort) +importFrom(rlang,as_function) +importFrom(rlang,enexpr) +importFrom(rlang,enquo) +importFrom(rlang,enquos) +importFrom(rlang,eval_tidy) +importFrom(rlang,expr) +importFrom(rlang,has_length) +importFrom(rlang,is_interactive) +importFrom(rlang,list2) +importFrom(rlang,local_options) +importFrom(rlang,quo) +importFrom(rlang,seq2) +importFrom(rlang,set_names) useDynLib(RSQLite, .registration = TRUE) diff --git a/R/RSQLite-package.R b/R/RSQLite-package.R new file mode 100644 index 000000000..55042f2d3 --- /dev/null +++ b/R/RSQLite-package.R @@ -0,0 +1,56 @@ +#' @keywords internal +"_PACKAGE" + +## usethis namespace: start +#' @importFrom DBItest check_df +#' @importFrom DBItest connect +#' @importFrom DBItest dbi_generics +#' @importFrom DBItest expect_all_args_have_default_values +#' @importFrom DBItest expect_ellipsis_in_formals +#' @importFrom DBItest expect_equal_df +#' @importFrom DBItest expect_has_class_method +#' @importFrom DBItest expect_invisible_true +#' @importFrom DBItest get_default_context +#' @importFrom DBItest get_key_methods +#' @importFrom DBItest get_penguins +#' @importFrom DBItest get_pkg_path +#' @importFrom DBItest get_placeholder_funs +#' @importFrom DBItest get_texts +#' @importFrom DBItest has_utf8_or_ascii_encoding +#' @importFrom DBItest local_connection +#' @importFrom DBItest local_remove_test_table +#' @importFrom DBItest local_result +#' @importFrom DBItest new_bind_tester_extra +#' @importFrom DBItest package_name +#' @importFrom DBItest random_table_name +#' @importFrom DBItest s4_methods +#' @importFrom DBItest sql_union +#' @importFrom DBItest test_data_type +#' @importFrom DBItest test_select +#' @importFrom DBItest test_select_bind +#' @importFrom DBItest test_select_with_null +#' @importFrom DBItest test_table_roundtrip +#' @importFrom DBItest test_table_roundtrip_one +#' @importFrom DBItest trivial_df +#' @importFrom DBItest trivial_query +#' @importFrom DBItest trivial_values +#' @importFrom DBItest try_silent +#' @importFrom DBItest unrowname +#' @importFrom rlang %||% +#' @importFrom rlang := +#' @importFrom rlang abort +#' @importFrom rlang as_function +#' @importFrom rlang enexpr +#' @importFrom rlang enquo +#' @importFrom rlang enquos +#' @importFrom rlang eval_tidy +#' @importFrom rlang expr +#' @importFrom rlang has_length +#' @importFrom rlang is_interactive +#' @importFrom rlang list2 +#' @importFrom rlang local_options +#' @importFrom rlang quo +#' @importFrom rlang seq2 +#' @importFrom rlang set_names +## usethis namespace: end +NULL diff --git a/tests/testthat.R b/tests/testthat.R index e8567252d..28e1140f7 100644 --- a/tests/testthat.R +++ b/tests/testthat.R @@ -1,3 +1,11 @@ +# This file is part of the standard setup for testthat. +# It is recommended that you do not modify it. +# +# Where should you do additional test configuration? +# Learn more about the roles of various files in: +# * https://r-pkgs.org/tests.html +# * https://testthat.r-lib.org/reference/test_package.html#special-files + library(testthat) library(RSQLite) diff --git a/tests/testthat/test-dbitest-compliance.R b/tests/testthat/test-dbitest-compliance.R new file mode 100644 index 000000000..18dc64056 --- /dev/null +++ b/tests/testthat/test-dbitest-compliance.R @@ -0,0 +1,60 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("compliance", { + key_methods <- get_key_methods() + expect_identical(names(key_methods), c("Driver", "Connection", "Result")) + pkg <- package_name(ctx) + where <- asNamespace(pkg) + sapply( + names(key_methods), + function(name) { + dbi_class <- paste0("DBI", name) + classes <- Filter( + function(class) { + extends(class, dbi_class) && `@`(getClass(class), virtual) == FALSE + }, + getClasses(where) + ) + expect_gte(length(classes), 1) + class <- classes[[1]] + mapply( + function(method, args) { + expect_has_class_method(method, class, args, where) + }, + names(key_methods[[name]]), + key_methods[[name]] + ) + } + ) +}) + +test_that("reexport", { + pkg <- package_name(ctx) + where <- asNamespace(pkg) + dbi_names <- dbi_generics(`$`(`$`(ctx, tweaks), dbitest_version)) + exported_names <- suppressWarnings( + `::`(callr, r)( + function(pkg) { + tryCatch(getNamespaceExports(getNamespace(pkg)), error = function(e) character()) + }, + args = list(pkg = pkg) + ) + ) + if (length(exported_names) == 0) { + skip("reexport: package must be installed for this test") + } + missing <- setdiff(dbi_names, exported_names) + expect_equal(paste(missing, collapse = ", "), "") +}) + +test_that("ellipsis", { + pkg <- package_name(ctx) + where <- asNamespace(pkg) + methods <- s4_methods(where, function(x) x == "DBI") + methods <- methods[grep("^db", names(methods))] + Map(expect_ellipsis_in_formals, methods, names(methods)) +}) diff --git a/tests/testthat/test-dbitest-connection.R b/tests/testthat/test-dbitest-connection.R new file mode 100644 index 000000000..1a4a5e8b6 --- /dev/null +++ b/tests/testthat/test-dbitest-connection.R @@ -0,0 +1,32 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("disconnect_formals", { + # + expect_equal(names(formals(dbDisconnect)), c("conn", "...")) +}) + +test_that("can_disconnect", { + #' @return + con <- connect(ctx) + #' `dbDisconnect()` returns `TRUE`, invisibly. + expect_invisible_true(dbDisconnect(con)) +}) + +test_that("data_type_connection", { + test_data_type(ctx, con) +}) + +test_that("get_info_connection", { + info <- dbGetInfo(con) + expect_type(info, "list") + info_names <- names(info) + necessary_names <- c("db.version", "dbname", "username", "host", "port") + for (name in necessary_names) { + eval(bquote(expect_true(.(name) %in% info_names))) + } + expect_false("password" %in% info_names) +}) diff --git a/tests/testthat/test-dbitest-driver.R b/tests/testthat/test-dbitest-driver.R new file mode 100644 index 000000000..28671faa8 --- /dev/null +++ b/tests/testthat/test-dbitest-driver.R @@ -0,0 +1,98 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("constructor", { + pkg_name <- package_name(ctx) + default_constructor_name <- gsub("^R", "", pkg_name) + constructor_name <- `$`(`$`(ctx, tweaks), constructor_name) %||% default_constructor_name + pkg_env <- getNamespace(pkg_name) + eval(bquote(expect_true(.(constructor_name) %in% getNamespaceExports(pkg_env)))) + eval(bquote(expect_true(exists(.(constructor_name), mode = "function", pkg_env)))) + constructor <- get(constructor_name, mode = "function", pkg_env) + expect_all_args_have_default_values(constructor) + if (!isTRUE(`$`(`$`(ctx, tweaks), constructor_relax_args))) { + expect_arglist_is_empty(constructor) + } +}) + +test_that("data_type_formals", { + # + expect_equal(names(formals(dbDataType)), c("dbObj", "obj", "...")) +}) + +test_that("data_type_driver", { + test_data_type(ctx, ctx$drv) +}) + +test_that("get_info_driver", { + info <- dbGetInfo(`$`(ctx, drv)) + expect_type(info, "list") + info_names <- names(info) + necessary_names <- c("driver.version", "client.version") + for (name in necessary_names) { + eval(bquote(expect_true(.(name) %in% info_names))) + } +}) + +test_that("connect_formals", { + # + expect_equal(names(formals(dbConnect)), c("drv", "...")) +}) + +test_that("connect_can_connect", { + #' @return + con <- expect_visible(connect(ctx)) + #' `dbConnect()` returns an S4 object that inherits from [DBIConnection-class]. + expect_s4_class(con, "DBIConnection") + dbDisconnect(con) + #' This object is used to communicate with the database engine. +}) + +test_that("connect_format", { + #' + #' A [format()] method is defined for the connection object. + desc <- format(con) + #' It returns a string that consists of a single line of text. + expect_type(desc, "character") + expect_length(desc, 1) + expect_false(grepl("\n", desc, fixed = TRUE)) +}) + +test_that("connect_bigint_integer", { + #' In addition, DBI supports the `bigint` argument that governs how + #' 64-bit integer data is returned. The following values are supported: + #' - `"integer"`: always return as `integer`, silently overflow + con <- local_connection(ctx, bigint = "integer") + res <- dbGetQuery(con, "SELECT 10000000000") + expect_type(res[[1]], "integer") +}) + +test_that("connect_bigint_numeric", { + #' - `"numeric"`: always return as `numeric`, silently round + con <- local_connection(ctx, bigint = "numeric") + res <- dbGetQuery(con, "SELECT 10000000000") + expect_type(res[[1]], "double") + expect_equal(res[[1]], 1e10) +}) + +test_that("connect_bigint_character", { + #' - `"character"`: always return the decimal representation as `character` + con <- local_connection(ctx, bigint = "character") + res <- dbGetQuery(con, "SELECT 10000000000") + expect_type(res[[1]], "character") + expect_equal(res[[1]], "10000000000") +}) + +test_that("connect_bigint_integer64", { + #' - `"integer64"`: return as a data type that can be coerced using + #' [as.integer()] (with warning on overflow), [as.numeric()] + #' and [as.character()] + con <- local_connection(ctx, bigint = "integer64") + res <- dbGetQuery(con, "SELECT 10000000000") + expect_warning(expect_true(is.na(as.integer(res[[1]])))) + expect_equal(as.numeric(res[[1]]), 1e10) + expect_equal(as.character(res[[1]]), "10000000000") +}) diff --git a/tests/testthat/test-dbitest-getting_started.R b/tests/testthat/test-dbitest-getting_started.R new file mode 100644 index 000000000..1ea8ccf05 --- /dev/null +++ b/tests/testthat/test-dbitest-getting_started.R @@ -0,0 +1,28 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("package_dependencies", { + #' A DBI backend is an R package + pkg_path <- get_pkg_path(ctx) + + pkg_deps_df <- desc::desc_get_deps(pkg_path) + pkg_imports <- pkg_deps_df$package[pkg_deps_df$type == "Imports"] + + #' which imports the \pkg{DBI} + expect_true("DBI" %in% pkg_imports) + #' and \pkg{methods} + expect_true("methods" %in% pkg_imports) + #' packages. +}) + +test_that("package_name", { + pkg_name <- package_name(ctx) + + #' For better or worse, the names of many existing backends start with + #' \sQuote{R}, e.g., \pkg{RSQLite}, \pkg{RMySQL}, \pkg{RSQLServer}; it is up + #' to the backend author to adopt this convention or not. + expect_match(pkg_name, "^R") +}) diff --git a/tests/testthat/test-dbitest-meta.R b/tests/testthat/test-dbitest-meta.R new file mode 100644 index 000000000..6be02cfbf --- /dev/null +++ b/tests/testthat/test-dbitest-meta.R @@ -0,0 +1,522 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("bind_formals", { + # + expect_equal(names(formals(dbBind)), c("res", "params", "...")) +}) + +test_that("bind_return_value", { + extra <- new_bind_tester_extra( + check_return_value = function(bind_res, res) { + expect_identical(res, `$`(bind_res, value)) + expect_false(`$`(bind_res, visible)) + } + ) + test_select_bind(con, ctx, 1L, extra = extra) + test_select_bind(con, ctx, 1L, extra = extra, query = FALSE) +}) + +test_that("bind_empty", { + #' @section Failure modes: + #' Calling `dbBind()` for a query without parameters + res <- local_result(dbSendQuery(con, trivial_query())) + #' raises an error. + expect_error(dbBind(res, list())) +}) + +test_that("bind_too_many", { + extra <- new_bind_tester_extra( + patch_bind_values = function(bind_values) { + if (is.null(names(bind_values))) { + c(bind_values, bind_values[[1L]]) + } else { + c(bind_values, bogus = bind_values[[1L]]) + } + }, + bind_error = function() ".*" + ) + test_select_bind(con, ctx, 1L, extra = extra) +}) + +test_that("bind_not_enough", { + extra <- new_bind_tester_extra(patch_bind_values = function(bind_values) { + bind_values[-1L] + }, bind_error = function() ".*") + test_select_bind(con, ctx, 1L, extra = extra) +}) + +test_that("bind_wrong_name", { + extra <- new_bind_tester_extra( + patch_bind_values = function(bind_values) { + `::`(stats, setNames)(bind_values, paste0("bogus", names(bind_values))) + }, + requires_names = function() TRUE, + bind_error = function() ".*" + ) + test_select_bind(con, ctx, 1L, extra = extra) +}) + +test_that("bind_multi_row_unequal_length", { + extra <- new_bind_tester_extra( + patch_bind_values = function(bind_values) { + bind_values[[2]] <- bind_values[[2]][-1] + bind_values + }, + bind_error = function() ".*" + ) + test_select_bind(con, ctx, list(1:3, 2:4), extra = extra, query = FALSE) +}) + +test_that("bind_named_param_unnamed_placeholders", { + extra <- new_bind_tester_extra( + patch_bind_values = function(bind_values) { + `::`(stats, setNames)(bind_values, NULL) + }, + bind_error = function() ".*", + requires_names = function() TRUE + ) + test_select_bind(con, ctx, 1L, extra = extra) +}) + +test_that("bind_named_param_empty_placeholders", { + extra <- new_bind_tester_extra( + patch_bind_values = function(bind_values) { + names(bind_values)[[1]] <- "" + }, + bind_error = function() ".*", + requires_names = function() TRUE + ) + test_select_bind(con, ctx, list(1L, 2L), extra = extra) +}) + +test_that("bind_named_param_na_placeholders", { + extra <- new_bind_tester_extra( + patch_bind_values = function(bind_values) { + names(bind_values)[[1]] <- NA + }, + bind_error = function() ".*", + requires_names = function() TRUE + ) + test_select_bind(con, ctx, list(1L, 2L), extra = extra) +}) + +test_that("bind_unnamed_param_named_placeholders", { + extra <- new_bind_tester_extra( + patch_bind_values = function(bind_values) { + `::`(stats, setNames)(bind_values, letters[seq_along(bind_values)]) + }, + bind_error = function() ".*", + requires_names = function() FALSE + ) + test_select_bind(con, ctx, 1L, extra = extra) +}) + +test_that("bind_premature_clear", { + extra <- new_bind_tester_extra(is_premature_clear = function() TRUE) + expect_error(test_select_bind(con, ctx, 1L, extra = extra)) +}) + +test_that("bind_multi_row", { + #' @section Specification: + #' The elements of the `params` argument do not need to be scalars, + #' vectors of arbitrary length + test_select_bind(con, ctx, list(1:3)) +}) + +test_that("bind_multi_row_zero_length", { + #' (including length 0) + test_select_bind(con, ctx, list(integer(), integer())) + + #' are supported. + # This behavior is tested as part of run_bind_tester$fun + #' For queries, calling `dbFetch()` binding such parameters returns + #' concatenated results, equivalent to binding and fetching for each set + #' of values and connecting via [rbind()]. +}) + +test_that("bind_multi_row_statement", { + # This behavior is tested as part of run_bind_tester$fun + #' For data manipulation statements, `dbGetRowsAffected()` returns the + #' total number of rows affected if binding non-scalar parameters. + test_select_bind(con, ctx, list(1:3), query = FALSE) +}) + +test_that("bind_repeated", { + extra <- new_bind_tester_extra(is_repeated = function() TRUE) + test_select_bind(con, ctx, 1L, extra = extra) + test_select_bind(con, ctx, 1L, extra = extra, query = FALSE) +}) + +test_that("bind_repeated_untouched", { + extra <- new_bind_tester_extra(is_repeated = function() TRUE, is_untouched = function() TRUE) + test_select_bind(con, ctx, 1L, extra = extra) + test_select_bind(con, ctx, 1L, extra = extra, query = FALSE) +}) + +test_that("bind_named_param_shuffle", { + extra <- new_bind_tester_extra(patch_bind_values = function(bind_values) { + bind_values[c(3, 1, 2, 4)] + }, requires_names = function() TRUE) + test_select_bind(con, ctx, c(1:3 + 0.5, NA), extra = extra) +}) + +test_that("bind_integer", { + #' At least the following data types are accepted on input (including [NA]): + #' - [integer] + test_select_bind(con, ctx, c(1:3, NA)) +}) + +test_that("bind_numeric", { + #' - [numeric] + test_select_bind(con, ctx, c(1:3 + 0.5, NA)) +}) + +test_that("bind_logical", { + #' - [logical] for Boolean values + test_select_bind(con, ctx, c(TRUE, FALSE, NA)) +}) + +test_that("bind_character", { + #' - [character] + test_select_bind(con, ctx, c(get_texts(), NA)) +}) + +test_that("bind_character_escape", { + #' (also with special characters such as spaces, newlines, quotes, and backslashes) + test_select_bind(con, ctx, c(" ", "\n", "\r", "\b", "'", '"', "[", "]", "\\", NA)) +}) + +test_that("bind_factor", { + #' - [factor] (bound as character, + #' with warning) + suppressWarnings(expect_warning( + test_select_bind( + con, + ctx, + lapply(c(get_texts(), NA_character_), factor) + ) + )) +}) + +test_that("bind_date", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + test_select_bind(con, ctx, c(Sys.Date() + 0:2, NA)) +}) + +test_that("bind_date_integer", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + test_select_bind(con, ctx, structure(c(18618:18620, NA), class = "Date")) +}) + +test_that("bind_timestamp", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + data_in <- as.POSIXct(c(round(Sys.time()) + 0:2, NA)) + test_select_bind(con, ctx, data_in) +}) + +test_that("bind_timestamp_lt", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + data_in <- lapply(round(Sys.time()) + c(0:2, NA), as.POSIXlt) + test_select_bind(con, ctx, data_in) +}) + +test_that("bind_time_seconds", { + if (!isTRUE(`$`(`$`(ctx, tweaks), time_typed))) { + skip("tweak: !time_typed") + } + data_in <- as.difftime(as.numeric(c(1:3, NA)), units = "secs") + test_select_bind(con, ctx, data_in) +}) + +test_that("bind_time_hours", { + if (!isTRUE(`$`(`$`(ctx, tweaks), time_typed))) { + skip("tweak: !time_typed") + } + data_in <- as.difftime(as.numeric(c(1:3, NA)), units = "hours") + test_select_bind(con, ctx, data_in) +}) + +test_that("bind_time_minutes_integer", { + if (!isTRUE(`$`(`$`(ctx, tweaks), time_typed))) { + skip("tweak: !time_typed") + } + data_in <- as.difftime(c(1:3, NA), units = "mins") + test_select_bind(con, ctx, data_in) +}) + +test_that("bind_raw", { + if (isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + skip("tweak: omit_blob_tests") + } + test_select_bind(con, ctx, list(list(as.raw(1:10)), list(raw(3)), list(NULL)), cast_fun = `$`(`$`(ctx, tweaks), blob_cast)) +}) + +test_that("bind_blob", { + if (isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + skip("tweak: omit_blob_tests") + } + test_select_bind( + con, + ctx, + list(`::`(blob, blob)(as.raw(1:10)), `::`(blob, blob)(raw(3)), `::`(blob, blob)(NULL)), + cast_fun = `$`(`$`(ctx, tweaks), blob_cast) + ) +}) + +test_that("is_valid_formals", { + # + expect_equal(names(formals(dbIsValid)), c("dbObj", "...")) +}) + +test_that("is_valid_connection", { + #' @return + #' `dbIsValid()` returns a logical scalar, + #' `TRUE` if the object specified by `dbObj` is valid, + #' `FALSE` otherwise. + con <- connect(ctx) + #' A [DBIConnection-class] object is initially valid, + expect_true(expect_visible(dbIsValid(con))) + expect_error(dbDisconnect(con), NA) + #' and becomes invalid after disconnecting with [dbDisconnect()]. + expect_false(expect_visible(dbIsValid(con))) +}) + +test_that("is_valid_result_query", { + query <- trivial_query() + res <- dbSendQuery(con, query) + on.exit(dbClearResult(res)) + #' A [DBIResult-class] object is valid after a call to [dbSendQuery()], + expect_true(expect_visible(dbIsValid(res))) + expect_error(dbFetch(res), NA) + #' and stays valid even after all rows have been fetched; + expect_true(expect_visible(dbIsValid(res))) + dbClearResult(res) + on.exit(NULL) + #' only clearing it with [dbClearResult()] invalidates it. + expect_false(dbIsValid(res)) +}) + +test_that("has_completed_formals", { + # + expect_equal(names(formals(dbHasCompleted)), c("res", "...")) +}) + +test_that("has_completed_query", { + #' @return + #' `dbHasCompleted()` returns a logical scalar. + #' For a query initiated by [dbSendQuery()] with non-empty result set, + res <- local_result(dbSendQuery(con, trivial_query())) + #' `dbHasCompleted()` returns `FALSE` initially + expect_false(expect_visible(dbHasCompleted(res))) + #' and `TRUE` after calling [dbFetch()] without limit. + check_df(dbFetch(res)) + expect_true(expect_visible(dbHasCompleted(res))) +}) + +test_that("has_completed_error", { + #' @section Failure modes: + res <- dbSendQuery(con, trivial_query()) + dbClearResult(res) + #' Attempting to query completion status for a result set cleared with + #' [dbClearResult()] gives an error. + expect_error(dbHasCompleted(res)) +}) + +test_that("has_completed_query_spec", { + #' @section Specification: + #' The completion status for a query is only guaranteed to be set to + #' `FALSE` after attempting to fetch past the end of the entire result. + #' Therefore, for a query with an empty result set, + res <- local_result(dbSendQuery(con, "SELECT * FROM (SELECT 1 as a) AS x WHERE (1 = 0)")) + #' the initial return value is unspecified, + #' but the result value is `TRUE` after trying to fetch only one row. + check_df(dbFetch(res, 1)) + expect_true(expect_visible(dbHasCompleted(res))) +}) + +test_that("has_completed_query_spec_partial", { + #' @section Specification: + #' Similarly, for a query with a result set of length n, + res <- local_result(dbSendQuery(con, trivial_query())) + #' the return value is unspecified after fetching n rows, + check_df(dbFetch(res, 1)) + #' but the result value is `TRUE` after trying to fetch only one more + #' row. + check_df(dbFetch(res, 1)) + expect_true(expect_visible(dbHasCompleted(res))) +}) + +test_that("get_statement_formals", { + # + expect_equal(names(formals(dbGetStatement)), c("res", "...")) +}) + +test_that("get_statement_query", { + #' @return + #' `dbGetStatement()` returns a string, the query used in + query <- trivial_query() + #' either [dbSendQuery()] + res <- local_result(dbSendQuery(con, query)) + s <- dbGetStatement(res) + expect_type(s, "character") + expect_identical(s, query) +}) + +test_that("get_statement_error", { + #' @section Failure modes: + res <- dbSendQuery(con, trivial_query()) + dbClearResult(res) + #' Attempting to query the statement for a result set cleared with + #' [dbClearResult()] gives an error. + expect_error(dbGetStatement(res)) +}) + +test_that("column_info_formals", { + # + expect_equal(names(formals(dbColumnInfo)), c("res", "...")) +}) + +test_that("column_info_closed", { + #' @section Failure modes: + #' An attempt to query columns for a closed result set raises an error. + query <- trivial_query() + + res <- dbSendQuery(con, query) + dbClearResult(res) + + expect_error(dbColumnInfo(res)) +}) + +test_that("column_info_consistent", { + res <- local_result(dbSendQuery(con, "SELECT 1.5 AS a, 2.5 AS b")) + #' The column names are always consistent + info <- dbColumnInfo(res) + #' with the data returned by `dbFetch()`. + data <- dbFetch(res) + expect_identical(info$name, names(data)) +}) + +test_that("column_info_consistent_unnamed", { + if (as.package_version(`$`(`$`(ctx, tweaks), dbitest_version)) < "1.7.2") { + skip(paste0("tweak: dbitest_version: ", `$`(`$`(ctx, tweaks), dbitest_version))) + } + res <- local_result(dbSendQuery(con, "SELECT 1.5, 2.5 AS a, 1.5, 3.5")) + info <- dbColumnInfo(res) + data <- dbFetch(res) + expect_identical(`$`(info, name), names(data)) + expect_equal(data[["a"]], 2.5) + expect_false(anyNA(names(data))) + expect_true(all(names(data) != "")) +}) + +test_that("column_info_consistent_keywords", { + #' Column names that correspond to SQL or R keywords are left unchanged. + res <- local_result(dbSendQuery(con, paste0("SELECT 1.5 AS ", dbQuoteIdentifier(con, "for")))) + info <- dbColumnInfo(res) + data <- dbFetch(res) + expect_identical(info$name, names(data)) + expect_equal(data[["for"]], 1.5) +}) + +test_that("get_row_count_formals", { + # + expect_equal(names(formals(dbGetRowCount)), c("res", "...")) +}) + +test_that("row_count_query", { + #' @return + #' `dbGetRowCount()` returns a scalar number (integer or numeric), + #' the number of rows fetched so far. + query <- trivial_query() + #' After calling [dbSendQuery()], + res <- local_result(dbSendQuery(con, query)) + rc <- dbGetRowCount(res) + #' the row count is initially zero. + expect_equal(rc, 0L) + #' After a call to [dbFetch()] without limit, + check_df(dbFetch(res)) + rc <- dbGetRowCount(res) + #' the row count matches the total number of rows returned. + expect_equal(rc, 1L) +}) + +test_that("row_count_query_limited", { + query <- sql_union(.ctx = ctx, trivial_query(), "SELECT 2", "SELECT 3") + res <- local_result(dbSendQuery(con, query)) + rc1 <- dbGetRowCount(res) + expect_equal(rc1, 0L) + #' Fetching a limited number of rows + check_df(dbFetch(res, 2L)) + #' increases the number of rows by the number of rows returned, + rc2 <- dbGetRowCount(res) + expect_equal(rc2, 2L) + #' even if fetching past the end of the result set. + check_df(dbFetch(res, 2L)) + rc3 <- dbGetRowCount(res) + expect_equal(rc3, 3L) +}) + +test_that("row_count_query_empty", { + #' For queries with an empty result set, + query <- sql_union( + .ctx = ctx, "SELECT * FROM (SELECT 1 as a) a WHERE (0 = 1)" + ) + res <- local_result(dbSendQuery(con, query)) + rc <- dbGetRowCount(res) + #' zero is returned + expect_equal(rc, 0L) + check_df(dbFetch(res)) + rc <- dbGetRowCount(res) + #' even after fetching. + expect_equal(rc, 0L) +}) + +test_that("get_row_count_error", { + #' @section Failure modes: + res <- dbSendQuery(con, trivial_query()) + dbClearResult(res) + #' Attempting to get the row count for a result set cleared with + #' [dbClearResult()] gives an error. + expect_error(dbGetRowCount(res)) +}) + +test_that("get_rows_affected_formals", { + # + expect_equal(names(formals(dbGetRowsAffected)), c("res", "...")) +}) + +test_that("rows_affected_query", { + query <- trivial_query() + #' For queries issued with [dbSendQuery()], + res <- local_result(dbSendQuery(con, query)) + rc <- dbGetRowsAffected(res) + #' zero is returned before + expect_equal(rc, 0L) + check_df(dbFetch(res)) + rc <- dbGetRowsAffected(res) + #' and after the call to `dbFetch()`. + expect_equal(rc, 0L) +}) + +test_that("get_info_result", { + res <- local_result(dbSendQuery(con, trivial_query())) + info <- dbGetInfo(res) + expect_type(info, "list") + info_names <- names(info) + necessary_names <- c("statement", "row.count", "rows.affected", "has.completed") + for (name in necessary_names) { + eval(bquote(expect_true(.(name) %in% info_names))) + } +}) diff --git a/tests/testthat/test-dbitest-result.R b/tests/testthat/test-dbitest-result.R new file mode 100644 index 000000000..0f3b43025 --- /dev/null +++ b/tests/testthat/test-dbitest-result.R @@ -0,0 +1,714 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("send_query_formals", { + # + expect_equal(names(formals(dbSendQuery)), c("conn", "statement", "...")) +}) + +test_that("send_query_trivial", { + #' @return + #' `dbSendQuery()` returns + res <- expect_visible(dbSendQuery(con, trivial_query())) + #' an S4 object that inherits from [DBIResult-class]. + expect_s4_class(res, "DBIResult") + #' The result set can be used with [dbFetch()] to extract records. + expect_equal(check_df(dbFetch(res))[[1]], 1.5) + #' Once you have finished using a result, make sure to clear it + #' with [dbClearResult()]. + dbClearResult(res) +}) + +test_that("send_query_non_string", { + #' or if the query is not a non-`NA` string. + expect_error(dbSendQuery(con, character())) + expect_error(dbSendQuery(con, letters)) + expect_error(dbSendQuery(con, NA_character_)) +}) + +test_that("send_query_syntax_error", { + #' @section Failure modes: + expect_error(dbSendQuery(con, "SELLECT", params = list())) + expect_error(dbSendQuery(con, "SELLECT", immediate = TRUE)) +}) + +test_that("send_query_result_valid", { + #' @section Specification: + #' No warnings occur under normal conditions. + expect_warning(res <- dbSendQuery(con, trivial_query()), NA) + #' When done, the DBIResult object must be cleared with a call to + #' [dbClearResult()]. + dbClearResult(res) +}) + +test_that("send_query_stale_warning", { + con <- connect(ctx) + on.exit(dbDisconnect(con)) + expect_warning(dbSendQuery(con, trivial_query()), NA) + expect_warning({ + dbDisconnect(con) + gc() + }) + on.exit(NULL) +}) + +test_that("send_query_only_one_result_set", { + #' If the backend supports only one open result set per connection, + res1 <- dbSendQuery(con, trivial_query()) + #' issuing a second query invalidates an already open result set + #' and raises a warning. + expect_warning(res2 <- dbSendQuery(con, "SELECT 2")) + expect_false(dbIsValid(res1)) + #' The newly opened result set is valid + expect_true(dbIsValid(res2)) + #' and must be cleared with `dbClearResult()`. + dbClearResult(res2) +}) + +test_that("send_query_params", { + placeholder_funs <- get_placeholder_funs(ctx) + for (placeholder_fun in placeholder_funs) { + placeholder <- placeholder_fun(1) + query <- paste0("SELECT ", placeholder, " + 1.0 AS a") + values <- trivial_values(3) - 1 + params <- `::`(stats, setNames)(list(values), names(placeholder)) + rs <- dbSendQuery(con, query, params = params) + ret <- dbFetch(rs) + expect_equal(ret, trivial_df(3), info = placeholder) + dbClearResult(rs) + } +}) + +test_that("fetch_formals", { + # + expect_equal(names(formals(dbFetch)), c("res", "n", "...")) +}) + +test_that("fetch_atomic", { + #' @return + #' `dbFetch()` always returns a [data.frame] + #' with as many rows as records were fetched and as many + #' columns as fields in the result set, + #' even if the result is a single value + query <- trivial_query() + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res)) + expect_equal(rows, data.frame(a = 1.5)) +}) + +test_that("fetch_one_row", { + #' or has one + query <- trivial_query(3, letters[1:3]) + result <- trivial_df(3, letters[1:3]) + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res)) + expect_identical(rows, result) +}) + +test_that("fetch_zero_rows", { + #' or zero rows. + query <- + "SELECT * FROM (SELECT 1 as a, 2 as b, 3 as c) AS x WHERE (1 = 0)" + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res)) + expect_identical(class(rows), "data.frame") +}) + +test_that("fetch_closed", { + #' @section Failure modes: + #' An attempt to fetch from a closed result set raises an error. + query <- trivial_query() + + res <- dbSendQuery(con, query) + dbClearResult(res) + + expect_error(dbFetch(res)) +}) + +test_that("fetch_n_bad", { + #' If the `n` argument is not an atomic whole number + #' greater or equal to -1 or Inf, an error is raised, + query <- trivial_query() + res <- local_result(dbSendQuery(con, query)) + expect_error(dbFetch(res, -2)) + expect_error(dbFetch(res, 1.5)) + expect_error(dbFetch(res, integer())) + expect_error(dbFetch(res, 1:3)) + expect_error(dbFetch(res, NA_integer_)) +}) + +test_that("fetch_n_good_after_bad", { + #' but a subsequent call to `dbFetch()` with proper `n` argument succeeds. + query <- trivial_query() + res <- local_result(dbSendQuery(con, query)) + expect_error(dbFetch(res, NA_integer_)) + rows <- check_df(dbFetch(res)) + expect_equal(rows, data.frame(a = 1.5)) +}) + +test_that("fetch_multi_row_single_column", { + #' @section Specification: + #' Fetching multi-row queries with one + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(3) + + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res)) + expect_identical(rows, result) +}) + +test_that("fetch_multi_row_multi_column", { + #' or more columns by default returns the entire result. + query <- sql_union( + .ctx = ctx, paste("SELECT", 1:5 + 0.5, "AS a,", 4:0 + 0.5, "AS b"), .order_by = "a" + ) + + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res)) + expect_identical(rows, data.frame(a = 1:5 + 0.5, b = 4:0 + 0.5)) +}) + +test_that("fetch_n_progressive", { + #' Multi-row queries can also be fetched progressively + query <- trivial_query(25, .ctx = ctx, .order_by = "a") + result <- trivial_df(25) + + res <- local_result(dbSendQuery(con, query)) + #' by passing a whole number ([integer] + rows <- check_df(dbFetch(res, 10L)) + expect_identical(rows, unrowname(result[1:10, , drop = FALSE])) + + #' or [numeric]) + rows <- check_df(dbFetch(res, 10)) + expect_identical(rows, unrowname(result[11:20, , drop = FALSE])) + + #' as the `n` argument. + rows <- check_df(dbFetch(res, n = 5)) + expect_identical(rows, unrowname(result[21:25, , drop = FALSE])) +}) + +test_that("fetch_n_multi_row_inf", { + #' A value of [Inf] for the `n` argument is supported + #' and also returns the full result. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(3) + + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res, n = Inf)) + expect_identical(rows, result) +}) + +test_that("fetch_n_more_rows", { + #' If more rows than available are fetched, the result is returned in full + #' without warning. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(3) + + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res, 5L)) + expect_identical(rows, result) + #' If fewer rows than requested are returned, further fetches will + #' return a data frame with zero rows. + rows <- check_df(dbFetch(res)) + expect_identical(rows, result[0, , drop = FALSE]) +}) + +test_that("fetch_n_zero_rows", { + #' If zero rows are fetched, the columns of the data frame are still fully + #' typed. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(0) + + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res, 0L)) + expect_identical(rows, result) +}) + +test_that("fetch_n_premature_close", { + #' Fetching fewer rows than available is permitted, + #' no warning is issued when clearing the result set. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(2) + + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res, 2L)) + expect_identical(rows, result) +}) + +test_that("fetch_row_names", { + #' A column named `row_names` is treated like any other column. + query <- trivial_query(column = "row_names") + result <- trivial_df(column = "row_names") + + res <- local_result(dbSendQuery(con, query)) + rows <- check_df(dbFetch(res)) + expect_identical(rows, result) + expect_identical(.row_names_info(rows), -1L) +}) + +test_that("clear_result_formals", { + # + expect_equal(names(formals(dbClearResult)), c("res", "...")) +}) + +test_that("clear_result_return_query", { + #' @return + #' `dbClearResult()` returns `TRUE`, invisibly, for result sets obtained from + #' both `dbSendQuery()` + res <- dbSendQuery(con, trivial_query()) + expect_invisible_true(dbClearResult(res)) +}) + +test_that("cannot_clear_result_twice_query", { + #' @section Failure modes: + #' An attempt to close an already closed result set issues a warning + res <- dbSendQuery(con, trivial_query()) + dbClearResult(res) + expect_warning(expect_invisible_true(dbClearResult(res))) +}) + +test_that("get_query_formals", { + # + expect_equal(names(formals(dbGetQuery)), c("conn", "statement", "...")) +}) + +test_that("get_query_atomic", { + #' @return + #' `dbGetQuery()` always returns a [data.frame] + #' with as many rows as records were fetched and as many + #' columns as fields in the result set, + #' even if the result is a single value + query <- trivial_query() + + rows <- check_df(dbGetQuery(con, query)) + expect_equal(rows, data.frame(a = 1.5)) +}) + +test_that("get_query_one_row", { + #' or has one + query <- trivial_query(3, letters[1:3]) + result <- trivial_df(3, letters[1:3]) + + rows <- check_df(dbGetQuery(con, query)) + expect_identical(rows, result) +}) + +test_that("get_query_zero_rows", { + #' or zero rows. + # Not all SQL dialects seem to support the query used here. + query <- + "SELECT * FROM (SELECT 1 as a, 2 as b, 3 as c) AS x WHERE (1 = 0)" + + rows <- check_df(dbGetQuery(con, query)) + expect_identical(names(rows), letters[1:3]) + expect_identical(dim(rows), c(0L, 3L)) +}) + +test_that("get_query_syntax_error", { + #' if the syntax of the query is invalid, + expect_error(dbGetQuery(con, "SELLECT")) +}) + +test_that("get_query_non_string", { + #' or if the query is not a non-`NA` string. + expect_error(dbGetQuery(con, character())) + expect_error(dbGetQuery(con, letters)) + expect_error(dbGetQuery(con, NA_character_)) +}) + +test_that("get_query_n_bad", { + #' If the `n` argument is not an atomic whole number + #' greater or equal to -1 or Inf, an error is raised, + query <- trivial_query() + expect_error(dbGetQuery(con, query, n = -2)) + expect_error(dbGetQuery(con, query, n = 1.5)) + expect_error(dbGetQuery(con, query, n = integer())) + expect_error(dbGetQuery(con, query, n = 1:3)) + expect_error(dbGetQuery(con, query, n = NA_integer_)) +}) + +test_that("get_query_good_after_bad_n", { + #' but a subsequent call to `dbGetQuery()` with proper `n` argument succeeds. + query <- trivial_query() + expect_error(dbGetQuery(con, query, n = NA_integer_)) + rows <- check_df(dbGetQuery(con, query)) + expect_equal(rows, data.frame(a = 1.5)) +}) + +test_that("get_query_row_names", { + #' A column named `row_names` is treated like any other column. + query <- trivial_query(column = "row_names") + result <- trivial_df(column = "row_names") + + rows <- check_df(dbGetQuery(con, query)) + expect_identical(rows, result) + expect_identical(.row_names_info(rows), -1L) +}) + +test_that("get_query_multi_row_single_column", { + #' The `n` argument specifies the number of rows to be fetched. + #' If omitted, fetching multi-row queries with one + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(3) + + rows <- check_df(dbGetQuery(con, query)) + expect_identical(rows, result) +}) + +test_that("get_query_multi_row_multi_column", { + #' or more columns returns the entire result. + query <- sql_union( + .ctx = ctx, paste("SELECT", 1:5 + 0.5, "AS a,", 4:0 + 0.5, "AS b"), .order_by = "a" + ) + + rows <- check_df(dbGetQuery(con, query)) + expect_identical(rows, data.frame(a = 1:5 + 0.5, b = 4:0 + 0.5)) +}) + +test_that("get_query_n_multi_row_inf", { + #' A value of [Inf] for the `n` argument is supported + #' and also returns the full result. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(3) + + rows <- check_df(dbGetQuery(con, query, n = Inf)) + expect_identical(rows, result) +}) + +test_that("get_query_n_more_rows", { + #' If more rows than available are fetched (by passing a too large value for + #' `n`), the result is returned in full without warning. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(3) + + rows <- check_df(dbGetQuery(con, query, n = 5L)) + expect_identical(rows, result) +}) + +test_that("get_query_n_zero_rows", { + #' If zero rows are requested, the columns of the data frame are still fully + #' typed. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(0) + + rows <- check_df(dbGetQuery(con, query, n = 0L)) + expect_identical(rows, result) +}) + +test_that("get_query_n_incomplete", { + #' Fetching fewer rows than available is permitted, + #' no warning is issued. + query <- trivial_query(3, .ctx = ctx, .order_by = "a") + result <- trivial_df(2) + + rows <- check_df(dbGetQuery(con, query, n = 2L)) + expect_identical(rows, result) +}) + +test_that("get_query_params", { + placeholder_funs <- get_placeholder_funs(ctx) + for (placeholder_fun in placeholder_funs) { + placeholder <- placeholder_fun(1) + query <- paste0("SELECT ", placeholder, " + 1.0 AS a") + values <- trivial_values(3) - 1 + params <- `::`(stats, setNames)(list(values), names(placeholder)) + ret <- dbGetQuery(con, query, params = params) + expect_equal(ret, trivial_df(3), info = placeholder) + } +}) + +test_that("send_statement_formals", { + # + expect_equal(names(formals(dbSendStatement)), c("conn", "statement", "...")) +}) + +test_that("send_statement_non_string", { + #' or if the statement is not a non-`NA` string. + expect_error(dbSendStatement(con, character())) + expect_error(dbSendStatement(con, letters)) + expect_error(dbSendStatement(con, NA_character_)) +}) + +test_that("send_statement_syntax_error", { + #' @section Failure modes: + expect_error(dbSendStatement(con, "CREATTE", params = list())) + expect_error(dbSendStatement(con, "CREATTE", immediate = TRUE)) +}) + +test_that("send_statement_stale_warning", { + con <- connect(ctx) + on.exit(dbDisconnect(con)) + expect_warning(dbSendStatement(con, trivial_query()), NA) + expect_warning({ + dbDisconnect(con) + gc() + }) + on.exit(NULL) +}) + +test_that("send_statement_params", { + placeholder_funs <- get_placeholder_funs(ctx) + for (placeholder_fun in placeholder_funs) { + table_name <- random_table_name() + local_remove_test_table(con, table_name) + dbWriteTable(con, table_name, data.frame(a = as.numeric(1:3))) + placeholder <- placeholder_fun(1) + query <- paste0("DELETE FROM ", table_name, " WHERE a > ", placeholder) + values <- 1.5 + params <- `::`(stats, setNames)(list(values), names(placeholder)) + rs <- dbSendStatement(con, query, params = params) + expect_equal(dbGetRowsAffected(rs), 2, info = placeholder) + dbClearResult(rs) + } +}) + +test_that("execute_formals", { + # + expect_equal(names(formals(dbExecute)), c("conn", "statement", "...")) +}) + +test_that("execute_syntax_error", { + #' if the syntax of the statement is invalid, + expect_error(dbExecute(con, "CREATTE")) +}) + +test_that("execute_non_string", { + #' or if the statement is not a non-`NA` string. + expect_error(dbExecute(con, character())) + expect_error(dbExecute(con, letters)) + expect_error(dbExecute(con, NA_character_)) +}) + +test_that("execute_params", { + placeholder_funs <- get_placeholder_funs(ctx) + for (placeholder_fun in placeholder_funs) { + table_name <- random_table_name() + local_remove_test_table(con, table_name) + dbWriteTable(con, table_name, data.frame(a = as.numeric(1:3))) + placeholder <- placeholder_fun(1) + query <- paste0("DELETE FROM ", table_name, " WHERE a > ", placeholder) + values <- 1.5 + params <- `::`(stats, setNames)(list(values), names(placeholder)) + ret <- dbExecute(con, query, params = params) + expect_equal(ret, 2, info = placeholder) + } +}) + +test_that("data_type_create_table", { + check_connection_data_type <- function(value) { + table_name <- random_table_name() + local_remove_test_table(con, table_name) + query <- paste0("CREATE TABLE ", table_name, " (a ", dbDataType(con, value), ")") + eval(bquote(dbExecute(con, .(query)))) + } + expect_conn_has_data_type <- function(value) { + eval(bquote(expect_error(check_connection_data_type(.(value)), NA))) + } + expect_conn_has_data_type(logical(1)) + expect_conn_has_data_type(integer(1)) + expect_conn_has_data_type(numeric(1)) + expect_conn_has_data_type(character(1)) + expect_conn_has_data_type(Sys.Date()) + expect_conn_has_data_type(Sys.time()) + if (!isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + expect_conn_has_data_type(list(as.raw(0:10))) + } +}) + +test_that("data_integer", { + #' @section Specification: + #' The column types of the returned data frame depend on the data returned: + #' - [integer] (or coercible to an integer) for integer values between -2^31 and 2^31 - 1, + #' with [NA] for SQL `NULL` values + test_select_with_null(.ctx = ctx, con, 1L ~ equals_one, -100L ~ equals_minus_100) +}) + +test_that("data_numeric", { + #' - [numeric] for numbers with a fractional component, + #' with NA for SQL `NULL` values + test_select_with_null(.ctx = ctx, con, 1.5, -100.5) +}) + +test_that("data_logical", { + #' - [logical] for Boolean values (some backends may return an integer); + int_values <- 1:0 + values <- ctx$tweaks$logical_return(as.logical(int_values)) + + sql_names <- paste0("CAST(", int_values, " AS ", dbDataType(con, logical()), ")") + + #' with NA for SQL `NULL` values + test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names)) +}) + +test_that("data_character", { + #' - [character] for text, + values <- get_texts() + test_funs <- rep(list(has_utf8_or_ascii_encoding), length(values)) + sql_names <- as.character(dbQuoteString(con, values)) + + #' with NA for SQL `NULL` values + test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names)) + test_select_with_null(.ctx = ctx, con, .dots = setNames(test_funs, sql_names)) +}) + +test_that("data_raw", { + if (isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + skip("tweak: omit_blob_tests") + } + is_raw_list <- function(x) { + is.list(x) && is.raw(x[[1L]]) + } + values <- list(is_raw_list) + sql_names <- `$`(`$`(ctx, tweaks), blob_cast)(`::`(DBI, dbQuoteLiteral)(con, list(raw(1)))) + test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names)) +}) + +test_that("data_date", { + as_date_equals_to <- function(x) { + lapply(x, function(xx) { + function(value) as.Date(value) == xx + }) + } + char_values <- paste0("2015-01-", sprintf("%.2d", 1:12)) + values <- as_date_equals_to(as.Date(char_values)) + sql_names <- `$`(`$`(ctx, tweaks), date_cast)(char_values) + test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names)) +}) + +test_that("data_date_current", { + #' (also applies to the return value of the SQL function `current_date`) + test_select_with_null( + .ctx = ctx, con, + "current_date" ~ is_roughly_current_date + ) +}) + +test_that("data_time", { + as_hms_equals_to <- function(x) { + lapply(x, function(xx) { + function(value) `::`(hms, as_hms)(value) == xx + }) + } + char_values <- c("00:00:00", "12:34:56") + time_values <- as_hms_equals_to(`::`(hms, as_hms)(char_values)) + sql_names <- `$`(`$`(ctx, tweaks), time_cast)(char_values) + test_select_with_null(.ctx = ctx, con, .dots = setNames(time_values, sql_names)) +}) + +test_that("data_time_current", { + #' (also applies to the return value of the SQL function `current_time`) + test_select_with_null( + .ctx = ctx, con, + "current_time" ~ coercible_to_time + ) +}) + +test_that("data_timestamp", { + coercible_to_timestamp <- function(x) { + x_timestamp <- try_silent(as.POSIXct(x)) + !is.null(x_timestamp) && all(is.na(x) == is.na(x_timestamp)) + } + char_values <- c("2015-10-11 00:00:00", "2015-10-11 12:34:56") + time_values <- rep(list(coercible_to_timestamp), 2L) + sql_names <- `$`(`$`(ctx, tweaks), timestamp_cast)(char_values) + test_select_with_null(.ctx = ctx, con, .dots = setNames(time_values, sql_names)) +}) + +test_that("data_timestamp_current", { + coercible_to_timestamp <- function(x) { + x_timestamp <- try_silent(as.POSIXct(x)) + !is.null(x_timestamp) && all(is.na(x) == is.na(x_timestamp)) + } + is_roughly_current_timestamp <- function(x) { + coercible_to_timestamp(x) && (Sys.time() - as.POSIXct(x, tz = "UTC") <= `::`(hms, hms)(2)) + } + test_select_with_null(.ctx = ctx, con, "current_timestamp" ~ is_roughly_current_timestamp) +}) + +test_that("data_date_typed", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + char_values <- paste0("2015-01-", sprintf("%.2d", 1:12)) + values <- lapply(char_values, as_numeric_date) + sql_names <- `$`(`$`(ctx, tweaks), date_cast)(char_values) + test_select_with_null(.ctx = ctx, con, .dots = setNames(values, sql_names)) +}) + +test_that("data_date_current_typed", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + test_select_with_null(.ctx = ctx, con, "current_date" ~ is_roughly_current_date_typed) +}) + +test_that("data_timestamp_typed", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + char_values <- c("2015-10-11 00:00:00", "2015-10-11 12:34:56") + timestamp_values <- rep(list(is_timestamp), 2L) + sql_names <- `$`(`$`(ctx, tweaks), timestamp_cast)(char_values) + test_select_with_null(.ctx = ctx, con, .dots = setNames(timestamp_values, sql_names)) +}) + +test_that("data_timestamp_current_typed", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + test_select_with_null(.ctx = ctx, con, "current_timestamp" ~ is_roughly_current_timestamp_typed) +}) + +test_that("data_64_bit_numeric", { + as_numeric_identical_to <- function(x) { + lapply(x, function(xx) { + function(value) as.numeric(value) == xx + }) + } + char_values <- c("10000000000", "-10000000000") + test_values <- as_numeric_identical_to(as.numeric(char_values)) + test_select_with_null(.ctx = ctx, con, .dots = setNames(test_values, char_values)) +}) + +test_that("data_64_bit_numeric_warning", { + as_numeric_equals_to <- function(x) { + lapply( + x, + function(xx) { + function(value) isTRUE(all.equal(as.numeric(value), xx)) + } + ) + } + char_values <- c(" 1234567890123456789", "-1234567890123456789") + num_values <- as.numeric(char_values) + test_values <- as_numeric_equals_to(num_values) + suppressWarnings( + expect_warning( + test_select(.ctx = ctx, con, .dots = setNames(test_values, char_values), .add_null = "none") + ) + ) + suppressWarnings( + expect_warning( + test_select(.ctx = ctx, con, .dots = setNames(test_values, char_values), .add_null = "above") + ) + ) + suppressWarnings( + expect_warning( + test_select(.ctx = ctx, con, .dots = setNames(test_values, char_values), .add_null = "below") + ) + ) +}) + +test_that("data_64_bit_lossless", { + as_character_equals_to <- function(x) { + lapply(x, function(xx) { + function(value) as.character(value) == xx + }) + } + char_values <- c("1234567890123456789", "-1234567890123456789") + test_values <- as_character_equals_to(char_values) + test_select_with_null(.ctx = ctx, con, .dots = setNames(test_values, char_values)) +}) diff --git a/tests/testthat/test-dbitest-sql.R b/tests/testthat/test-dbitest-sql.R new file mode 100644 index 000000000..8456d4249 --- /dev/null +++ b/tests/testthat/test-dbitest-sql.R @@ -0,0 +1,1500 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("quote_string_formals", { + # + expect_equal(names(formals(dbQuoteString)), c("conn", "x", "...")) +}) + +test_that("quote_string_return", { + #' @return + #' `dbQuoteString()` returns an object that can be coerced to [character], + simple <- "simple" + simple_out <- dbQuoteString(con, simple) + expect_error(as.character(simple_out), NA) + expect_type(as.character(simple_out), "character") + expect_equal(length(simple_out), 1L) +}) + +test_that("quote_string_vectorized", { + #' of the same length as the input. + letters_out <- dbQuoteString(con, letters) + expect_equal(length(letters_out), length(letters)) + + #' For an empty character vector this function returns a length-0 object. + empty_out <- dbQuoteString(con, character()) + expect_equal(length(empty_out), 0L) +}) + +test_that("quote_string_double", { + simple <- "simple" + simple_out <- dbQuoteString(con, simple) + + letters_out <- dbQuoteString(con, letters) + + empty <- character() + empty_out <- dbQuoteString(con, character()) + + #' + #' When passing the returned object again to `dbQuoteString()` + #' as `x` + #' argument, it is returned unchanged. + expect_identical(dbQuoteString(con, simple_out), simple_out) + expect_identical(dbQuoteString(con, letters_out), letters_out) + expect_identical(dbQuoteString(con, empty_out), empty_out) + #' Passing objects of class [SQL] should also return them unchanged. + expect_identical(dbQuoteString(con, SQL(simple)), SQL(simple)) + expect_identical(dbQuoteString(con, SQL(letters)), SQL(letters)) + expect_identical(dbQuoteString(con, SQL(empty)), SQL(empty)) + + #' (For backends it may be most convenient to return [SQL] objects + #' to achieve this behavior, but this is not required.) +}) + +test_that("quote_string_roundtrip", { + do_test_string <- function(x) { + query <- paste0("SELECT ", paste(dbQuoteString(con, x), collapse = ", ")) + x_out <- check_df(dbGetQuery(con, query)) + expect_equal(nrow(x_out), 1L) + expect_identical(unlist(unname(x_out)), x) + } + expand_char <- function(...) { + df <- expand.grid(..., stringsAsFactors = FALSE) + do.call(paste0, df) + } + test_chars <- c("", " ", "\t", "'", "\"", "`", "\n") + test_strings_0 <- expand_char(test_chars, "a", test_chars, "b", test_chars) + test_strings_1 <- as.character(dbQuoteString(con, test_strings_0)) + test_strings_2 <- as.character(dbQuoteString(con, test_strings_1)) + test_strings <- c(test_strings_0, test_strings_1, test_strings_2) + do_test_string(test_strings) +}) + +test_that("quote_string_na", { + null <- dbQuoteString(con, NA_character_) + quoted_null <- dbQuoteString(con, as.character(null)) + na <- dbQuoteString(con, "NA") + quoted_na <- dbQuoteString(con, as.character(na)) + + query <- paste0( + "SELECT ", + null, " AS null_return,", + na, " AS na_return,", + quoted_null, " AS quoted_null,", + quoted_na, " AS quoted_na" + ) + + #' If `x` is `NA`, the result must merely satisfy [is.na()]. + rows <- check_df(dbGetQuery(con, query)) + expect_true(is.na(rows$null_return)) + #' The strings `"NA"` or `"NULL"` are not treated specially. + expect_identical(rows$na_return, "NA") + expect_identical(rows$quoted_null, as.character(null)) + expect_identical(rows$quoted_na, as.character(na)) +}) + +test_that("quote_string_na_is_null", { + #' + #' `NA` should be translated to an unquoted SQL `NULL`, + null <- dbQuoteString(con, NA_character_) + #' so that the query `SELECT * FROM (SELECT 1) a WHERE ... IS NULL` + rows <- check_df(dbGetQuery(con, paste0("SELECT * FROM (SELECT 1) a WHERE ", null, " IS NULL"))) + #' returns one row. + expect_equal(nrow(rows), 1L) +}) + +test_that("quote_string_error", { + #' @section Failure modes: + #' + #' Passing a numeric, + expect_error(dbQuoteString(con, c(1, 2, 3))) + #' integer, + expect_error(dbQuoteString(con, 1:3)) + #' logical, + expect_error(dbQuoteString(con, c(TRUE, FALSE))) + #' or raw vector, + expect_error(dbQuoteString(con, as.raw(1:3))) + #' or a list + expect_error(dbQuoteString(con, as.list(1:3))) + #' for the `x` argument raises an error. +}) + +test_that("quote_literal_formals", { + # + expect_equal(names(formals(dbQuoteLiteral)), c("conn", "x", "...")) +}) + +test_that("quote_literal_return", { + #' @return + #' `dbQuoteLiteral()` returns an object that can be coerced to [character], + simple <- "simple" + simple_out <- dbQuoteLiteral(con, simple) + expect_error(as.character(simple_out), NA) + expect_type(as.character(simple_out), "character") + expect_equal(length(simple_out), 1L) +}) + +test_that("quote_literal_vectorized", { + #' of the same length as the input. + letters_out <- dbQuoteLiteral(con, letters) + expect_equal(length(letters_out), length(letters)) +}) + +test_that("quote_literal_empty", { + if (as.package_version(`$`(`$`(ctx, tweaks), dbitest_version)) < "1.7.2") { + skip(paste0("tweak: dbitest_version: ", `$`(`$`(ctx, tweaks), dbitest_version))) + } + expect_equal(length(dbQuoteLiteral(con, integer())), 0L) + expect_equal(length(dbQuoteLiteral(con, numeric())), 0L) + expect_equal(length(dbQuoteLiteral(con, character())), 0L) + expect_equal(length(dbQuoteLiteral(con, logical())), 0L) + expect_equal(length(dbQuoteLiteral(con, Sys.Date()[0])), 0L) + expect_equal(length(dbQuoteLiteral(con, Sys.time()[0])), 0L) + expect_equal(length(dbQuoteLiteral(con, list())), 0L) +}) + +test_that("quote_literal_double", { + simple <- "simple" + simple_out <- dbQuoteLiteral(con, simple) + + letters_out <- dbQuoteLiteral(con, letters) + + empty <- character() + empty_out <- dbQuoteLiteral(con, character()) + + #' + #' When passing the returned object again to `dbQuoteLiteral()` + #' as `x` + #' argument, it is returned unchanged. + expect_identical(dbQuoteLiteral(con, simple_out), simple_out) + expect_identical(dbQuoteLiteral(con, letters_out), letters_out) + expect_identical(dbQuoteLiteral(con, empty_out), empty_out) + #' Passing objects of class [SQL] should also return them unchanged. + expect_identical(dbQuoteLiteral(con, SQL(simple)), SQL(simple)) + expect_identical(dbQuoteLiteral(con, SQL(letters)), SQL(letters)) + expect_identical(dbQuoteLiteral(con, SQL(empty)), SQL(empty)) + + #' (For backends it may be most convenient to return [SQL] objects + #' to achieve this behavior, but this is not required.) +}) + +test_that("quote_literal_roundtrip", { + do_test_literal <- function(x) { + literals <- vapply(x, dbQuoteLiteral, conn = con, character(1)) + query <- paste0("SELECT ", paste(literals, collapse = ", ")) + x_out <- check_df(dbGetQuery(con, query)) + expect_equal(nrow(x_out), 1L) + is_logical <- vapply(x, is.logical, FUN.VALUE = logical(1)) + x_out[is_logical] <- lapply(x_out[is_logical], as.logical) + is_numeric <- vapply(x, is.numeric, FUN.VALUE = logical(1)) + x_out[is_numeric] <- lapply(x_out[is_numeric], as.numeric) + expect_equal(as.list(unname(x_out)), x) + } + test_literals <- list(1L, 2.5, "string", TRUE) + do_test_literal(test_literals) +}) + +test_that("quote_literal_na", { + null <- dbQuoteLiteral(con, NA_character_) + quoted_null <- dbQuoteLiteral(con, as.character(null)) + na <- dbQuoteLiteral(con, "NA") + quoted_na <- dbQuoteLiteral(con, as.character(na)) + + query <- paste0( + "SELECT ", + null, " AS null_return,", + na, " AS na_return,", + quoted_null, " AS quoted_null,", + quoted_na, " AS quoted_na" + ) + + #' If `x` is `NA`, the result must merely satisfy [is.na()]. + rows <- check_df(dbGetQuery(con, query)) + expect_true(is.na(rows$null_return)) + #' The literals `"NA"` or `"NULL"` are not treated specially. + expect_identical(rows$na_return, "NA") + expect_identical(rows$quoted_null, as.character(null)) + expect_identical(rows$quoted_na, as.character(na)) +}) + +test_that("quote_literal_na_is_null", { + #' + #' `NA` should be translated to an unquoted SQL `NULL`, + null <- dbQuoteLiteral(con, NA_character_) + #' so that the query `SELECT * FROM (SELECT 1) a WHERE ... IS NULL` + rows <- check_df(dbGetQuery(con, paste0("SELECT * FROM (SELECT 1) a WHERE ", null, " IS NULL"))) + #' returns one row. + expect_equal(nrow(rows), 1L) +}) + +test_that("quote_literal_error", { + #' @section Failure modes: + #' + #' Passing a list + expect_error(dbQuoteString(con, as.list(1:3))) + #' for the `x` argument raises an error. +}) + +test_that("quote_identifier_formals", { + # + expect_equal(names(formals(dbQuoteIdentifier)), c("conn", "x", "...")) +}) + +test_that("quote_identifier_return", { + #' @return + #' `dbQuoteIdentifier()` returns an object that can be coerced to [character], + simple_out <- dbQuoteIdentifier(con, "simple") + expect_error(as.character(simple_out), NA) + expect_type(as.character(simple_out), "character") +}) + +test_that("quote_identifier_vectorized", { + #' of the same length as the input. + simple <- "simple" + simple_out <- dbQuoteIdentifier(con, simple) + expect_equal(length(simple_out), 1L) + + letters_out <- dbQuoteIdentifier(con, letters) + expect_equal(length(letters_out), length(letters)) + + #' For an empty character vector this function returns a length-0 object. + empty <- character() + empty_out <- dbQuoteIdentifier(con, empty) + expect_equal(length(empty_out), 0L) + + #' The names of the input argument are preserved in the output. + unnamed <- letters + unnamed_out <- dbQuoteIdentifier(con, unnamed) + expect_null(names(unnamed_out)) + named <- stats::setNames(LETTERS[1:3], letters[1:3]) + named_out <- dbQuoteIdentifier(con, named) + expect_equal(names(named_out), letters[1:3]) + + #' When passing the returned object again to `dbQuoteIdentifier()` + #' as `x` + #' argument, it is returned unchanged. + expect_identical(dbQuoteIdentifier(con, simple_out), simple_out) + expect_identical(dbQuoteIdentifier(con, letters_out), letters_out) + expect_identical(dbQuoteIdentifier(con, empty_out), empty_out) + #' Passing objects of class [SQL] should also return them unchanged. + expect_identical(dbQuoteIdentifier(con, SQL(simple)), SQL(simple)) + expect_identical(dbQuoteIdentifier(con, SQL(letters)), SQL(letters)) + expect_identical(dbQuoteIdentifier(con, SQL(empty)), SQL(empty)) + + #' (For backends it may be most convenient to return [SQL] objects + #' to achieve this behavior, but this is not required.) +}) + +test_that("quote_identifier_error", { + #' @section Failure modes: + #' + #' An error is raised if the input contains `NA`, + expect_error(dbQuoteIdentifier(con, NA)) + expect_error(dbQuoteIdentifier(con, NA_character_)) + expect_error(dbQuoteIdentifier(con, c("a", NA_character_))) + #' but not for an empty string. + expect_error(dbQuoteIdentifier(con, ""), NA) +}) + +test_that("quote_identifier", { + #' @section Specification: + #' Calling [dbGetQuery()] for a query of the format `SELECT 1 AS ...` + #' returns a data frame with the identifier, unquoted, as column name. + #' Quoted identifiers can be used as table and column names in SQL queries, + simple <- dbQuoteIdentifier(con, "simple") + + #' in particular in queries like `SELECT 1 AS ...` + query <- trivial_query(column = simple) + rows <- check_df(dbGetQuery(con, query)) + expect_identical(names(rows), "simple") + expect_identical(unlist(unname(rows)), 1.5) + + #' and `SELECT * FROM (SELECT 1) ...`. + query <- paste0("SELECT * FROM (", trivial_query(), ") ", simple) + rows <- check_df(dbGetQuery(con, query)) + expect_identical(unlist(unname(rows)), 1.5) +}) + +test_that("quote_identifier_string", { + #' The method must use a quoting mechanism that is unambiguously different + #' from the quoting mechanism used for strings, so that a query like + #' `SELECT ... FROM (SELECT 1 AS ...)` + query <- paste0( + "SELECT ", dbQuoteIdentifier(con, "b"), " FROM (", + "SELECT 1 AS ", dbQuoteIdentifier(con, "a"), ")" + ) + + #' throws an error if the column names do not match. + eval(bquote(expect_error(dbGetQuery(con, .(query))))) +}) + +test_that("quote_identifier_special", { + with_space_in <- "with space" + with_space <- dbQuoteIdentifier(con, with_space_in) + with_dot_in <- "with.dot" + with_dot <- dbQuoteIdentifier(con, with_dot_in) + with_comma_in <- "with,comma" + with_comma <- dbQuoteIdentifier(con, with_comma_in) + with_quote_in <- as.character(dbQuoteString(con, "a")) + with_quote <- dbQuoteIdentifier(con, with_quote_in) + empty_in <- "" + empty <- dbQuoteIdentifier(con, empty_in) + quoted_empty <- dbQuoteIdentifier(con, as.character(empty)) + quoted_with_space <- dbQuoteIdentifier(con, as.character(with_space)) + quoted_with_dot <- dbQuoteIdentifier(con, as.character(with_dot)) + quoted_with_comma <- dbQuoteIdentifier(con, as.character(with_comma)) + quoted_with_quote <- dbQuoteIdentifier(con, as.character(with_quote)) + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + skip("tweak: strict_identifier") + } + query <- paste0("SELECT ", "2.5 as", with_space, ",", "3.5 as", with_dot, ",", "4.5 as", with_comma, ",", "5.5 as", with_quote, ",", "6.5 as", quoted_empty, ",", "7.5 as", quoted_with_space, ",", "8.5 as", quoted_with_dot, ",", "9.5 as", quoted_with_comma, ",", "10.5 as", quoted_with_quote) + rows <- check_df(dbGetQuery(con, query)) + expect_identical( + names(rows), + c(with_space_in, with_dot_in, with_comma_in, with_quote_in, as.character(empty), as.character(with_space), as.character(with_dot), as.character(with_comma), as.character(with_quote)) + ) + expect_identical(unlist(unname(rows)), 2:10 + 0.5) +}) + +test_that("unquote_identifier_formals", { + # + expect_equal(names(formals(dbUnquoteIdentifier)), c("conn", "x", "...")) +}) + +test_that("unquote_identifier_return", { + #' @return + #' `dbUnquoteIdentifier()` returns a list of objects + simple_in <- dbQuoteIdentifier(con, "simple") + simple_out <- dbUnquoteIdentifier(con, simple_in) + expect_type(simple_out, "list") +}) + +test_that("unquote_identifier_vectorized", { + #' of the same length as the input. + simple_in <- dbQuoteIdentifier(con, "simple") + simple_out <- dbUnquoteIdentifier(con, simple_in) + expect_equal(length(simple_out), 1L) + + letters_in <- dbQuoteIdentifier(con, letters) + letters_out <- dbUnquoteIdentifier(con, letters_in) + expect_equal(length(letters_out), length(letters_in)) + + #' For an empty character vector this function returns a length-0 object. + empty <- character() + empty_in <- dbQuoteIdentifier(con, empty) + empty_out <- dbUnquoteIdentifier(con, empty_in) + expect_equal(length(empty_out), 0) + + #' The names of the input argument are preserved in the output. + unnamed_in <- dbQuoteIdentifier(con, letters) + unnamed_out <- dbUnquoteIdentifier(con, unnamed_in) + expect_null(names(unnamed_out)) + named_in <- dbQuoteIdentifier(con, stats::setNames(LETTERS[1:3], letters[1:3])) + named_out <- dbUnquoteIdentifier(con, named_in) + expect_equal(names(named_out), letters[1:3]) + + #' When passing the first element of a returned object again to + #' `dbUnquoteIdentifier()` as `x` + #' argument, it is returned unchanged (but wrapped in a list). + expect_identical(dbUnquoteIdentifier(con, simple_out[[1]]), simple_out) + expect_identical(dbUnquoteIdentifier(con, letters_out[[1]]), letters_out[1]) + #' Passing objects of class [Id] should also return them unchanged (but wrapped in a list). + expect_identical(dbUnquoteIdentifier(con, Id(table = "simple")), list(Id(table = "simple"))) + + #' (For backends it may be most convenient to return [Id] objects + #' to achieve this behavior, but this is not required.) +}) + +test_that("unquote_identifier_error", { + #' @section Failure modes: + #' + #' An error is raised if plain character vectors are passed as the `x` + #' argument. + expect_error(dbUnquoteIdentifier(con, NA_character_)) + expect_error(dbUnquoteIdentifier(con, c("a", NA_character_))) + expect_error(dbUnquoteIdentifier(con, character())) +}) + +test_that("unquote_identifier_roundtrip", { + #' @section Specification: + #' For any character vector of length one, quoting (with [dbQuoteIdentifier()]) + #' then unquoting then quoting the first element is identical to just quoting. + simple_in <- dbQuoteIdentifier(con, "simple") + simple_out <- dbUnquoteIdentifier(con, simple_in) + simple_roundtrip <- dbQuoteIdentifier(con, simple_out[[1]]) + expect_identical(simple_in, simple_roundtrip) +}) + +test_that("unquote_identifier_special", { + with_space_in <- dbQuoteIdentifier(con, "with space") + with_space_out <- dbUnquoteIdentifier(con, with_space_in) + with_space_roundtrip <- dbQuoteIdentifier(con, with_space_out[[1]]) + with_dot_in <- dbQuoteIdentifier(con, "with.dot") + with_dot_out <- dbUnquoteIdentifier(con, with_dot_in) + with_dot_roundtrip <- dbQuoteIdentifier(con, with_dot_out[[1]]) + with_comma_in <- dbQuoteIdentifier(con, "with,comma") + with_comma_out <- dbUnquoteIdentifier(con, with_comma_in) + with_comma_roundtrip <- dbQuoteIdentifier(con, with_comma_out[[1]]) + with_quote_in <- dbQuoteIdentifier(con, as.character(dbQuoteString(con, "a"))) + with_quote_out <- dbUnquoteIdentifier(con, with_quote_in) + with_quote_roundtrip <- dbQuoteIdentifier(con, with_quote_out[[1]]) + quoted_with_space_in <- dbQuoteIdentifier(con, as.character(with_space_in)) + quoted_with_space_out <- dbUnquoteIdentifier(con, quoted_with_space_in) + quoted_with_space_roundtrip <- dbQuoteIdentifier(con, quoted_with_space_out[[1]]) + quoted_with_dot_in <- dbQuoteIdentifier(con, as.character(with_dot_in)) + quoted_with_dot_out <- dbUnquoteIdentifier(con, quoted_with_dot_in) + quoted_with_dot_roundtrip <- dbQuoteIdentifier(con, quoted_with_dot_out[[1]]) + quoted_with_comma_in <- dbQuoteIdentifier(con, as.character(with_comma_in)) + quoted_with_comma_out <- dbUnquoteIdentifier(con, quoted_with_comma_in) + quoted_with_comma_roundtrip <- dbQuoteIdentifier(con, quoted_with_comma_out[[1]]) + quoted_with_quote_in <- dbQuoteIdentifier(con, as.character(with_quote_in)) + quoted_with_quote_out <- dbUnquoteIdentifier(con, quoted_with_quote_in) + quoted_with_quote_roundtrip <- dbQuoteIdentifier(con, quoted_with_quote_out[[1]]) + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + skip("tweak: strict_identifier") + } + expect_identical(with_space_in, with_space_roundtrip) + expect_identical(with_dot_in, with_dot_roundtrip) + expect_identical(with_comma_in, with_comma_roundtrip) + expect_identical(with_quote_in, with_quote_roundtrip) + expect_identical(quoted_with_space_in, quoted_with_space_roundtrip) + expect_identical(quoted_with_dot_in, quoted_with_dot_roundtrip) + expect_identical(quoted_with_comma_in, quoted_with_comma_roundtrip) + expect_identical(quoted_with_quote_in, quoted_with_quote_roundtrip) +}) + +test_that("unquote_identifier_simple", { + #' Unquoting simple strings (consisting of only letters) wrapped with [SQL()] + #' and then quoting via [dbQuoteIdentifier()] gives the same result as just + #' quoting the string. + simple_in <- "simple" + simple_quoted <- dbQuoteIdentifier(con, simple_in) + simple_out <- dbUnquoteIdentifier(con, SQL(simple_in)) + simple_roundtrip <- dbQuoteIdentifier(con, simple_out[[1]]) + expect_identical(simple_roundtrip, simple_quoted) +}) + +test_that("unquote_identifier_table_schema", { + #' Similarly, unquoting expressions of the form `SQL("schema.table")` + #' and then quoting gives the same result as quoting the identifier + #' constructed by `Id(schema = "schema", table = "table")`. + schema_in <- "schema" + table_in <- "table" + simple_quoted <- dbQuoteIdentifier(con, Id(schema = schema_in, table = table_in)) + simple_out <- dbUnquoteIdentifier(con, SQL(paste0(schema_in, ".", table_in))) + simple_roundtrip <- dbQuoteIdentifier(con, simple_out[[1]]) + expect_identical(simple_roundtrip, simple_quoted) +}) + +test_that("read_table_formals", { + # + expect_equal(names(formals(dbReadTable)), c("conn", "name", "...")) +}) + +test_that("read_table_row_names_false", { + for (row.names in list(FALSE, NULL)) { + table_name <- random_table_name() + local_remove_test_table(con, table_name) + mtcars_in <- `::`(datasets, mtcars) + dbWriteTable(con, table_name, mtcars_in, row.names = TRUE) + mtcars_out <- check_df(dbReadTable(con, table_name, row.names = row.names)) + expect_true("row_names" %in% names(mtcars_out)) + expect_true(all(`$`(mtcars_out, row_names) %in% rownames(mtcars_in))) + expect_true(all(rownames(mtcars_in) %in% `$`(mtcars_out, row_names))) + expect_equal_df(mtcars_out[names(mtcars_out) != "row_names"], unrowname(mtcars_in)) + } +}) + +test_that("read_table_name", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + local_remove_test_table(con, table_name) + test_in <- data.frame(a = 1L) + dbWriteTable(con, table_name, test_in) + test_out <- check_df(dbReadTable(con, table_name)) + expect_equal_df(test_out, test_in) + test_out <- check_df(dbReadTable(con, dbQuoteIdentifier(con, table_name))) + expect_equal_df(test_out, test_in) + } +}) + +test_that("create_table_formals", { + # + expect_equal(names(formals(dbCreateTable)), c("conn", "name", "fields", "...", "row.names", "temporary")) +}) + +test_that("create_table_name", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + test_in <- trivial_df() + local_remove_test_table(con, table_name) + dbCreateTable(con, table_name, test_in) + test_out <- check_df(dbReadTable(con, dbQuoteIdentifier(con, table_name))) + expect_equal_df(test_out, test_in[0, , drop = FALSE]) + } +}) + +test_that("create_table_name_quoted", { + if (as.package_version(`$`(`$`(ctx, tweaks), dbitest_version)) < "1.7.2") { + skip(paste0("tweak: dbitest_version: ", `$`(`$`(ctx, tweaks), dbitest_version))) + } + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + test_in <- trivial_df() + local_remove_test_table(con, table_name) + dbCreateTable(con, dbQuoteIdentifier(con, table_name), test_in) + test_out <- check_df(dbReadTable(con, table_name)) + expect_equal_df(test_out, test_in[0, , drop = FALSE]) + } +}) + +test_that("create_temporary_table", { + table_name <- "dbit03" + expect_error(dbReadTable(con, table_name)) +}) + +test_that("create_table_visible_in_other_connection", { + penguins <- get_penguins(ctx) + + table_name <- "dbit04" + + #' in a pre-existing connection, + expect_equal_df(check_df(dbReadTable(con, table_name)), penguins[0, , drop = FALSE]) +}) + +test_that("create_roundtrip_keywords", { + #' SQL keywords can be used freely in table names, column names, and data. + tbl_in <- data.frame( + select = "unique", from = "join", where = "order", + stringsAsFactors = FALSE + ) + test_table_roundtrip(con, tbl_in, name = "exists") +}) + +test_that("create_roundtrip_quotes", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + skip("tweak: strict_identifier") + } + table_names <- c(as.character(dbQuoteIdentifier(con, "")), as.character(dbQuoteString(con, "")), "with space", ",") + for (table_name in table_names) { + tbl_in <- trivial_df(4, letters[1:4]) + names(tbl_in) <- c(as.character(dbQuoteIdentifier(con, "")), as.character(dbQuoteString(con, "")), "with space", ",") + test_table_roundtrip(con, tbl_in) + } +}) + +test_that("append_table_formals", { + # + expect_equal(names(formals(dbAppendTable)), c("conn", "name", "value", "...", "row.names")) +}) + +test_that("append_roundtrip_keywords", { + #' @section Specification: + #' SQL keywords can be used freely in table names, column names, and data. + tbl_in <- data.frame( + select = "unique", from = "join", where = "order", + stringsAsFactors = FALSE + ) + test_table_roundtrip(use_append = TRUE, con, tbl_in, name = "exists") +}) + +test_that("append_roundtrip_quotes_table_names", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + skip("tweak: strict_identifier") + } + table_names <- c(as.character(dbQuoteIdentifier(con, "")), as.character(dbQuoteString(con, "")), "with space", "a,b", "a\nb", "a\tb", "a\rb", "a\bb", "a\\Nb", "a\\tb", "a\\rb", "a\\bb", "a\\Zb") + tbl_in <- trivial_df() + for (table_name in table_names) { + test_table_roundtrip_one(con, tbl_in, use_append = TRUE, .add_na = FALSE) + } +}) + +test_that("append_roundtrip_quotes_column_names", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + skip("tweak: strict_identifier") + } + column_names <- c(as.character(dbQuoteIdentifier(con, "")), as.character(dbQuoteString(con, "")), "with space", "a,b", "a\nb", "a\tb", "a\rb", "a\bb", "a\\nb", "a\\tb", "a\\rb", "a\\bb", "a\\zb") + tbl_in <- trivial_df(length(column_names), column_names) + test_table_roundtrip_one(con, tbl_in, use_append = TRUE, .add_na = FALSE) +}) + +test_that("append_roundtrip_integer", { + #' The following data types must be supported at least, + #' and be read identically with [dbReadTable()]: + #' - integer + tbl_in <- data.frame(a = c(1:5)) + test_table_roundtrip(use_append = TRUE, con, tbl_in) +}) + +test_that("append_roundtrip_numeric", { + #' - numeric + tbl_in <- data.frame(a = c(seq(1, 3, by = 0.5))) + test_table_roundtrip(use_append = TRUE, con, tbl_in) + #' (the behavior for `Inf` and `NaN` is not specified) +}) + +test_that("append_roundtrip_logical", { + #' - logical + tbl_in <- data.frame(a = c(TRUE, FALSE, NA)) + tbl_exp <- tbl_in + tbl_exp$a <- ctx$tweaks$logical_return(tbl_exp$a) + test_table_roundtrip(use_append = TRUE, con, tbl_in, tbl_exp) +}) + +test_that("append_roundtrip_null", { + tbl_in <- data.frame(a = NA) + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + transform = function(tbl_out) { + `$`(tbl_out, a) <- as.logical(`$`(tbl_out, a)) + tbl_out + } + ) +}) + +test_that("append_roundtrip_64_bit_numeric", { + tbl_in <- data.frame(a = c(-1e+14, 1e+15)) + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + transform = function(tbl_out) { + `$`(tbl_out, a) <- as.numeric(`$`(tbl_out, a)) + tbl_out + }, + field.types = c(a = "BIGINT") + ) +}) + +test_that("append_roundtrip_64_bit_character", { + tbl_in <- data.frame(a = c(-1e+14, 1e+15)) + tbl_exp <- tbl_in + `$`(tbl_exp, a) <- format(`$`(tbl_exp, a), scientific = FALSE) + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + tbl_exp, + transform = function(tbl_out) { + `$`(tbl_out, a) <- as.character(`$`(tbl_out, a)) + tbl_out + }, + field.types = c(a = "BIGINT") + ) +}) + +test_that("append_roundtrip_character", { + #' - character (in both UTF-8 + tbl_in <- data.frame( + id = seq_along(get_texts()), + a = get_texts(), + stringsAsFactors = FALSE + ) + test_table_roundtrip(use_append = TRUE, con, tbl_in) +}) + +test_that("append_roundtrip_character_native", { + #' and native encodings), + tbl_in <- data.frame( + a = c(enc2native(get_texts())), + stringsAsFactors = FALSE + ) + test_table_roundtrip(use_append = TRUE, con, tbl_in) +}) + +test_that("append_roundtrip_character_empty", { + #' supporting empty strings + tbl_in <- data.frame( + a = c("", "a"), + stringsAsFactors = FALSE + ) + test_table_roundtrip(use_append = TRUE, con, tbl_in) +}) + +test_that("append_roundtrip_character_empty_after", { + #' (before and after non-empty strings) + tbl_in <- data.frame( + a = c("a", ""), + stringsAsFactors = FALSE + ) + test_table_roundtrip(use_append = TRUE, con, tbl_in) +}) + +test_that("append_roundtrip_factor", { + #' - factor (returned as character, + tbl_in <- data.frame( + a = factor(get_texts()) + ) + tbl_exp <- tbl_in + tbl_exp$a <- as.character(tbl_exp$a) + #' with a warning) + suppressWarnings( + expect_warning( + test_table_roundtrip(use_append = TRUE, con, tbl_in, tbl_exp) + ) + ) +}) + +test_that("append_roundtrip_raw", { + if (isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + skip("tweak: omit_blob_tests") + } + tbl_in <- data.frame(id = 1L, a = I(list(as.raw(0:10)))) + tbl_exp <- tbl_in + `$`(tbl_exp, a) <- `::`(blob, as_blob)(unclass(`$`(tbl_in, a))) + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + tbl_exp, + transform = function(tbl_out) { + `$`(tbl_out, a) <- `::`(blob, as_blob)(`$`(tbl_out, a)) + tbl_out + } + ) +}) + +test_that("append_roundtrip_blob", { + if (isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + skip("tweak: omit_blob_tests") + } + tbl_in <- data.frame(id = 1L, a = `::`(blob, blob)(as.raw(0:10))) + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + transform = function(tbl_out) { + `$`(tbl_out, a) <- `::`(blob, as_blob)(`$`(tbl_out, a)) + tbl_out + } + ) +}) + +test_that("append_roundtrip_date", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + tbl_in <- data.frame(a = as_numeric_date(c(Sys.Date() + 1:5))) + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + transform = function(tbl_out) { + expect_type(unclass(`$`(tbl_out, a)), "double") + tbl_out + } + ) +}) + +test_that("append_roundtrip_date_extended", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + tbl_in <- data.frame( + a = as_numeric_date( + c("1811-11-11", "1899-12-31", "1900-01-01", "1950-05-05", "1969-12-31", "1970-01-01", "2037-01-01", "2038-01-01", "2040-01-01", "2999-09-09") + ) + ) + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + transform = function(tbl_out) { + expect_type(unclass(`$`(tbl_out, a)), "double") + tbl_out + } + ) +}) + +test_that("append_roundtrip_time", { + if (!isTRUE(`$`(`$`(ctx, tweaks), time_typed))) { + skip("tweak: !time_typed") + } + tbl_in <- data.frame(a = `::`(hms, hms)(minutes = 1:5)) + `$`(tbl_in, b) <- .difftime(as.numeric(`$`(tbl_in, a)) / 60, "mins") + tbl_exp <- tbl_in + `$`(tbl_exp, a) <- `::`(hms, as_hms)(`$`(tbl_exp, a)) + `$`(tbl_exp, b) <- `::`(hms, as_hms)(`$`(tbl_exp, b)) + test_table_roundtrip( + con, + tbl_in, + tbl_exp, + transform = function(tbl_out) { + expect_s3_class(`$`(tbl_out, a), "difftime") + expect_s3_class(`$`(tbl_out, b), "difftime") + `$`(tbl_out, a) <- `::`(hms, as_hms)(`$`(tbl_out, a)) + `$`(tbl_out, b) <- `::`(hms, as_hms)(`$`(tbl_out, b)) + tbl_out + } + ) +}) + +test_that("append_roundtrip_timestamp", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + local <- round(Sys.time()) + c(1, 60, 3600, 86400, 86400 * 90, 86400 * 180, 86400 * 270, 1e+09, 5e+09) + attr(local, "tzone") <- "" + tbl_in <- data.frame(id = seq_along(local)) + `$`(tbl_in, local) <- local + `$`(tbl_in, gmt) <- `::`(lubridate, with_tz)(local, tzone = "GMT") + `$`(tbl_in, pst8pdt) <- `::`(lubridate, with_tz)(local, tzone = "PST8PDT") + `$`(tbl_in, utc) <- `::`(lubridate, with_tz)(local, tzone = "UTC") + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + transform = function(out) { + dates <- vapply(out, inherits, "POSIXt", FUN.VALUE = logical(1L)) + tz <- toupper(names(out)) + tz[tz == "LOCAL"] <- "" + out[dates] <- Map(`::`(lubridate, with_tz), out[dates], tz[dates]) + out + } + ) +}) + +test_that("append_roundtrip_timestamp_extended", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + local <- as.POSIXct( + c("1811-11-11", "1899-12-31", "1900-01-01", "1950-05-05", "1969-12-31", "1970-01-01", "2037-01-01", "2038-01-01", "2040-01-01", "2999-09-09") + ) + attr(local, "tzone") <- "" + tbl_in <- data.frame(id = seq_along(local)) + `$`(tbl_in, local) <- local + `$`(tbl_in, gmt) <- `::`(lubridate, with_tz)(local, tzone = "GMT") + `$`(tbl_in, pst8pdt) <- `::`(lubridate, with_tz)(local, tzone = "PST8PDT") + `$`(tbl_in, utc) <- `::`(lubridate, with_tz)(local, tzone = "UTC") + test_table_roundtrip( + use_append = TRUE, + con, + tbl_in, + transform = function(out) { + dates <- vapply(out, inherits, "POSIXt", FUN.VALUE = logical(1L)) + tz <- toupper(names(out)) + tz[tz == "LOCAL"] <- "" + out[dates] <- Map(`::`(lubridate, with_tz), out[dates], tz[dates]) + out + } + ) +}) + +test_that("append_roundtrip_mixed", { + data <- list("a", 1L, 1.5) + data <- lapply(data, c, NA) + expanded <- expand.grid(a = data, b = data, c = data) + tbl_in_list <- lapply( + seq_len(nrow(expanded)), + function(i) { + as.data.frame(lapply(expanded[i, ], unlist, recursive = FALSE)) + } + ) + lapply(tbl_in_list, test_table_roundtrip, con = con) +}) + +test_that("append_table_name", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + test_in <- trivial_df() + local_remove_test_table(con, table_name) + dbCreateTable(con, table_name, test_in) + dbAppendTable(con, table_name, test_in) + test_out <- check_df(dbReadTable(con, dbQuoteIdentifier(con, table_name))) + expect_equal_df(test_out, test_in) + } +}) + +test_that("append_table_name_quoted", { + if (as.package_version(`$`(`$`(ctx, tweaks), dbitest_version)) < "1.7.2") { + skip(paste0("tweak: dbitest_version: ", `$`(`$`(ctx, tweaks), dbitest_version))) + } + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + test_in <- trivial_df() + local_remove_test_table(con, table_name) + dbCreateTable(con, dbQuoteIdentifier(con, table_name), test_in) + dbAppendTable(con, dbQuoteIdentifier(con, table_name), test_in) + test_out <- check_df(dbReadTable(con, table_name)) + expect_equal_df(test_out, test_in) + } +}) + +test_that("write_table_formals", { + # + expect_equal(names(formals(dbWriteTable)), c("conn", "name", "value", "...")) +}) + +test_that("write_table_name", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + test_in <- data.frame(a = 1) + local_remove_test_table(con, table_name) + dbWriteTable(con, table_name, test_in) + test_out <- check_df(dbReadTable(con, dbQuoteIdentifier(con, table_name))) + expect_equal_df(test_out, test_in) + } +}) + +test_that("write_table_name_quoted", { + if (as.package_version(`$`(`$`(ctx, tweaks), dbitest_version)) < "1.7.2") { + skip(paste0("tweak: dbitest_version: ", `$`(`$`(ctx, tweaks), dbitest_version))) + } + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + test_in <- data.frame(a = 1) + local_remove_test_table(con, table_name) + dbWriteTable(con, dbQuoteIdentifier(con, table_name), test_in) + test_out <- check_df(dbReadTable(con, table_name)) + expect_equal_df(test_out, test_in) + } +}) + +test_that("temporary_table", { + if (!isTRUE(`$`(`$`(ctx, tweaks), temporary_tables))) { + skip("tweak: temporary_tables") + } + table_name <- "dbit08" + expect_error(dbReadTable(con, table_name)) +}) + +test_that("table_visible_in_other_connection", { + #' in a pre-existing connection, + penguins30 <- get_penguins(ctx) + + table_name <- "dbit09" + + expect_equal_df(check_df(dbReadTable(con, table_name)), penguins30) +}) + +test_that("roundtrip_keywords", { + #' SQL keywords can be used freely in table names, column names, and data. + tbl_in <- data.frame( + select = "unique", from = "join", where = "order", + stringsAsFactors = FALSE + ) + test_table_roundtrip(con, tbl_in, name = "exists") +}) + +test_that("roundtrip_quotes_table_names", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + skip("tweak: strict_identifier") + } + table_names <- c(as.character(dbQuoteIdentifier(con, "")), as.character(dbQuoteString(con, "")), "with space", "a,b", "a\nb", "a\tb", "a\rb", "a\bb", "a\\Nb", "a\\tb", "a\\rb", "a\\bb", "a\\Zb") + tbl_in <- trivial_df() + for (table_name in table_names) { + test_table_roundtrip_one(con, tbl_in, .add_na = "none") + } +}) + +test_that("roundtrip_quotes_column_names", { + if (as.package_version(`$`(`$`(ctx, tweaks), dbitest_version)) < "1.7.2") { + skip(paste0("tweak: dbitest_version: ", `$`(`$`(ctx, tweaks), dbitest_version))) + } + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + skip("tweak: strict_identifier") + } + column_names <- c(as.character(dbQuoteIdentifier(con, "")), as.character(dbQuoteString(con, "")), "with space", "a,b", "a\nb", "a\tb", "a\rb", "a\bb", "a\\nb", "a\\tb", "a\\rb", "a\\bb", "a\\zb") + tbl_in <- trivial_df(length(column_names), column_names) + test_table_roundtrip_one(con, tbl_in, .add_na = "none") +}) + +test_that("roundtrip_integer", { + #' The following data types must be supported at least, + #' and be read identically with [dbReadTable()]: + #' - integer + tbl_in <- data.frame(a = c(1:5)) + test_table_roundtrip(con, tbl_in) +}) + +test_that("roundtrip_numeric", { + #' - numeric + tbl_in <- data.frame(a = c(seq(1, 3, by = 0.5))) + test_table_roundtrip(con, tbl_in) + #' (the behavior for `Inf` and `NaN` is not specified) +}) + +test_that("roundtrip_logical", { + #' - logical + tbl_in <- data.frame(a = c(TRUE, FALSE, NA)) + tbl_exp <- tbl_in + tbl_exp$a <- ctx$tweaks$logical_return(tbl_exp$a) + test_table_roundtrip(con, tbl_in, tbl_exp) +}) + +test_that("roundtrip_null", { + tbl_in <- data.frame(a = NA) + test_table_roundtrip( + con, + tbl_in, + transform = function(tbl_out) { + `$`(tbl_out, a) <- as.logical(`$`(tbl_out, a)) + tbl_out + } + ) +}) + +test_that("roundtrip_64_bit_numeric", { + tbl_in <- data.frame(a = c(-1e+14, 1e+15)) + test_table_roundtrip( + con, + tbl_in, + transform = function(tbl_out) { + `$`(tbl_out, a) <- as.numeric(`$`(tbl_out, a)) + tbl_out + }, + field.types = c(a = "BIGINT") + ) +}) + +test_that("roundtrip_64_bit_character", { + tbl_in <- data.frame(a = c(-1e+14, 1e+15)) + tbl_exp <- tbl_in + `$`(tbl_exp, a) <- format(`$`(tbl_exp, a), scientific = FALSE) + test_table_roundtrip( + con, + tbl_in, + tbl_exp, + transform = function(tbl_out) { + `$`(tbl_out, a) <- as.character(`$`(tbl_out, a)) + tbl_out + }, + field.types = c(a = "BIGINT") + ) +}) + +test_that("roundtrip_character", { + #' - character (in both UTF-8 + tbl_in <- data.frame( + id = seq_along(get_texts()), + a = get_texts(), + stringsAsFactors = FALSE + ) + test_table_roundtrip(con, tbl_in) +}) + +test_that("roundtrip_character_native", { + #' and native encodings), + tbl_in <- data.frame( + a = c(enc2native(get_texts())), + stringsAsFactors = FALSE + ) + test_table_roundtrip(con, tbl_in) +}) + +test_that("roundtrip_character_empty", { + #' supporting empty strings + tbl_in <- data.frame( + a = c("", "a"), + stringsAsFactors = FALSE + ) + test_table_roundtrip(con, tbl_in) +}) + +test_that("roundtrip_character_empty_after", { + #' before and after a non-empty string + tbl_in <- data.frame( + a = c("a", ""), + stringsAsFactors = FALSE + ) + test_table_roundtrip(con, tbl_in) +}) + +test_that("roundtrip_factor", { + #' - factor (returned as character) + tbl_in <- data.frame( + a = factor(get_texts()) + ) + tbl_exp <- tbl_in + tbl_exp$a <- as.character(tbl_exp$a) + test_table_roundtrip(con, tbl_in, tbl_exp) +}) + +test_that("roundtrip_raw", { + if (isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + skip("tweak: omit_blob_tests") + } + tbl_in <- data.frame(id = 1L, a = I(list(as.raw(0:10)))) + tbl_exp <- tbl_in + `$`(tbl_exp, a) <- `::`(blob, as_blob)(unclass(`$`(tbl_in, a))) + test_table_roundtrip( + con, + tbl_in, + tbl_exp, + transform = function(tbl_out) { + `$`(tbl_out, a) <- `::`(blob, as_blob)(`$`(tbl_out, a)) + tbl_out + } + ) +}) + +test_that("roundtrip_blob", { + if (isTRUE(`$`(`$`(ctx, tweaks), omit_blob_tests))) { + skip("tweak: omit_blob_tests") + } + tbl_in <- data.frame(id = 1L, a = `::`(blob, blob)(as.raw(0:10))) + test_table_roundtrip( + con, + tbl_in, + transform = function(tbl_out) { + `$`(tbl_out, a) <- `::`(blob, as_blob)(`$`(tbl_out, a)) + tbl_out + } + ) +}) + +test_that("roundtrip_date", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + tbl_in <- data.frame(a = as_numeric_date(c(Sys.Date() + 1:5))) + test_table_roundtrip( + con, + tbl_in, + transform = function(tbl_out) { + expect_type(unclass(`$`(tbl_out, a)), "double") + tbl_out + } + ) +}) + +test_that("roundtrip_date_extended", { + if (!isTRUE(`$`(`$`(ctx, tweaks), date_typed))) { + skip("tweak: !date_typed") + } + tbl_in <- data.frame( + a = as_numeric_date( + c("1811-11-11", "1899-12-31", "1900-01-01", "1950-05-05", "1969-12-31", "1970-01-01", "2037-01-01", "2038-01-01", "2040-01-01", "2999-09-09") + ) + ) + test_table_roundtrip( + con, + tbl_in, + transform = function(tbl_out) { + expect_type(unclass(`$`(tbl_out, a)), "double") + tbl_out + } + ) +}) + +test_that("roundtrip_time", { + if (!isTRUE(`$`(`$`(ctx, tweaks), time_typed))) { + skip("tweak: !time_typed") + } + tbl_in <- data.frame(a = `::`(hms, hms)(minutes = 1:5)) + `$`(tbl_in, b) <- .difftime(as.numeric(`$`(tbl_in, a)) / 60, "mins") + tbl_exp <- tbl_in + `$`(tbl_exp, a) <- `::`(hms, as_hms)(`$`(tbl_exp, a)) + `$`(tbl_exp, b) <- `::`(hms, as_hms)(`$`(tbl_exp, b)) + test_table_roundtrip( + con, + tbl_in, + tbl_exp, + transform = function(tbl_out) { + expect_s3_class(`$`(tbl_out, a), "difftime") + expect_s3_class(`$`(tbl_out, b), "difftime") + `$`(tbl_out, a) <- `::`(hms, as_hms)(`$`(tbl_out, a)) + `$`(tbl_out, b) <- `::`(hms, as_hms)(`$`(tbl_out, b)) + tbl_out + } + ) +}) + +test_that("roundtrip_timestamp", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + local <- round(Sys.time()) + c(1, 60, 3600, 86400, 86400 * 90, 86400 * 180, 86400 * 270, 1e+09, 5e+09) + attr(local, "tzone") <- "" + tbl_in <- data.frame(id = seq_along(local)) + `$`(tbl_in, local) <- local + `$`(tbl_in, gmt) <- `::`(lubridate, with_tz)(local, tzone = "GMT") + `$`(tbl_in, pst8pdt) <- `::`(lubridate, with_tz)(local, tzone = "PST8PDT") + `$`(tbl_in, utc) <- `::`(lubridate, with_tz)(local, tzone = "UTC") + test_table_roundtrip( + con, + tbl_in, + transform = function(out) { + dates <- vapply(out, inherits, "POSIXt", FUN.VALUE = logical(1L)) + tz <- toupper(names(out)) + tz[tz == "LOCAL"] <- "" + out[dates] <- Map(`::`(lubridate, with_tz), out[dates], tz[dates]) + out + } + ) +}) + +test_that("roundtrip_timestamp_extended", { + if (!isTRUE(`$`(`$`(ctx, tweaks), timestamp_typed))) { + skip("tweak: !timestamp_typed") + } + local <- as.POSIXct( + c("1811-11-11", "1899-12-31", "1900-01-01", "1950-05-05", "1969-12-31", "1970-01-01", "2037-01-01", "2038-01-01", "2040-01-01", "2999-09-09") + ) + attr(local, "tzone") <- "" + tbl_in <- data.frame(id = seq_along(local)) + `$`(tbl_in, local) <- local + `$`(tbl_in, gmt) <- `::`(lubridate, with_tz)(local, tzone = "GMT") + `$`(tbl_in, pst8pdt) <- `::`(lubridate, with_tz)(local, tzone = "PST8PDT") + `$`(tbl_in, utc) <- `::`(lubridate, with_tz)(local, tzone = "UTC") + test_table_roundtrip( + con, + tbl_in, + transform = function(out) { + dates <- vapply(out, inherits, "POSIXt", FUN.VALUE = logical(1L)) + tz <- toupper(names(out)) + tz[tz == "LOCAL"] <- "" + out[dates] <- Map(`::`(lubridate, with_tz), out[dates], tz[dates]) + out + } + ) +}) + +test_that("roundtrip_mixed", { + data <- list("a", 1L, 1.5) + data <- lapply(data, c, NA) + expanded <- expand.grid(a = data, b = data, c = data) + tbl_in_list <- lapply( + seq_len(nrow(expanded)), + function(i) { + as.data.frame(lapply(expanded[i, ], unlist, recursive = FALSE)) + } + ) + lapply(tbl_in_list, test_table_roundtrip, con = con) +}) + +test_that("roundtrip_field_types", { + #' The `field.types` argument must be a named character vector with at most + #' one entry for each column. + #' It indicates the SQL data type to be used for a new column. + tbl_in <- data.frame(a = numeric(), b = character()) + #' If a column is missed from `field.types`, the type is inferred + #' from the input data with [dbDataType()]. + tbl_exp <- data.frame(a = integer(), b = character()) + test_table_roundtrip( + con, tbl_in, tbl_exp, + field.types = c(a = "INTEGER") + ) + + tbl_in <- data.frame(a = numeric(), b = integer()) + tbl_exp <- data.frame(a = integer(), b = numeric()) + test_table_roundtrip( + con, tbl_in, tbl_exp, + field.types = c(b = "REAL", a = "INTEGER") + ) +}) + +test_that("write_table_row_names_false", { + for (row.names in list(FALSE, NULL)) { + table_name <- random_table_name() + local_remove_test_table(con, table_name) + mtcars_in <- `::`(datasets, mtcars) + dbWriteTable(con, table_name, mtcars_in, row.names = row.names) + mtcars_out <- check_df(dbReadTable(con, table_name, row.names = FALSE)) + expect_false("row_names" %in% names(mtcars_out)) + expect_equal_df(mtcars_out, unrowname(mtcars_in)) + } +}) + +test_that("list_tables_formals", { + # + expect_equal(names(formals(dbListTables)), c("conn", "...")) +}) + +test_that("list_tables", { + #' As soon a table is removed from the database, + #' it is also removed from the list of database tables. + table_name <- "dbit07" + tables <- dbListTables(con) + expect_false(table_name %in% tables) +}) + +test_that("list_tables_quote", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + local_remove_test_table(con, table_name) + dbWriteTable(con, dbQuoteIdentifier(con, table_name), data.frame(a = 2L)) + tables <- dbListTables(con) + expect_true(table_name %in% tables) + expect_true(dbQuoteIdentifier(con, table_name) %in% dbQuoteIdentifier(con, tables)) + } +}) + +test_that("exists_table_formals", { + # + expect_equal(names(formals(dbExistsTable)), c("conn", "name", "...")) +}) + +test_that("exists_table", { + table_name <- "dbit05" + expect_false(expect_visible(dbExistsTable(con, table_name))) +}) + +test_that("exists_table_name", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + local_remove_test_table(con, table_name) + expect_false(dbExistsTable(con, table_name)) + test_in <- data.frame(a = 1L) + dbWriteTable(con, table_name, test_in) + expect_true(dbExistsTable(con, table_name)) + expect_true(dbExistsTable(con, dbQuoteIdentifier(con, table_name))) + } +}) + +test_that("remove_table_formals", { + # + expect_equal(names(formals(dbRemoveTable)), c("conn", "name", "...")) +}) + +test_that("remove_table_name", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + test_in <- data.frame(a = 1L) + for (table_name in table_names) { + local_remove_test_table(con, table_name) + dbWriteTable(con, table_name, test_in) + expect_true(dbRemoveTable(con, table_name)) + } +}) + +test_that("remove_table_name_quoted", { + if (as.package_version(`$`(`$`(ctx, tweaks), dbitest_version)) < "1.7.2") { + skip(paste0("tweak: dbitest_version: ", `$`(`$`(ctx, tweaks), dbitest_version))) + } + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + test_in <- data.frame(a = 1L) + for (table_name in table_names) { + local_remove_test_table(con, table_name) + dbWriteTable(con, table_name, test_in) + expect_true(dbRemoveTable(con, dbQuoteIdentifier(con, table_name))) + } +}) + +test_that("list_objects_formals", { + # + expect_equal(names(formals(dbListObjects)), c("conn", "prefix", "...")) +}) + +test_that("list_objects", { + #' As soon a table is removed from the database, + #' it is also removed from the data frame of database objects. + table_name <- "dbit06" + + objects <- dbListObjects(con) + quoted_tables <- vapply(objects$table, dbQuoteIdentifier, conn = con, character(1)) + expect_false(dbQuoteIdentifier(con, table_name) %in% quoted_tables) +}) + +test_that("list_objects_quote", { + if (isTRUE(`$`(`$`(ctx, tweaks), strict_identifier))) { + table_names <- "a" + } else { + table_names <- c("a", "with spaces", "with,comma") + } + for (table_name in table_names) { + local_remove_test_table(con, table_name) + dbWriteTable(con, dbQuoteIdentifier(con, table_name), data.frame(a = 2L)) + objects <- dbListObjects(con) + quoted_tables <- vapply(`$`(objects, table), dbQuoteIdentifier, conn = con, character(1)) + expect_true(dbQuoteIdentifier(con, table_name) %in% quoted_tables) + } +}) + +test_that("list_objects_features", { + objects <- dbListObjects(con) + non_prefix_objects <- vapply(`$`(objects, table)[!`$`(objects, is_prefix)], dbQuoteIdentifier, conn = con, character(1)) + all_tables <- dbQuoteIdentifier(con, dbListTables(con)) + expect_equal(sort(non_prefix_objects), sort(as.character(all_tables))) + sql <- lapply(`$`(objects, table)[!`$`(objects, is_prefix)], dbQuoteIdentifier, conn = con) + unquoted <- vapply(sql, dbUnquoteIdentifier, conn = con, list(1)) + expect_equal(unquoted, unclass(`$`(objects, table)[!`$`(objects, is_prefix)])) + if (!any(`$`(objects, is_prefix))) { + skip("No schemas available") + } + for (schema in `::`(utils, head)(`$`(objects, table)[`$`(objects, is_prefix)])) { + sub_objects <- dbListObjects(con, prefix = schema) + for (sub_table in `::`(utils, head)(`$`(sub_objects, table)[!`$`(sub_objects, is_prefix)])) { + if (!identical(sub_table, Id(schema = "information_schema", table = "FILES"))) { + eval( + bquote( + expect_true(dbExistsTable(con, .(sub_table)), label = paste0("dbExistsTable(", dbQuoteIdentifier(con, sub_table), ")")) + ) + ) + } + } + } +}) + +test_that("list_fields_formals", { + # + expect_equal(names(formals(dbListFields)), c("conn", "name", "...")) +}) + +test_that("list_fields_wrong_table", { + #' @section Failure modes: + #' If the table does not exist, an error is raised. + name <- "missing" + + expect_false(dbExistsTable(con, name)) + expect_error(dbListFields(con, name)) +}) + +test_that("list_fields_invalid_type", { + #' Invalid types for the `name` argument + #' (e.g., `character` of length not equal to one, + expect_error(dbListFields(con, character())) + expect_error(dbListFields(con, letters)) + #' or numeric) + expect_error(dbListFields(con, 1)) + #' lead to an error. +}) diff --git a/tests/testthat/test-dbitest-stress.R b/tests/testthat/test-dbitest-stress.R new file mode 100644 index 000000000..228f9023f --- /dev/null +++ b/tests/testthat/test-dbitest-stress.R @@ -0,0 +1,23 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("simultaneous_connections", { + cons <- list() + on.exit(try_silent(lapply(cons, dbDisconnect)), add = TRUE) + for (i in seq_len(50L)) { + cons <- c(cons, connect(ctx)) + } + inherit_from_connection <- vapply(cons, is, class2 = "DBIConnection", logical(1)) + expect_true(all(inherit_from_connection)) +}) + +test_that("stress_connections", { + for (i in seq_len(50L)) { + con <- connect(ctx) + expect_s4_class(con, "DBIConnection") + expect_error(dbDisconnect(con), NA) + } +}) diff --git a/tests/testthat/test-dbitest-transaction.R b/tests/testthat/test-dbitest-transaction.R new file mode 100644 index 000000000..1fa147efb --- /dev/null +++ b/tests/testthat/test-dbitest-transaction.R @@ -0,0 +1,119 @@ +# Created by DBItest::use_dbitest(), do not edit by hand + +ctx <- get_default_context() + +con <- local_connection(ctx) + +test_that("begin_formals", { + # + expect_equal(names(formals(dbBegin)), c("conn", "...")) +}) + +test_that("commit_formals", { + # + expect_equal(names(formals(dbCommit)), c("conn", "...")) +}) + +test_that("rollback_formals", { + # + expect_equal(names(formals(dbRollback)), c("conn", "...")) +}) + +test_that("begin_commit_return_value", { + expect_invisible_true(dbBegin(con)) + on.exit({ + dbRollback(con) + }) + expect_invisible_true(dbCommit(con)) + on.exit(NULL) +}) + +test_that("begin_rollback_return_value", { + expect_invisible_true(dbBegin(con)) + expect_invisible_true(dbRollback(con)) +}) + +test_that("commit_without_begin", { + #' In addition, a call to `dbCommit()` + expect_error(dbCommit(con)) +}) + +test_that("rollback_without_begin", { + #' or `dbRollback()` + #' without a prior call to `dbBegin()` raises an error. + expect_error(dbRollback(con)) +}) + +test_that("begin_begin", { + dbBegin(con) + on.exit({ + dbRollback(con) + }) + expect_error(dbBegin(con)) + dbCommit(con) + on.exit(NULL) +}) + +test_that("begin_commit", { + dbBegin(con) + success <- FALSE + expect_error( + { + dbCommit(con) + success <- TRUE + }, + NA + ) + if (!success) dbRollback(con) +}) + +test_that("begin_write_commit", { + table_name <- "dbit00" + dbWriteTable(con, table_name, data.frame(a = 0L), overwrite = TRUE) + dbBegin(con) + on.exit({ + dbRollback(con) + }) + dbExecute(con, paste0("INSERT INTO ", table_name, " (a) VALUES (1)")) + expect_equal(check_df(dbReadTable(con, table_name)), data.frame(a = 0:1)) + dbCommit(con) + on.exit(NULL) + expect_equal(check_df(dbReadTable(con, table_name)), data.frame(a = 0:1)) +}) + +test_that("begin_rollback", { + #' + #' A transaction + dbBegin(con) + #' can also be aborted with `dbRollback()`. + expect_error(dbRollback(con), NA) +}) + +test_that("with_transaction_formals", { + # + expect_equal(names(formals(dbWithTransaction)), c("conn", "code", "...")) +}) + +test_that("with_transaction_return_value", { + #' @return + #' `dbWithTransaction()` returns the value of the executed code. + name <- random_table_name() + expect_identical(dbWithTransaction(con, name), name) +}) + +test_that("with_transaction_error_nested", { + #' of if [dbBegin()] has been called already) + dbBegin(con) + #' gives an error. + expect_error(dbWithTransaction(con, NULL)) + dbRollback(con) +}) + +test_that("with_transaction_side_effects", { + #' All side effects caused by the code + expect_false(exists("a", inherits = FALSE)) + #' (such as the creation of new variables) + dbWithTransaction(con, a <- 42) + #' propagate to the calling environment. + expect_identical(get0("a", inherits = FALSE), 42) +})