Implement S7_on_unload()

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)

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).

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()
 }

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
+}

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()
+}

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) {