diff --git a/R/aaa.R b/R/aaa.R index f299df89..2d872fa5 100644 --- a/R/aaa.R +++ b/R/aaa.R @@ -25,8 +25,11 @@ new_function <- function(args = NULL, topNamespaceName <- function(env = parent.frame()) { env <- topenv(env) - if (isNamespace(env)) - getNamespaceName(env) + if (!isNamespace(env)) { + return() + } + + getNamespaceName(env) } is_string <- function(x) { diff --git a/R/zzz.R b/R/zzz.R index f4d9cfc2..05d03716 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -82,9 +82,9 @@ is_S7_type <- function(x) { } check_subsettable <- function(x, allow_env = FALSE) { - allowed_types <- c("list", if (allow_env) "environment") + allowed_types <- c("list", "language", "pairlist", if (allow_env) "environment") if (!typeof(x) %in% allowed_types) { - stop("S7 objects are not subsettable.", call. = FALSE) + stop("S7 objects are not subsettable.") } invisible(TRUE) } diff --git a/src/init.c b/src/init.c index 11568282..63943bbc 100644 --- a/src/init.c +++ b/src/init.c @@ -36,6 +36,8 @@ SEXP sym_dot_should_validate; SEXP sym_dot_getting_prop; SEXP sym_dot_setting_prop; +SEXP fn_base_quote; + SEXP ns_S7; @@ -58,5 +60,7 @@ void R_init_S7(DllInfo *dll) sym_dot_getting_prop = Rf_install(".getting_prop"); sym_dot_setting_prop = Rf_install(".setting_prop"); + fn_base_quote = Rf_eval(Rf_install("quote"), R_BaseEnv); + ns_S7 = Rf_findVarInFrame(R_NamespaceRegistry, Rf_install("S7")); } diff --git a/src/prop.c b/src/prop.c index 7f5ec376..1086fa0d 100644 --- a/src/prop.c +++ b/src/prop.c @@ -18,6 +18,8 @@ extern SEXP sym_dot_should_validate; extern SEXP sym_dot_getting_prop; extern SEXP sym_dot_setting_prop; +extern SEXP fn_base_quote; + static inline SEXP eval_here(SEXP lang) { PROTECT(lang); @@ -26,6 +28,51 @@ SEXP eval_here(SEXP lang) { return ans; } +static inline +SEXP do_call1(SEXP fn, SEXP arg) { + SEXP call, answer; + switch (TYPEOF(arg)) { + case LANGSXP: + case SYMSXP: + arg = PROTECT(Rf_lang2(fn_base_quote, arg)); + call = PROTECT(Rf_lang2(fn, arg)); + answer = Rf_eval(call, ns_S7); + UNPROTECT(2); + return answer; + default: + call = PROTECT(Rf_lang2(fn, arg)); + answer = Rf_eval(call, ns_S7); + UNPROTECT(1); + return answer; + } +} + +static inline SEXP do_call2(SEXP fn, SEXP arg1, SEXP arg2) { + int n_protected = 0; + // Protect the arguments from evaluation if they are SYMSXP or LANGSXP + switch (TYPEOF(arg1)) { + case LANGSXP: + case SYMSXP: + arg1 = PROTECT(Rf_lang2(fn_base_quote, arg1)); + ++n_protected; + } + + switch (TYPEOF(arg2)) { + case LANGSXP: + case SYMSXP: + arg2 = PROTECT(Rf_lang2(fn_base_quote, arg2)); + ++n_protected; + } + + SEXP call = PROTECT(Rf_lang3(fn, arg1, arg2)); + ++n_protected; + + SEXP result = Rf_eval(call, ns_S7); + + UNPROTECT(n_protected); + return result; +} + static __attribute__((noreturn)) void signal_is_not_S7(SEXP object) { static SEXP check_is_S7 = NULL; @@ -207,13 +254,25 @@ void obj_validate(SEXP object) { if (validate == NULL) validate = Rf_findVarInFrame(ns_S7, Rf_install("validate")); - eval_here(Rf_lang4( - validate, object, - /* recursive = */ Rf_ScalarLogical(TRUE), - /* properties = */ Rf_ScalarLogical(FALSE))); -} - + switch (TYPEOF(object)) { + case LANGSXP: + case SYMSXP: { + // Wrap the call or symbol in quote(), so it doesn't evaluate in Rf_eval() + object = PROTECT(Rf_lang2(fn_base_quote, object)); + eval_here(Rf_lang4(validate, object, + /* recursive = */ Rf_ScalarLogical(TRUE), + /* properties = */ Rf_ScalarLogical(FALSE))); + UNPROTECT(1); // object + return; + } + default: + eval_here(Rf_lang4( + validate, object, + /* recursive = */ Rf_ScalarLogical(TRUE), + /* properties = */ Rf_ScalarLogical(FALSE))); + } +} static inline Rboolean getter_callable_no_recurse(SEXP getter, SEXP object, SEXP name_sym) { @@ -248,9 +307,10 @@ SEXP prop_(SEXP object, SEXP name) { SEXP getter = extract_name(property, "getter"); if (TYPEOF(getter) == CLOSXP && getter_callable_no_recurse(getter, object, name_sym)) { - SEXP value = PROTECT(eval_here(Rf_lang2(getter, object))); + + SEXP value = PROTECT(do_call1(getter, object)); getter_no_recurse_clear(object, name_sym); - UNPROTECT(1); + UNPROTECT(1); // value return value; } @@ -316,7 +376,7 @@ SEXP prop_set_(SEXP object, SEXP name, SEXP check_sexp, SEXP value) { if (setter_callable_no_recurse(setter, object, name_sym, &should_validate_obj)) { // use setter() - REPROTECT(object = eval_here(Rf_lang3(setter, object, value)), object_pi); + REPROTECT(object = do_call2(setter, object, value), object_pi); setter_no_recurse_clear(object, name_sym); } else { // don't use setter() diff --git a/tests/testthat/_snaps/zzz.md b/tests/testthat/_snaps/zzz.md index ee034fbe..9c222d92 100644 --- a/tests/testthat/_snaps/zzz.md +++ b/tests/testthat/_snaps/zzz.md @@ -22,12 +22,12 @@ x <- new_class("foo")() x[1] Condition - Error: + Error in `check_subsettable()`: ! S7 objects are not subsettable. Code x[1] <- 1 Condition - Error: + Error in `check_subsettable()`: ! S7 objects are not subsettable. # [[ gives more accurate error @@ -36,11 +36,11 @@ x <- new_class("foo")() x[[1]] Condition - Error: + Error in `check_subsettable()`: ! S7 objects are not subsettable. Code x[[1]] <- 1 Condition - Error: + Error in `check_subsettable()`: ! S7 objects are not subsettable. diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 7e2b2751..0bc2cf08 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -140,3 +140,8 @@ dbg <- function(..., .display = utils::str, .file = NULL) { } `%error%` <- function(x, y) tryCatch(x, error = function(e) y) + +drop_attributes <- function(x) { + attributes(x) <- NULL + x +} diff --git a/tests/testthat/test-property.R b/tests/testthat/test-property.R index be4caa93..5e6e876a 100644 --- a/tests/testthat/test-property.R +++ b/tests/testthat/test-property.R @@ -444,3 +444,79 @@ test_that("custom setters can call custom getters", { expect_equal(x@someprop, "FOOFOO") }) + + +test_that("custom getters don't evaulate call objects", { + QuotedCall := new_class(class_call, properties = list( + name = new_property(getter = function(self) { + stopifnot(is.call(self)) + as.character(self[[1]]) + }), + args = new_property(getter = function(self) { + stopifnot(is.call(self)) + as.list(self)[-1] + }) + ), constructor = function(x) { + new_object(substitute(x)) + }) + + cl <- QuotedCall(stop("boom")) + expect_equal(cl@name, "stop") + expect_equal(cl@args, list("boom")) + +}) + + +test_that("custom setters don't evaulate call objects", { + + Call := new_class(class_call, properties = list( + name = new_property( + getter = function(self) { + stopifnot(is.call(self)) + as.character(self[[1]]) + }, + setter = function(self, value) { + stopifnot(is.call(self), is.name(value)) + self[[1]] <- value + self + } + ), + args = new_property( + getter = function(self) { + stopifnot(is.call(self)) + as.list(self)[-1] + }, + setter = function(self, value) { + stopifnot(is.call(self), is.list(value) || is.pairlist(value)) + # self[seq(2, length.out = length(value))] <- value + # names(self) <- c("", names(value)) + # self + out <- as.call(c(self[[1]], value)) + attributes(out) <- attributes(self) + out + }) + ), constructor = function(name, ...) { + new_object(as.call(c(as.name(name), ...))) + }) + + cl <- Call("stop", "boom") + expect_identical(cl@name, "stop") + expect_identical(cl@args, list("boom")) + + abort <- stop + cl@name <- quote(abort) + expect_identical(cl@name, "abort") + expect_identical(cl[[1]], quote(abort)) + + cl@args <- pairlist("boom2") + expect_identical(cl[[2]], "boom2") + expect_identical(cl@args, list("boom2")) + expect_identical(drop_attributes(cl), quote(abort("boom2"))) + + cl@args <- alist(msg = "boom3", foo = bar, baz) + expect_identical(cl@args, alist(msg = "boom3", foo = bar, baz)) + + expect_identical(drop_attributes(cl), + quote(abort(msg = "boom3", foo = bar, baz))) + +})