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 diff --git a/src/lookup.c b/src/lookup.c index 6c6d98ff..8428d3ba 100644 --- a/src/lookup.c +++ b/src/lookup.c @@ -29,21 +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 = 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)`. diff --git a/tests/testthat/helper-expect.r b/tests/testthat/helper-expect.r index 2247a499..f42dc612 100644 --- a/tests/testthat/helper-expect.r +++ b/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) { 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..e4309200 100644 --- a/tests/testthat/test-active.r +++ b/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')) +}) 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') ) })