From 0663e5da017d4f3c2b2eb844a3096c1d69e75955 Mon Sep 17 00:00:00 2001 From: Konrad Rudolph Date: Mon, 6 Apr 2026 21:22:07 +0200 Subject: [PATCH 1/6] 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. --- src/lookup.c | 7 ++++++- tests/testthat/mod/active2.r | 12 ++++++++++++ tests/testthat/test-active.r | 15 +++++++++++++++ 3 files changed, 33 insertions(+), 1 deletion(-) create mode 100644 tests/testthat/mod/active2.r diff --git a/src/lookup.c b/src/lookup.c index 6c6d98ff..7bd401b6 100644 --- a/src/lookup.c +++ b/src/lookup.c @@ -29,7 +29,12 @@ SEXP strict_extract(SEXP e1, SEXP e2) { // Return value of `install` does not need to be protected: // SEXP name = Rf_installTrChar(STRING_ELT(e2, 0)); - SEXP ret = Rf_findVarInFrame(e1, name); + SEXP ret = +#if R_VERSION < R_Version(4, 5, 0) + Rf_findVarInFrame(e1, name); +#else + R_getVarEx(name, e1, FALSE, R_UnboundValue); +#endif if (ret == R_UnboundValue) { SEXP parent = PROTECT(parent_frame()); diff --git a/tests/testthat/mod/active2.r b/tests/testthat/mod/active2.r new file mode 100644 index 00000000..224af6d3 --- /dev/null +++ b/tests/testthat/mod/active2.r @@ -0,0 +1,12 @@ +.on_load = function (ns) { + makeActiveBinding( + 'binding', + function () { + message('get') + 1L + }, + ns + ) +} + +box::export(binding) diff --git a/tests/testthat/test-active.r b/tests/testthat/test-active.r index 8b037773..f31ca77c 100644 --- a/tests/testthat/test-active.r +++ b/tests/testthat/test-active.r @@ -14,3 +14,18 @@ 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') +}) From f5e8e5671b7fed6ec24a2d8c83ff9619af21a1b4 Mon Sep 17 00:00:00 2001 From: Konrad Rudolph Date: Wed, 8 Apr 2026 00:40:29 +0200 Subject: [PATCH 2/6] Add more unit tests --- tests/testthat/helper-expect.r | 46 ++++++++++++++++++++---------- tests/testthat/test-active.r | 12 ++++++++ tests/testthat/test-expectations.r | 32 +++++++++++++++++++++ tests/testthat/test-reload.r | 2 +- 4 files changed, 76 insertions(+), 16 deletions(-) diff --git a/tests/testthat/helper-expect.r b/tests/testthat/helper-expect.r index 2247a499..3dd22570 100644 --- a/tests/testthat/helper-expect.r +++ b/tests/testthat/helper-expect.r @@ -71,29 +71,45 @@ 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') + } + + expected = unlist(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)), + ! any(unexpected), sprintf( - '%s produces unexpected message(s). It produced:\n%s', - act$lab, pretty_messages + '%s produced unwanted message(s):\n%s', + act$lab, + pretty_messages(unexpected) ), info = info ) diff --git a/tests/testthat/test-active.r b/tests/testthat/test-active.r index f31ca77c..e4309200 100644 --- a/tests/testthat/test-active.r +++ b/tests/testthat/test-active.r @@ -29,3 +29,15 @@ test_that('active binding can be attached from .on_load()', { 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')) +}) diff --git a/tests/testthat/test-expectations.r b/tests/testthat/test-expectations.r index 8e94e115..0a5e0b79 100644 --- a/tests/testthat/test-expectations.r +++ b/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"' + ) +}) diff --git a/tests/testthat/test-reload.r b/tests/testthat/test-reload.r index a66e88c3..10e0fd73 100644 --- a/tests/testthat/test-reload.r +++ b/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') ) }) From 02d797f85ede8fee02b661ae7aa4b5eb03f6aa29 Mon Sep 17 00:00:00 2001 From: Konrad Rudolph Date: Wed, 8 Apr 2026 01:00:34 +0200 Subject: [PATCH 3/6] =?UTF-8?q?Work=20around=20breaking=20change=20in=20?= =?UTF-8?q?=E2=80=98testthat=E2=80=99=20v3.3.0?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- tests/testthat/helper-expect.r | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/tests/testthat/helper-expect.r b/tests/testthat/helper-expect.r index 3dd22570..98b4d153 100644 --- a/tests/testthat/helper-expect.r +++ b/tests/testthat/helper-expect.r @@ -104,15 +104,17 @@ expect_messages = function (object, has = NULL, has_not = NULL, info = NULL, lab logical(1L) ) - testthat::expect( - ! any(unexpected), - sprintf( - '%s produced unwanted message(s):\n%s', - act$lab, - pretty_messages(unexpected) - ), - 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) { From 39d6c549e28b2b011741fdeae9e49f06361b7201 Mon Sep 17 00:00:00 2001 From: Konrad Rudolph Date: Wed, 8 Apr 2026 11:44:30 +0200 Subject: [PATCH 4/6] Fix custom expectation type --- tests/testthat/helper-expect.r | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/tests/testthat/helper-expect.r b/tests/testthat/helper-expect.r index 98b4d153..f42dc612 100644 --- a/tests/testthat/helper-expect.r +++ b/tests/testthat/helper-expect.r @@ -80,7 +80,21 @@ expect_messages = function (object, has = NULL, has_not = NULL, info = NULL, lab paste('*', vapply(messages[which], deparse, character(1L)), collapse = '\n') } - expected = unlist(Map(grepl, has, messages)) + 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 From 3034ce9b9b09c6887d6d3b8b74cd7894b2770f41 Mon Sep 17 00:00:00 2001 From: ArcadeAntics Date: Wed, 8 Apr 2026 07:04:33 -0400 Subject: [PATCH 5/6] Remove references to `R_UnboundValue` (#392) * remove references to R_UnboundValue In R >= 4.6, remove references to R_UnboundValue in favour of R_GetBindingType() (since R_UnboundValue will also be removed along with Rf_findVarInFrame) * avoid using R_GetBindingType(), use R_getVarEx(,,, NULL) instead * Fix promise evaluation and code style --------- Co-authored-by: Konrad Rudolph --- src/lookup.c | 39 +++++++++++++++++++++++---------------- 1 file changed, 23 insertions(+), 16 deletions(-) diff --git a/src/lookup.c b/src/lookup.c index 7bd401b6..8428d3ba 100644 --- a/src/lookup.c +++ b/src/lookup.c @@ -29,26 +29,33 @@ SEXP strict_extract(SEXP e1, SEXP e2) { // Return value of `install` does not need to be protected: // SEXP name = Rf_installTrChar(STRING_ELT(e2, 0)); - SEXP ret = -#if R_VERSION < R_Version(4, 5, 0) - Rf_findVarInFrame(e1, name); + +#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 - R_getVarEx(name, e1, FALSE, R_UnboundValue); + SEXP ret = R_getVarEx(name, e1, /* inherits */ FALSE, /* ifnotfound */ NULL); + if (ret) { + return ret; + } #endif - 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)) - ); - } + 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)`. From c732266a3d51cb67bbe260127c811da54e8c008b Mon Sep 17 00:00:00 2001 From: Konrad Rudolph Date: Wed, 8 Apr 2026 17:17:23 +0200 Subject: [PATCH 6/6] Bump version, document changes --- DESCRIPTION | 2 +- NEWS.md | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index f2dc6b48..9184777c 100644 --- a/DESCRIPTION +++ b/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', diff --git a/NEWS.md b/NEWS.md index ae60e4b8..d06c1246 100644 --- a/NEWS.md +++ b/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