Add support for R 4.6 (#391)

* Add support for R 4.6.

    R 4.6 removes the C (de-facto-)API function Rf_FindVarInFrame(). This
commit updates the C implementation to add support for the new API.

* Add more unit tests

* Work around breaking change in ‘testthat’ v3.3.0

---------

Co-authored-by: ArcadeAntics <nsnjsnd@gmail.com>

Author: klmr

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: box
 Title: Write Reusable, Composable and Modular R Code
-Version: 1.2.1.9000
+Version: 1.2.2
 Authors@R: c(
         person(
             'Konrad', 'Rudolph',

NEWS.md

@@ -1,3 +1,10 @@
+# box 1.2.2
+
+## Miscellaneous
+
+* Update the C implementation to adapt to R C API changes in R 4.6.0 (@ArcadeAntics, #391).
+
+
 # box 1.2.1
 
 ## Bug fixes

src/lookup.c

@@ -29,21 +29,33 @@ SEXP strict_extract(SEXP e1, SEXP e2) {
     // Return value of `install` does not need to be protected:
     // <https://github.com/kalibera/cran-checks/blob/master/rchk/PROTECT.md>
     SEXP name = Rf_installTrChar(STRING_ELT(e2, 0));
-    SEXP ret = Rf_findVarInFrame(e1, name);
-
-    if (ret == R_UnboundValue) {
-        SEXP parent = PROTECT(parent_frame());
-        SEXP call = PROTECT(sys_call(parent));
-        SEXP fst_arg = PROTECT(CADR(call));
 
-        Rf_errorcall(
-            call, "name '%s' not found in '%s'",
-            Rf_translateChar(STRING_ELT(e2, 0)),
-            Rf_translateChar(PRINTNAME(fst_arg))
-        );
+#if R_VERSION < R_Version(4, 6, 0)
+    SEXP ret = Rf_findVarInFrame(e1, name);
+    if (ret != R_UnboundValue) {
+        if (TYPEOF(ret) == PROMSXP) {
+            PROTECT(ret);
+            ret = Rf_eval(ret, e1);
+            UNPROTECT(1);
+        }
+        return ret;
     }
+#else
+    SEXP ret = R_getVarEx(name, e1, /* inherits */ FALSE, /* ifnotfound */ NULL);
+    if (ret) {
+        return ret;
+    }
+#endif
+
+    SEXP parent = PROTECT(parent_frame());
+    SEXP call = PROTECT(sys_call(parent));
+    SEXP fst_arg = PROTECT(CADR(call));
 
-    return ret;
+    Rf_errorcall(
+        call, "name '%s' not found in '%s'",
+        Rf_translateChar(STRING_ELT(e2, 0)),
+        Rf_translateChar(PRINTNAME(fst_arg))
+    );
 }
 
 // Cached version of an R function that calls `sys.frame(-1L)`.

tests/testthat/helper-expect.r

@@ -71,32 +71,64 @@ expect_messages = function (object, has = NULL, has_not = NULL, info = NULL, lab
     act = withCallingHandlers(
         testthat::quasi_label(rlang::enquo(object), label, arg = 'object'),
         message = function (m) {
-            self$messages = c(self$messages, m$message)
+            self$messages = c(self$messages, sub('\\n$', '', conditionMessage(m)))
             invokeRestart('muffleMessage')
         }
     )
 
-    pretty_messages = paste('*', messages, collapse = '')
-
-    find = function (pattern, x) any(grepl(pattern, x))
-
-    testthat::expect(
-        all(vapply(has, find, logical(1L), messages)),
-        sprintf(
-            '%s did not produce the expected message(s). It produced:\n%s',
-            act$lab, pretty_messages
-        ),
-        info = info
+    pretty_messages = function (which) {
+        paste('*', vapply(messages[which], deparse, character(1L)), collapse = '\n')
+    }
+
+    if (! is.null(has) && length(has) != length(messages)) {
+        testthat::expect(
+            FALSE,
+            sprintf(
+                '%s did not produce %s message(s). It produced:\n%s\n\nExpected:\n%s',
+                act$lab,
+                length(messages),
+                pretty_messages(TRUE),
+                paste('*', vapply(has[TRUE], deparse, character(1L)), collapse = '\n')
+            ),
+            info = info
+        )
+    }
+
+    expected = unlist(box:::map(grepl, has, messages))
+
+    if (! all(expected)) {
+        # We can’t use `testthat::expect(all(expected), …)` here, since that will cause the subsequent assertion to
+        # be ignored inside a nested assertion, such as when used inside `expect_failure`. This caused the test of
+        # this helper itself to fail.
+        testthat::expect(
+            FALSE,
+            sprintf(
+                '%s did not produce the expected message(s). It produced:\n%s\n\nExpected:\n%s',
+                act$lab,
+                pretty_messages(! expected),
+                paste('*', vapply(has[! expected], deparse, character(1L)), collapse = '\n')
+            ),
+            info = info
+        )
+    }
+
+    unexpected = vapply(
+        messages,
+        function (m) any(vapply(has_not, grepl, logical(1L), m)),
+        logical(1L)
     )
 
-    testthat::expect(
-        ! any(vapply(has_not, find, logical(1L), messages)),
-        sprintf(
-            '%s produces unexpected message(s). It produced:\n%s',
-            act$lab, pretty_messages
-        ),
-        info = info
-    )
+    if (any(unexpected)) {
+        testthat::expect(
+            FALSE,
+            sprintf(
+                '%s produced unwanted message(s):\n%s',
+                act$lab,
+                pretty_messages(unexpected)
+            ),
+            info = info
+        )
+    }
 }
 
 in_globalenv = function (expr) {

tests/testthat/mod/active2.r

@@ -0,0 +1,12 @@
+.on_load = function (ns) {
+    makeActiveBinding(
+        'binding',
+        function () {
+            message('get')
+            1L
+        },
+        ns
+    )
+}
+
+box::export(binding)

tests/testthat/test-active.r

@@ -14,3 +14,30 @@ test_that('active bindings can be attached', {
     expect_equal(binding, 1L)
     expect_message(binding, 'get')
 })
+
+test_that('active binding can be exported from .on_load()', {
+    box::use(mod/active2)
+    expect_setequal(ls(active2), 'binding')
+    expect_true(bindingIsActive('binding', active2))
+    expect_equal(active2$binding, 1L)
+    expect_message(active2$binding, 'get')
+})
+
+test_that('active binding can be attached from .on_load()', {
+    box::use(mod/active2[...])
+    expect_true(bindingIsActive('binding', parent.env(environment())))
+    expect_equal(binding, 1L)
+    expect_message(binding, 'get')
+})
+
+test_that('active binding is lazily evaluted', {
+    box::use(active = mod/active[...])
+
+    f = function (x) {
+        message('f')
+        x
+    }
+
+    expect_messages(f(active$binding), c('^f', '^get'))
+    expect_messages(f(binding), c('^f', '^get'))
+})

tests/testthat/test-expectations.r

@@ -38,3 +38,35 @@ test_that('`expect_not_in` works', {
     expect_failure(expect_not_in(2, c(1, 2, 3)))
     expect_failure(expect_not_in('A', LETTERS))
 })
+
+test_that('`expect_messages` works', {
+    expect_messages(
+        {
+            message('foo')
+            message('bar')
+        },
+        c('foo', 'bar')
+    )
+
+    expect_failure(
+        expect_messages(
+            {
+                message('foo')
+                message('bar')
+            },
+            c('foo', 'baz')
+        ),
+        'did not produce the expected message'
+    )
+
+    expect_failure(
+        expect_messages(
+            {
+                message('foo')
+                message('bar')
+            },
+            has_not = 'foo'
+        ),
+        'produced unwanted message\\(s\\):\n\\* "foo"'
+    )
+})

tests/testthat/test-reload.r

@@ -87,7 +87,7 @@ test_that('reload includes transitive dependencies', {
     box::use(mod/reload/a)
     expect_messages(
         box::reload(a),
-        has = c('^c unloaded', '^c loaded')
+        has = c('^a unloaded', '^c unloaded', '^c loaded')
     )
 })