diff --git a/R/spec-meta-bind-.R b/R/spec-meta-bind-.R index 16b9dd14a..1d5dfede7 100644 --- a/R/spec-meta-bind-.R +++ b/R/spec-meta-bind-.R @@ -1,6 +1,12 @@ # Helpers ----------------------------------------------------------------- -test_select_bind <- function(con, ctx, bind_values, ..., requires_names = NULL) { +test_select_bind <- function( + con, + ctx, + bind_values, + ..., + cast_fun = identity, + requires_names = NULL) { placeholder_funs <- get_placeholder_funs(ctx, requires_names) lapply( @@ -9,6 +15,7 @@ test_select_bind <- function(con, ctx, bind_values, ..., requires_names = NULL) con = con, bind_values = bind_values, is_null_check = ctx$tweaks$is_null_check, + cast_fun = cast_fun, allow_na_rows_affected = ctx$tweaks$allow_na_rows_affected, ... ) @@ -66,12 +73,7 @@ test_select_bind_one <- function( rlang::check_dots_empty() - run_bind_tester$fun( - con, - placeholder_fun = placeholder_fun, - is_null_check = is_null_check, - cast_fun = cast_fun, - allow_na_rows_affected = allow_na_rows_affected, + test_expr <- run_bind_tester$fun( bind_values = bind_values, query = query, skip_fun = skip_fun, @@ -82,6 +84,23 @@ test_select_bind_one <- function( is_premature_clear = is_premature_clear, is_untouched = is_untouched ) + + rm(bind_values) + rm(query) + rm(skip_fun) + rm(check_return_value) + rm(patch_bind_values) + rm(bind_error) + rm(is_repeated) + rm(is_premature_clear) + rm(is_untouched) + + force(placeholder_fun) + force(is_null_check) + force(cast_fun) + force(allow_na_rows_affected) + + rlang::eval_bare(test_expr) } diff --git a/R/spec-meta-bind-runner.R b/R/spec-meta-bind-runner.R index 85a3d9d40..cff7929f2 100644 --- a/R/spec-meta-bind-runner.R +++ b/R/spec-meta-bind-runner.R @@ -10,13 +10,7 @@ run_bind_tester <- list() #' \pkg{DBI} clients execute parametrized statements as follows: #' run_bind_tester$fun <- function( - con, ..., - # Run time - placeholder_fun, - is_null_check, - cast_fun, - allow_na_rows_affected, # Spec time bind_values, query, @@ -28,10 +22,6 @@ run_bind_tester$fun <- function( is_premature_clear, is_untouched) { rlang::check_dots_empty() - force(placeholder_fun) - force(is_null_check) - force(cast_fun) - force(allow_na_rows_affected) force(bind_values) force(query) force(skip) @@ -42,16 +32,18 @@ run_bind_tester$fun <- function( force(is_premature_clear) force(is_untouched) - if (is.null(patch_bind_values)) { - patch_bind_values <- identity - } - bind_values_expr <- rlang::expr({ bind_values <- !!construct_expr(bind_values) }) + bind_values_patched_expr <- if (is.null(patch_bind_values)) rlang::expr({ + bind_values_patched <- bind_values + }) else rlang::expr({ + bind_values_patched <- !!body(patch_bind_values) + }) + skip_expr <- if (!is.null(skip_fun) && skip_fun()) rlang::expr({ - skip(rlang::expr_deparse(body(skip_fun))) + skip(!!rlang::expr_deparse(body(skip_fun))) }) #' 1. Call [dbSendQuery()] or [dbSendStatement()] with a query or statement @@ -145,20 +137,22 @@ run_bind_tester$fun <- function( names(bind_values) <- names(placeholder_fun(length(bind_values))) }) + check_return_value_expr <- if (!is.null(check_return_value)) rlang::expr({ + !!body(check_return_value) + }) + #' All elements in this list must have the same lengths and contain values #' supported by the backend; a [data.frame] is internally stored as such #' a list. #' The parameter list is passed to a call to `dbBind()` on the `DBIResult` #' object. bind_expr <- if (is.na(bind_error)) rlang::expr({ - bind_res <- withVisible(dbBind(res, patch_bind_values(bind_values))) - if (!is.null(check_return_value)) { - check_return_value(bind_res, res) - } + bind_res <- withVisible(dbBind(res, bind_values_patched)) + !!check_return_value_expr }) else rlang::expr({ expect_error( - withVisible(dbBind(res, patch_bind_values(bind_values))), - bind_error + withVisible(dbBind(res, bind_values_patched)), + !!bind_error ) }) @@ -194,10 +188,8 @@ run_bind_tester$fun <- function( #' 1. Repeat 2. and 3. as necessary. repeated_expr <- if (is_repeated) rlang::expr({ - bind_res <- withVisible(dbBind(res, patch_bind_values(bind_values))) - if (!is.null(check_return_value)) { - check_return_value(bind_res, res) - } + bind_res <- withVisible(dbBind(res, bind_values_patched)) + !!check_return_value_expr !!retrieve_expr }) @@ -206,7 +198,7 @@ run_bind_tester$fun <- function( early_exit <- is_premature_clear || !is.na(bind_error) || - !identical(bind_values, patch_bind_values(bind_values)) + (!is.null(patch_bind_values) && !identical(bind_values, patch_bind_values(bind_values))) post_bind_expr <- if (!early_exit) rlang::expr({ !!not_untouched_expr @@ -214,17 +206,17 @@ run_bind_tester$fun <- function( }) test_expr <- rlang::expr({ - !!bind_values_expr !!skip_expr + !!bind_values_expr + !!name_values_expr + !!bind_values_patched_expr !!send_expr !!clear_expr - !!name_values_expr !!bind_expr !!post_bind_expr }) - rm(bind_values) - rlang::eval_bare(test_expr) + test_expr } construct_expr <- function(x) {