Run unload hooks

NEWS.md

@@ -1,5 +1,12 @@
 # pkgload (development version)
 
+* When reloading a package, `load_all()` now runs the unload hooks of the
+  previously loaded package (`.onUnload()` and user hooks registered with
+  `setHook()`), whether it was loaded with pkgload or regularly. The old
+  namespace and its DLL are still kept loaded so that dangling references
+  continue to work, and errors thrown from `.onUnload()` are demoted to
+  warnings so that they can't prevent reloading (#253).
+
 # pkgload 1.5.2
 
 * Better handling of S7 topics (#332).

R/load.R

@@ -64,6 +64,13 @@
 #'    behavior when loading an installed package with [library()], and can
 #'    be useful for checking for missing exports.
 #'
+#' - When reloading a package, `load_all()` runs the unload hooks
+#'    (`.onUnload()` and hooks registered with [setHook()]) of the old
+#'    namespace, but doesn't unload the namespace or its DLL. This keeps
+#'    dangling references to the old namespace in working order. Errors
+#'    thrown from `.onUnload()` are demoted to warnings so that they can't
+#'    prevent reloading.
+#'
 #' # Controlling the debug compiler flags
 #'
 #' `load_all()` delegates to [pkgbuild::compile_dll()] to perform the actual
@@ -183,12 +190,19 @@ load_all <- function(
   old_methods <- list()
   clear_cache()
 
-  # Remove package from known namespaces. We don't unload it to allow
-  # safe usage of dangling references.
+  # Remove package from known namespaces. We don't fully unload it, to
+  # allow safe usage of dangling references, but we run the unload hooks
+  # since `unloadNamespace()` never will (#253).
   if (is_loaded(package)) {
     patch_colon(package)
 
     methods_env <- ns_s3_methods(package)
+
+    # Detach first so that hooks run in the same order as in
+    # `unloadNamespace()`: detach hooks, then unload hooks
+    unload_pkg_env(package)
+    run_unload_hooks(package)
+
     unregister(package)
 
     # Save foreign methods after unregistering the package's own

R/run-loadhooks.R

@@ -30,7 +30,8 @@ run_pkg_hook <- function(package, hook) {
   if (hook %in% c("load", "attach")) {
     nsenv[[f_name]](dirname(ns_path), package)
   } else {
-    nsenv[[f_name]](dirname(ns_path))
+    # `.onUnload()` and `.onDetach()` take the full path to the package
+    nsenv[[f_name]](ns_path)
   }
   metadata[[f_name]] <- TRUE
 
@@ -67,6 +68,9 @@ run_user_hook <- function(package, hook) {
     try_fetch(
       if (hook %in% c("load", "attach")) {
         fun(package, lib_path)
+      } else if (hook == "unload") {
+        # `unloadNamespace()` passes the full path to the package
+        fun(package, ns_path)
       } else {
         fun(package)
       },
@@ -89,3 +93,23 @@ run_user_hook <- function(package, hook) {
   metadata[[hook_name]] <- TRUE
   invisible(TRUE)
 }
+
+# Run the unload hooks of a package that `load_all()` is about to
+# reload. Reloading doesn't unload the namespace or its DLL (to allow
+# safe usage of dangling references), so `unloadNamespace()` never gets
+# a chance to run `.onUnload()` and the user `onUnload` hooks (#253).
+# Errors are demoted to warnings so that a failing hook can't prevent
+# reloading.
+run_unload_hooks <- function(package) {
+  run_user_hook(package, "unload")
+
+  try_fetch(
+    run_pkg_hook(package, "unload"),
+    error = function(cnd) {
+      cli::cli_warn(
+        "Problem while running `.onUnload()` for package {.pkg {package}}.",
+        parent = cnd
+      )
+    }
+  )
+}

tests/testthat/test-load-hooks.R

@@ -25,6 +25,24 @@ test_that("hooks called in correct order", {
     c("pkg_load", "user_load", "pkg_attach", "user_attach")
   )
 
+  # Reloading runs the detach and unload hooks of the old namespace,
+  # in the same order as `unloadNamespace()` (#253)
+  reset_events()
+  load_all("testHooks")
+  expect_equal(
+    globalenv()$hooks$events,
+    c(
+      "user_detach",
+      "pkg_detach",
+      "user_unload",
+      "pkg_unload",
+      "pkg_load",
+      "user_load",
+      "pkg_attach",
+      "user_attach"
+    )
+  )
+
   reset_events()
   unload("testHooks")
   expect_equal(
@@ -137,6 +155,45 @@ test_that("onUnload", {
   rm(".__testLoadHooks__", envir = .GlobalEnv)
 })
 
+test_that("load_all() runs .onUnload() when reloading (#253)", {
+  load_all("testLoadHooks")
+
+  .GlobalEnv$.__testLoadHooks__ <- 1
+  load_all("testLoadHooks")
+  expect_equal(.GlobalEnv$.__testLoadHooks__, 2)
+
+  # unload() runs the hook of the new namespace as usual
+  unload("testLoadHooks")
+  expect_equal(.GlobalEnv$.__testLoadHooks__, 3)
+
+  rm(".__testLoadHooks__", envir = .GlobalEnv)
+})
+
+test_that(".onUnload() receives the full path to the package (#253)", {
+  load_all("testLoadHooks")
+
+  path <- NULL
+  with_options(
+    "pkgload:::testLoadHooks::.onUnload" = function(libpath) path <<- libpath,
+    load_all("testLoadHooks")
+  )
+  expect_equal(normalizePath(path), normalizePath(test_path("testLoadHooks")))
+
+  unload("testLoadHooks")
+})
+
+test_that("a failing .onUnload() doesn't prevent reloading (#253)", {
+  load_all("testLoadHooks")
+
+  with_options(
+    "pkgload:::testLoadHooks::.onUnload" = function(libpath) stop("uh oh"),
+    expect_warning(load_all("testLoadHooks"), "onUnload")
+  )
+  expect_true(is_loaded("testLoadHooks"))
+
+  unload("testLoadHooks")
+})
+
 test_that("user onLoad hooks are properly run", {
   load_all("testUserLoadHook")
 

tests/testthat/testLoadHooks/R/a.r

@@ -40,6 +40,11 @@ the$onattach_lib <- ""
 }
 
 .onUnload <- function(libpath) {
+  hook <- getOption("pkgload:::testLoadHooks::.onUnload")
+  if (is.function(hook)) {
+    hook(libpath)
+  }
+
   # Increment this variable if it exists in the global env
   if (exists(".__testLoadHooks__", .GlobalEnv)) {
     .GlobalEnv$.__testLoadHooks__ <- .GlobalEnv$.__testLoadHooks__ + 1