Fix custom getters with class_call objects (#470)

* print `topNamespaceName()` NULL value * protect call objects from evaluation when calling custom `getter` * add test for call `getter()` * fix custom `getter` on language objects. * allow subsetting `class_call` objects * add tests for custom `setter` on `class_call` objects * tidy; dry; rename helper * Update R/zzz.R Co-authored-by: Hadley Wickham <h.wickham@gmail.com> * Update R/zzz.R Co-authored-by: Hadley Wickham <h.wickham@gmail.com> * Use early return in `topNamespaceName()` for readability --------- Co-authored-by: Hadley Wickham <h.wickham@gmail.com>
RConsortium · Oct 25, 2024 · 70d1c85 · 70d1c85
1 parent 5e939fb
commit 70d1c85
Show file tree

Hide file tree

Showing 7 changed files with 165 additions and 17 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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)))
+
+})