diff --git a/R/firmly.R b/R/firmly.R index c904afb..0df3208 100644 --- a/R/firmly.R +++ b/R/firmly.R @@ -70,12 +70,11 @@ warning_closure <- function(.fn, .warn) { force(.warn) function() { - call <- match.call() - .warn(call) + call <- base::match.call() + encl <- base::parent.env(base::environment()) + encl$.warn(call) - parent <- parent.frame() - encl <- parent.env(environment()) - eval(encl$.fn(call), parent) + base::eval.parent(encl$.fn(call)) } } @@ -108,33 +107,42 @@ validating_closure <- function(.chks, .sig, .fn, .warn, .error_class) { force(.warn) force(.error_class) + exprs <- purrr::transpose(.chks[c("expr", "env")]) error <- function(message) { structure( list(message = message, call = NULL), class = c(.error_class, "error", "condition") ) } - exprs <- purrr::transpose(.chks[c("expr", "env")]) + + # Local bindings to avoid (unlikely) clashes with formal arguments + deparse_collapse <- match.fun("deparse_collapse") + enumerate_many <- match.fun("enumerate_many") + problems <- match.fun("problems") + promises <- match.fun("promises") function() { - call <- match.call() - .warn(call) - - parent <- parent.frame() - encl <- parent.env(environment()) - env <- promises(call, encl$.sig, parent) - verdict <- suppressWarnings(lapply(encl$exprs, function(.) - tryCatch(eval(.$expr, `parent.env<-`(env, .$env)), error = identity) + call <- base::match.call() + encl <- base::parent.env(base::environment()) + encl$.warn(call) + + parent <- base::parent.frame() + env <- encl$promises(call, encl$.sig, parent) + verdict <- base::suppressWarnings(base::lapply(encl$exprs, function(.) + base::tryCatch(base::eval(.$expr, base::`parent.env<-`(env, .$env)), + error = base::identity) )) - pass <- vapply(verdict, is_true, logical(1)) + pass <- base::vapply(verdict, base::isTRUE, base::logical(1)) - if (all(pass)) { - eval(encl$.fn(call), parent) + if (base::all(pass)) { + base::eval(encl$.fn(call), parent) } else { fail <- !pass - msg_call <- sprintf("%s\n", deparse_collapse(call)) - msg_error <- enumerate_many(problems(encl$.chks[fail, ], verdict[fail])) - stop(encl$error(paste0(msg_call, msg_error))) + msg_call <- base::sprintf("%s\n", encl$deparse_collapse(call)) + msg_error <- encl$enumerate_many( + encl$problems(encl$.chks[fail, ], verdict[fail]) + ) + base::stop(encl$error(base::paste0(msg_call, msg_error))) } } } diff --git a/tests/testthat/test-validation.R b/tests/testthat/test-validation.R index a78b491..14bc43e 100644 --- a/tests/testthat/test-validation.R +++ b/tests/testthat/test-validation.R @@ -391,41 +391,51 @@ test_that("predicate is evaluated in its ambient formula environment", { } }) -test_that("names in checking procedure don't override function arguments", { +test_that("formal arguments don't override names in validation procedure", { # Bindings in execution/enclosing environment of validating_closure() - nms <- c("call", "parent", "encl", "env", "verdict", "pass", "fail", - "msg_call", "msg_error", ".chks", ".sig", ".warn", "exprs") + nms <- c("call", "parent", "encl", "env", "verdict", "pass", "fail", + "msg_call", "msg_error", ".chks", ".sig", "exprs") + nms_fn <- c(".fn", ".warn", "deparse_collapse", "enumerate_many", "error", + "problems", "promises") sum_args <- parse(text = paste(nms, collapse = "+")) f <- function() { - # Ensure that no arguments have type "logical" + # Ensure that no arguments have are logical (thus are coercible to numeric) args <- as.list(match.call()[-1]) stopifnot(vapply(args, Negate(is.logical), logical(1))) - eval(sum_args) } - # All arguments get an positive integer default value, except .fn - wrong_fn <- function(x) "Wrong function called" - def_args_nonfn <- seq_along(nms) - def_args <- c(alist(.fn = wrong_fn), stats::setNames(def_args_nonfn, nms)) + # All function arguments get the function wrong_fn as default value + wrong_fn <- function(...) { + message("This function shouldn't have been called!") + } + def_args_fn <- stats::setNames(vector("list", length(nms_fn)), nms_fn) + def_args_fn[] <- list(quote(wrong_fn)) + + # All non-function arguments get an positive integer default value + def_args_nonfn <- stats::setNames(seq_along(nms), nms) + def_args <- c(def_args_fn, def_args_nonfn) formals(f) <- as.pairlist(def_args) - f_firm <- firmly( - f, - list(~.fn) ~ is.function, - lapply(nms, function(.) eval(parse(text = paste0("~", .)))) ~ is.numeric - ) + make_checkfml <- function(.) eval(parse(text = paste0("~", .))) + f_firm <- firmly(f, + lapply(nms_fn, make_checkfml) ~ is.function, + lapply(nms, make_checkfml) ~ is.numeric) f_warn <- firmly(f, .warn_missing = names(def_args)) - # Verify that f_firm(), f_warn() generate no errors and has correct value + # Verify that f_firm(), f_warn() generate no errors and return correct value expect_error(f_firm(), NA) expect_error(do.call("f_warn", def_args), NA) sum(def_args_nonfn) %>% expect_identical(f_firm()) %>% expect_identical(do.call("f_warn", def_args)) - # Verify that f_firm(), f_warn() do not (accidentally) call .fn - expect_false(isTRUE(all.equal(f_firm(), wrong_fn()))) - expect_false(isTRUE(all.equal(do.call("f_warn", def_args), wrong_fn()))) + # Verify that f_firm(), f_warn() do not call its function arguments + msg <- capture_messages(wrong_fn()) + expect_gt(length(msg), 0) # msg is non-empty string + expect_message(wrong_fn(), msg) # wrong_fn() produces msg when called + # f_firm(), f_warn() produce no message, so wrong_fn() wasn't called + expect_message(f_firm(), NA) + expect_message(do.call("f_warn", def_args), NA) })