diff --git a/NAMESPACE b/NAMESPACE index f4560765..16148e7b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -53,6 +53,7 @@ export(S7_methods) export(S7_object) export(S7_on_build) export(S7_on_load) +export(S7_on_unload) export(as_class) export(check_is_S7) export(class_Date) diff --git a/NEWS.md b/NEWS.md index 20c14238..3f154556 100644 --- a/NEWS.md +++ b/NEWS.md @@ -18,6 +18,7 @@ * `method<-` and `method()` now accept a length-1 list as `signature` for single-dispatch generics, matching the list-of-classes form required for multi-dispatch (#555). * `new_object()` now names its first argument `_parent` to minimise the chance of a clash with a property (#423). It also accepts a single unnamed named list as a shortcut for splicing property values, making it easier to programmatically construct an object from a list of properties (#497). * `method<-` can now register methods on S3 and S4 generics with base types (e.g. `class_character`), S3 classes (`new_S3_class()`, `class_factor`, etc.), S7 unions (expanded to one registration per class), `class_any` (registered as the `default` method), and `NULL` (registered as the `NULL` method) (#455). +* `method<-` no longer emits an "Overwriting method" message when re-registering an identical method, eliminating spurious messages from `devtools::load_all()` (#474). * `new_class()` now errors if a child class overrides a parent property with a type that doesn't extend the parent's type, since such a class could never be instantiated. Narrowing the type is still allowed, as are dynamic (getter) properties (#352). * `new_class()` now allows properties named `names`, `dim`, `dimnames`, `class`, `comment`, `tsp`, and `row.names`. But property names beginning with `_` are now reserved for internal use (#579). * `new_class()` experimentally allows `class_environment` as a parent again, so you can build S7 objects that share R's reference semantics for environments. This support is provisional: because environments are mutated in place, some operations behave differently than for value-typed S7 objects, and the API may change. `S7_data()` and `S7_data<-()` error on environment-based objects, since they would otherwise destroy the object's S7 attributes in place (#590). @@ -41,8 +42,9 @@ * `S7_data<-()` now preserves attributes (like `names` or `dim`) from the replacement data instead of carrying over the originals, so resizing the underlying data works correctly (#478). * `S7_error_method_not_found` now has a correct class vector without a duplicate `"error"` entry (@jjjermiah, #604). * `S7_inherits()` and `check_is_S7()` now accept any class specification (S7 class, S7 union, S3 class, S4 class, or base type wrapper like `class_integer`), not just S7 classes (#556). +* `S7_on_load()` is the new name for `methods_register()`, giving it a nicer symmetry with `S7_on_build()`; `methods_register()` remains available for backward compatibility (#615). It no longer accumulates duplicate registration hooks when a package is loaded repeatedly (#316). +* New `S7_on_unload()`, to be called from `.onUnload()`, unregisters active methods and removes hooks added by `S7_on_load()` (#316). * `set_props()` now names its first argument `_object` to minimise the chances of a clash with a property (#423). It also accepts a single unnamed named list as a shortcut for splicing property values, making it easier to set properties programmatically (#497). -* `S7_on_load()` is the new name for `methods_register()`, giving it a nicer symmetry with `S7_on_build()`; `methods_register()` remains available for backward compatibility (#615). * `str()` on S7 objects that inherit from data.frame (or other S3 classes whose underlying data has a `dim` attribute incompatible with the bare base type) no longer errors (#494). * `super()` now works with S3 and S4 objects, not just S7 objects (#500). * `validate()` now signals validation errors with class `S7_error_validation_failed`, so they can be caught with `tryCatch()` (#602, #605). diff --git a/R/external-generic.R b/R/external-generic.R index 6e72ecca..fab97db3 100644 --- a/R/external-generic.R +++ b/R/external-generic.R @@ -76,6 +76,18 @@ is_external_generic <- function(x) { inherits(x, "S7_external_generic") } +external_generic_available <- function(generic) { + is_external_generic(generic) && + isNamespaceLoaded(generic$package) && + external_generic_version_ok(generic, asNamespace(generic$package)) +} + +external_generic_version_ok <- function(generic, ns) { + stopifnot(is_external_generic(generic), is.environment(ns)) + + is.null(generic$version) || getNamespaceVersion(ns) >= generic$version +} + registrar <- function(generic, signature, method, env) { # Force all arguments generic @@ -85,9 +97,7 @@ registrar <- function(generic, signature, method, env) { function(...) { ns <- asNamespace(generic$package) - if ( - is.null(generic$version) || getNamespaceVersion(ns) >= generic$version - ) { + if (external_generic_version_ok(generic, ns)) { if (!exists(generic$name, envir = ns, inherits = FALSE)) { msg <- sprintf( "[S7] Failed to find generic %s() in package %s", @@ -108,15 +118,24 @@ external_methods_reset <- function(package) { invisible() } -external_methods_add <- function(package, generic, signature, method) { - tbl <- S7_methods_table(package) +external_methods_add <- function( + package, + generic, + signature, + method +) { + # Remove any existing entries + external_methods_remove(package, generic, signature) - append1(tbl) <- list( + entry <- list( generic = generic, signature = signature, method = method ) + tbl <- S7_methods_table(package) + append1(tbl) <- entry + S7_methods_table(package) <- tbl invisible() } diff --git a/R/generic.R b/R/generic.R index abef58ac..a9f510b6 100644 --- a/R/generic.R +++ b/R/generic.R @@ -226,7 +226,8 @@ generic_add_method <- function(generic, signature, method) { } p_tbl <- tbl } else { - if (!is.null(p_tbl[[class_name]])) { + existing <- p_tbl[[class_name]] + if (!is.null(existing) && !identical(existing, method)) { message("Overwriting method ", method_name(generic, signature)) } p_tbl[[class_name]] <- method @@ -252,3 +253,17 @@ generic_remove_method <- function(generic, signature) { } invisible() } + +generic_get_method <- function(generic, signature) { + p_tbl <- generic@methods + chr_signature <- vcapply(signature, class_register) + + for (class_name in chr_signature) { + p_tbl <- p_tbl[[class_name]] + if (is.null(p_tbl)) { + return(NULL) + } + } + + p_tbl +} diff --git a/R/hooks.R b/R/hooks.R index da966524..11d11396 100644 --- a/R/hooks.R +++ b/R/hooks.R @@ -1,7 +1,7 @@ #' Package hooks for S7 methods #' #' @description -#' When using S7 in a package, add two hooks to your `zzz.R`: +#' When using S7 in a package, add three hooks to your `zzz.R`: #' #' * Call `S7_on_load()` from `.onLoad()`. This is S7's way of #' registering methods, rather than using `NAMESPACE` directives like S3 and @@ -11,6 +11,11 @@ #' packages, but there's no harm in always including it and it ensures you #' won't forget later. #' +#' * Call `S7_on_unload()` from `.onUnload()`. This cleans up after +#' `S7_on_load()`: it unregisters methods that your package registered for +#' S7 generics in other packages, if they are still active, and removes any +#' hooks that `S7_on_load()` added. +#' #' * Call `S7_on_build()` at the top level (i.e. *not* inside `.onLoad()`) #' after all method registration is complete. This avoids embedding copies #' of external generics in your package when you use `method<-`. @@ -21,12 +26,15 @@ #' See `vignette("packages")` for more details. #' #' @importFrom utils getFromNamespace packageName -#' @returns Nothing; both functions are called for their side-effects. +#' @returns Nothing; these functions are called for their side-effects. #' @examples #' # In zzz.R: #' .onLoad <- function(...) { #' S7::S7_on_load() #' } +#' .onUnload <- function(...) { +#' S7::S7_on_unload() +#' } #' S7::S7_on_build() #' @export S7_on_load <- function() { @@ -41,20 +49,97 @@ methods_register <- function() { S7_on_load_ <- function(env) { package <- packageName(env) - ns <- topenv(env) - # TODO?: check/enforce that S7_on_load() is being called from .onLoad() - tbl <- S7_methods_table(package) + hooks_remove(package) # always start from a clean slate + hooks <- hooks_add(package) + hooks_run_loaded(hooks) # run hooks for loaded packages + + invisible() +} + +#' @export +#' @rdname S7_on_load +S7_on_unload <- function() { + S7_on_unload_(parent.frame()) +} + +S7_on_unload_ <- function(env) { + package <- packageName(env) + hooks_remove(package) + tbl <- S7_methods_table(package) for (x in tbl) { + if (!isNamespaceLoaded(x$generic$package)) { + next + } + + ns <- asNamespace(x$generic$package) + if (!external_generic_version_ok(x$generic, ns)) { + next + } + + generic <- get0(x$generic$name, envir = ns, inherits = FALSE) + if (is.null(generic)) { + next + } + generic <- as_generic(generic) + # Methods registered for S3 and S4 generics can't be unregistered yet + if (is_S7_generic(generic)) { + unregister_own_S7_method( + generic, + x$signature, + x$method, + package + ) + } + } + + invisible() +} + +# Add a hook for each method that registers it when its generic's package is +# loaded. Returns the added hooks, named by the package they're attached to. +hooks_add <- function(package) { + ns <- asNamespace(package) + tbl <- S7_methods_table(package) + pkgs <- vcapply(tbl, function(x) x$generic$package) + + hooks <- lapply(tbl, function(x) { register <- registrar(x$generic, x$signature, x$method, ns) + hook <- S7_hook(register, package) + setHook(packageEvent(x$generic$package, "onLoad"), hook) + hook + }) + names(hooks) <- pkgs + hooks_packages(package) <- union(hooks_packages(package), pkgs) + hooks +} + +# Remove our hooks for `package`. +hooks_remove <- function(package) { + tbl <- S7_methods_table(package) + pkgs <- unique(c( + hooks_packages(package), + vcapply(tbl, function(x) x$generic$package) + )) - if (isNamespaceLoaded(x$generic$package)) { - register() + for (pkg in pkgs) { + event <- packageEvent(pkg, "onLoad") + hooks <- getHook(event) + ours <- vlapply(hooks, is_S7_hook, package = package) + if (any(ours)) { + setHook(event, hooks[!ours], action = "replace") } - setHook(packageEvent(x$generic$package, "onLoad"), register) } + hooks_packages(package) <- character() + invisible() +} +hooks_run_loaded <- function(hooks) { + is_loaded <- vlapply(names(hooks), isNamespaceLoaded) + for (hook in hooks[is_loaded]) { + hook() + } invisible() } @@ -80,3 +165,49 @@ generic_sentinel <- function(generic) { } is_generic_sentinel <- function(x) inherits(x, "S7_generic_sentinel") + + +# Tag our hooks so we can remove later +S7_hook <- function(fun, package) { + attr(fun, "S7_package") <- package + class(fun) <- "S7_hook" + fun +} +is_S7_hook <- function(x, package = NULL) { + if (!inherits(x, "S7_hook")) { + return(FALSE) + } + is.null(package) || identical(attr(x, "S7_package", TRUE), package) +} + +hooks_packages <- function(package) { + ns <- asNamespace(package) + tbl <- ns[[".__S3MethodsTable__."]] + attr(tbl, "S7hooks") %||% character() +} +`hooks_packages<-` <- function(package, value) { + ns <- asNamespace(package) + tbl <- ns[[".__S3MethodsTable__."]] + attr(tbl, "S7hooks") <- value + invisible() +} + +unregister_own_S7_method <- function( + generic, + signature, + method, + package = NULL +) { + signatures <- flatten_signature(signature) + for (i in seq_along(signatures)) { + sig <- signatures[[i]] + current <- generic_get_method(generic, sig) + own <- S7_method_for_signature(method, generic, sig, package = package) + # Unload only removes the method this package currently owns. It does not + # remember or restore any method that was overwritten during loading. + if (identical(current, own)) { + generic_remove_method(generic, sig) + } + } + invisible() +} diff --git a/R/method-register.R b/R/method-register.R index 6d2ee4c3..2afd6ea3 100644 --- a/R/method-register.R +++ b/R/method-register.R @@ -77,19 +77,31 @@ register_method <- function( original <- generic generic <- as_generic(generic, call = call) signature <- as_signature(signature, generic, call = call) + method_package <- packageName(env) - if (is_external_generic(generic) && isNamespaceLoaded(generic$package)) { + if (external_generic_available(generic)) { generic <- as_generic( getFromNamespace(generic$name, generic$package), call = call ) } + external <- NULL + if (!is.null(package) && !is_local_generic(generic, package)) { + external <- as_external_generic(generic, env) + } + # Register in current session signatures <- flatten_signature(signature) if (is_S7_generic(generic)) { for (sig in signatures) { - register_S7_method(generic, sig, method, call = call) + register_S7_method( + generic, + sig, + method, + package = method_package, + call = call + ) } register_ops_bridge(generic, signatures, env) } else if (is_S3_generic(generic)) { @@ -105,7 +117,6 @@ register_method <- function( # if we're inside a package, we also need to be able register methods # when the package is loaded if (!is.null(package) && !is_local_generic(generic, package)) { - external <- as_external_generic(generic, env) external_methods_add(package, external, signature, method) return(generic_sentinel(external)) } @@ -124,7 +135,7 @@ unregister_method <- function( generic <- as_generic(generic, call = call) signature <- as_signature(signature, generic, call = call) - if (is_external_generic(generic) && isNamespaceLoaded(generic$package)) { + if (external_generic_available(generic)) { generic <- as_generic( getFromNamespace(generic$name, generic$package), call = call @@ -155,6 +166,7 @@ register_S7_method <- function( generic, signature, method, + package = NULL, call = sys.call(-1L) ) { check_method( @@ -163,12 +175,33 @@ register_S7_method <- function( name = method_name(generic, signature), call = call ) - method <- S7_method(method, generic = generic, signature = signature) + method <- S7_method_for_signature( + method, + generic, + signature, + package = package + ) generic_add_method(generic, signature, method) invisible() } +S7_method_for_signature <- function( + method, + generic, + signature, + package = NULL +) { + method <- S7_method(method, generic = generic, signature = signature) + if (is.null(attr(method, "name", TRUE))) { + attr(method, "name") <- as.name(method_signature(generic, signature)) + } + if (!is.null(package)) { + attr(method, "S7_package") <- package + } + method +} + unregister_S7_method <- function(generic, signature) { signatures <- flatten_signature(signature) for (signature in signatures) { diff --git a/man/S7_on_load.Rd b/man/S7_on_load.Rd index 80321a48..7560b184 100644 --- a/man/S7_on_load.Rd +++ b/man/S7_on_load.Rd @@ -3,6 +3,7 @@ \name{S7_on_load} \alias{S7_on_load} \alias{methods_register} +\alias{S7_on_unload} \alias{S7_on_build} \title{Package hooks for S7 methods} \usage{ @@ -10,13 +11,15 @@ S7_on_load() methods_register() +S7_on_unload() + S7_on_build() } \value{ -Nothing; both functions are called for their side-effects. +Nothing; these functions are called for their side-effects. } \description{ -When using S7 in a package, add two hooks to your \code{zzz.R}: +When using S7 in a package, add three hooks to your \code{zzz.R}: \itemize{ \item Call \code{S7_on_load()} from \code{.onLoad()}. This is S7's way of registering methods, rather than using \code{NAMESPACE} directives like S3 and @@ -25,6 +28,10 @@ other packages are registered as needed when your package is loaded. This is only strictly necessary if you register methods for generics in other packages, but there's no harm in always including it and it ensures you won't forget later. +\item Call \code{S7_on_unload()} from \code{.onUnload()}. This cleans up after +\code{S7_on_load()}: it unregisters methods that your package registered for +S7 generics in other packages, if they are still active, and removes any +hooks that \code{S7_on_load()} added. \item Call \code{S7_on_build()} at the top level (i.e. \emph{not} inside \code{.onLoad()}) after all method registration is complete. This avoids embedding copies of external generics in your package when you use \verb{method<-}. @@ -40,5 +47,8 @@ See \code{vignette("packages")} for more details. .onLoad <- function(...) { S7::S7_on_load() } +.onUnload <- function(...) { + S7::S7_on_unload() +} S7::S7_on_build() } diff --git a/tests/testthat/_snaps/method-register.md b/tests/testthat/_snaps/method-register.md index 006e3f3a..3873f0ea 100644 --- a/tests/testthat/_snaps/method-register.md +++ b/tests/testthat/_snaps/method-register.md @@ -2,7 +2,7 @@ Code method(foo, class_character) <- (function(x) "c") - method(foo, class_character) <- (function(x) "c") + method(foo, class_character) <- (function(x) "C") Message Overwriting method foo() diff --git a/tests/testthat/helper.R b/tests/testthat/helper.R index 56787f77..912c657d 100644 --- a/tests/testthat/helper.R +++ b/tests/testthat/helper.R @@ -55,6 +55,37 @@ local_methods <- function(..., frame = parent.frame()) { invisible() } +# Simulate a package with namesapce +local_package <- function(name, ..., frame = parent.frame()) { + ns <- new.env(parent = asNamespace("S7")) + + info <- new.env(parent = emptyenv()) + info$spec <- c(name = name, version = "0.0.0") + ns[[".__NAMESPACE__."]] <- info + ns[[".packageName"]] <- name + ns[[".__S3MethodsTable__."]] <- new.env(parent = emptyenv()) + + # register namespace so asNamespace(pkg) works + internal <- get(".Internal", envir = baseenv()) + internal(registerNamespace(name, ns)) + defer(internal(unregisterNamespace(name)), frame = frame) + defer(S7_on_unload_(ns), frame = frame) + + for (expr in eval(substitute(alist(...)))) { + eval(expr, ns) + } + + ns +} + +# Filter out any IDE hooks added interactively (e.g. Positron registers an +# "ark_onload_hook" for every package), leaving only the hooks S7 manages. +package_hooks <- function(package, event = "onLoad") { + hooks <- getHook(packageEvent(package, event)) + is_ide_hook <- function(hook) any(startsWith(class(hook), "ark_")) + Filter(function(hook) !is_ide_hook(hook), hooks) +} + local_S4_class <- function( name, ..., diff --git a/tests/testthat/t2/R/t2.R b/tests/testthat/t2/R/t2.R index 2fe62ff3..5acb70a3 100644 --- a/tests/testthat/t2/R/t2.R +++ b/tests/testthat/t2/R/t2.R @@ -38,4 +38,8 @@ S7::method(another_s3_generic, an_s7_class) <- function(x) "foo" S7::S7_on_load() } +.onUnload <- function(libpath) { + S7::S7_on_unload() +} + S7::S7_on_build() diff --git a/tests/testthat/test-external-generic.R b/tests/testthat/test-external-generic.R index c4710908..3a423189 100644 --- a/tests/testthat/test-external-generic.R +++ b/tests/testthat/test-external-generic.R @@ -1,13 +1,12 @@ test_that("can get and append methods", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) + local_package("testpkg") - expect_equal(S7_methods_table("S7"), list()) + expect_equal(S7_methods_table("testpkg"), list()) bar <- new_external_generic("foo", "bar", "x") - external_methods_add("S7", bar, list(), function() {}) + external_methods_add("testpkg", bar, list(), function() {}) expect_equal( - S7_methods_table("S7"), + S7_methods_table("testpkg"), list( list( generic = bar, @@ -18,42 +17,46 @@ test_that("can get and append methods", { ) }) +test_that("re-adding a method replaces the existing entry", { + local_package("testpkg") + + bar <- new_external_generic("foo", "bar", "x") + external_methods_add("testpkg", bar, list("A"), function() "a") + external_methods_add("testpkg", bar, list("A"), function() "b") + expect_length(S7_methods_table("testpkg"), 1) + expect_equal(S7_methods_table("testpkg")[[1]]$method(), "b") +}) + test_that("can remove methods", { - external_methods_reset("S7") - on.exit(external_methods_reset("S7"), add = TRUE) + local_package("testpkg") bar <- new_external_generic("foo", "bar", "x") baz <- new_external_generic("foo", "baz", "x") - external_methods_add("S7", bar, list("A"), function() "a") - external_methods_add("S7", baz, list("B"), function() "b") - expect_length(S7_methods_table("S7"), 2) + external_methods_add("testpkg", bar, list("A"), function() "a") + external_methods_add("testpkg", baz, list("B"), function() "b") + expect_length(S7_methods_table("testpkg"), 2) - external_methods_remove("S7", bar, list("A")) - expect_length(S7_methods_table("S7"), 1) - expect_equal(S7_methods_table("S7")[[1]]$generic, baz) + external_methods_remove("testpkg", bar, list("A")) + expect_length(S7_methods_table("testpkg"), 1) + expect_equal(S7_methods_table("testpkg")[[1]]$generic, baz) # No-op when entry doesn't exist - external_methods_remove("S7", bar, list("A")) - expect_length(S7_methods_table("S7"), 1) + external_methods_remove("testpkg", bar, list("A")) + expect_length(S7_methods_table("testpkg"), 1) }) test_that("displays nicely", { bar <- new_external_generic("foo", "bar", "x") - on.exit(external_methods_reset("S7"), add = TRUE) - expect_snapshot({ print(bar) }) }) test_that("can convert existing generics to external", { - foo_S7 := new_generic("x") - env <- new.env() - env$.packageName <- "test" - environment(foo_S7) <- env + ns <- local_package("test", foo_S7 := new_generic("x")) expect_equal( - as_external_generic(foo_S7), + as_external_generic(ns$foo_S7), new_external_generic("test", "foo_S7", "x") ) diff --git a/tests/testthat/test-hooks.R b/tests/testthat/test-hooks.R index 18f80c0a..e48f1306 100644 --- a/tests/testthat/test-hooks.R +++ b/tests/testthat/test-hooks.R @@ -1,3 +1,153 @@ +test_that("S7_on_load() doesn't accumulate hooks across repeated loads", { + upstream <- local_package("upstream", gen := new_generic("x")) + expect_length(package_hooks("upstream"), 0) + + downstream <- local_package( + "downstream", + Foo := new_class(), + gen := new_external_generic("upstream", dispatch_args = "x"), + method(gen, Foo) <- \(x) "dispatched" + ) + S7_on_load_(downstream) + expect_length(package_hooks("upstream"), 1) + S7_on_load_(downstream) + expect_length(package_hooks("upstream"), 1) +}) + +test_that("S7_on_unload() unregisters methods and removes hooks", { + upstream <- local_package("upstream", gen := new_generic("x")) + downstream <- local_package( + "downstream", + Foo := new_class(), + gen := new_external_generic("upstream", dispatch_args = "x"), + method(gen, Foo) <- \(x) "dispatched" + ) + S7_on_load_(downstream) + + S7_on_unload_(downstream) + expect_length(package_hooks("upstream"), 0) + expect_error( + upstream$gen(downstream$Foo()), + class = "S7_error_method_not_found" + ) +}) + +test_that("S7_on_unload() unregisters base operator methods", { + local_methods(base_ops[["+"]]) + + downstream <- local_package( + "downstream_base_ops_unload", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + Foo := new_class(), + method(`+`, list(Foo, Foo)) <- function(e1, e2) "dispatched" + ) + downstream$.onLoad() + expect_equal(downstream$Foo() + downstream$Foo(), "dispatched") + + downstream$.onUnload() + expect_error( + downstream$Foo() + downstream$Foo(), + class = "S7_error_method_not_found" + ) +}) + +test_that("S7_on_unload() doesn't remove methods registered by another package", { + upstream <- local_package("upstream_conflict", gen := new_generic("x")) + first <- local_package( + "downstream_first", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_conflict", dispatch_args = "x"), + method(gen, class_character) <- function(x) "first" + ) + first$.onLoad() + expect_equal(upstream$gen("x"), "first") + + second <- NULL + expect_message( + second <- local_package( + "downstream_second", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic("upstream_conflict", dispatch_args = "x"), + method(gen, class_character) <- function(x) "second" + ), + "Overwriting method" + ) + second$.onLoad() + expect_equal(upstream$gen("x"), "second") + + first$.onUnload() + expect_equal(upstream$gen("x"), "second") +}) + +test_that("S7_on_load() removes hooks for deleted external methods", { + upstream <- local_package("upstream_deleted", gen := new_generic("x")) + downstream <- local_package( + "downstream_deleted", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + Foo := new_class(), + gen := new_external_generic("upstream_deleted", dispatch_args = "x"), + method(gen, Foo) <- function(x) "dispatched" + ) + downstream$.onLoad() + expect_length(package_hooks("upstream_deleted"), 1) + + eval(quote(method(gen, Foo) <- NULL), downstream) + expect_error( + upstream$gen(downstream$Foo()), + class = "S7_error_method_not_found" + ) + + downstream$.onLoad() + expect_length(package_hooks("upstream_deleted"), 0) + expect_error( + upstream$gen(downstream$Foo()), + class = "S7_error_method_not_found" + ) +}) + +test_that("S7_on_unload() honors external generic version gates", { + downstream <- local_package( + "downstream_version_gate_unload", + .onLoad <- function(...) S7_on_load(), + .onUnload <- function(...) S7_on_unload(), + gen := new_external_generic( + "upstream_version_gate_unload", + dispatch_args = "x", + version = "1.0.0" + ), + method(gen, class_character) <- function(x) "downstream" + ) + upstream <- local_package( + "upstream_version_gate_unload", + gen <- function(x) "not an S7 generic" + ) + + downstream$.onLoad() + expect_equal(upstream$gen("x"), "not an S7 generic") + expect_no_error(downstream$.onUnload()) +}) + +test_that("S7_on_unload() unregisters methods when a real package is unloaded (#316)", { + skip_if(getRversion() < "4.1" && Sys.info()[["sysname"]] == "Windows") + skip_if(quick_test()) + + tmp_lib <- local_libpath() + local_install_and_attach(test_path("t0"), tmp_lib) + local_install_and_attach(test_path("t2"), tmp_lib) + + expect_equal(t0::an_s7_generic("x"), "foo") + + # t2's .onUnload() calls S7_on_unload(), which unregisters the methods + # it registered for t0's generics and removes its hooks for t1 + unloadNamespace("t2") + expect_null(t0::an_s7_generic@methods[["character"]]) + expect_length(package_hooks("t1"), 0) +}) + test_that("S7_on_build() removes only generic sentinels from the namespace", { ns <- new.env(parent = emptyenv()) ns$keep_fun <- function() {} diff --git a/tests/testthat/test-method-register.R b/tests/testthat/test-method-register.R index 9f6379b9..d198c1d3 100644 --- a/tests/testthat/test-method-register.R +++ b/tests/testthat/test-method-register.R @@ -9,11 +9,19 @@ test_that("method registration adds messages when overwriting", { foo := new_generic("x") expect_snapshot({ method(foo, class_character) <- function(x) "c" - method(foo, class_character) <- function(x) "c" + method(foo, class_character) <- function(x) "C" }) expect_length(methods(foo), 1) }) +test_that("re-registering an identical method is silent (#474)", { + foo := new_generic("x") + fn <- function(x) "c" + method(foo, class_character) <- fn + expect_no_message(method(foo, class_character) <- fn) + expect_length(methods(foo), 1) +}) + test_that("method registration adds a method for each element of a union", { foo := new_generic("x") method(foo, class_numeric) <- function(x) "x" diff --git a/vignettes/packages.Rmd b/vignettes/packages.Rmd index 66f56598..8988fcc9 100644 --- a/vignettes/packages.Rmd +++ b/vignettes/packages.Rmd @@ -26,19 +26,25 @@ library(S7) First, add `S7` to the `Imports` field of your `DESCRIPTION`. We then recommend importing all S7 functions into your package `NAMESPACE` with `import(S7)`, or, if you're using roxygen2, `@import S7`. -Next, create a `zzz.R` with a `.onLoad()` that calls `S7_on_load()` and a top-level call to `S7_on_build()`: +Next, create a `zzz.R` with a `.onLoad()` that calls `S7_on_load()`, an `.onUnload()` that calls `S7_on_unload()`, and a top-level call to `S7_on_build()`: ```{r} .onLoad <- function(...) { S7::S7_on_load() } +.onUnload <- function(...) { + S7::S7_on_unload() +} + S7::S7_on_build() ``` `S7_on_load()` is S7's way of registering methods, rather than using export directives in your `NAMESPACE` like S3 and S4 do. This is only strictly necessary if you are registering methods for generics in other packages, but there's no harm in adding it and it ensures that you won't forget later. +`S7_on_unload()` cleans up after `S7_on_load()`: it unregisters methods that your package registered, if they are still active, and removes hooks, so unloading your package doesn't leave stale state behind. + `S7_on_build()` cleans up after `method<-`. Because `method<-` is a replacement function, `method(generic, class) <- fun` is evaluated as `generic <- method<-(generic, class, fun)`, which would otherwise leave a copy of `generic` in your namespace. When `generic` belongs to another package, `method<-` returns a sentinel value instead of the generic, and `S7_on_build()` removes these sentinels from your namespace when the package is built.