Fix reactlog session token for "exit" actions

The "exit" actions were not being saved with the correct session
token, because on.exit() calls inside of withReactiveDomain() get
executed *after* the end of the withReactiveDomain.

R/react.R

@@ -21,8 +21,10 @@ Context <- R6Class(
       withReactiveDomain(.domain, {
         env <- .getReactiveEnvironment()
         .graphEnterContext(id)
-        on.exit(.graphExitContext(id), add = TRUE)
-        env$runWith(self, func)
+        tryCatch(
+          env$runWith(self, func),
+          finally = .graphExitContext(id)
+        )
       })
     },
     invalidate = function() {

R/reactive-domains.R

@@ -41,12 +41,13 @@ NULL
 # `reactlog(logEntry)`.
 #
 ## ------------------------------------------------------------------------
-createMockDomain <- function() {
-  callbacks <- list()
+createMockDomain <- function(token = createUniqueId(4)) {
+  callbacks <- Callbacks$new()
   ended <- FALSE
   domain <- new.env(parent = emptyenv())
+  domain$token <- token
   domain$onEnded <- function(callback) {
-    callbacks <<- c(callbacks, callback)
+    return(callbacks$register(callback))
   }
   domain$isEnded <- function() {
     ended
@@ -55,7 +56,7 @@ createMockDomain <- function() {
   domain$end <- function() {
     if (!ended) {
       ended <<- TRUE
-      lapply(callbacks, do.call, list())
+      callbacks$invoke()
     }
     invisible()
   }

R/reactives.R

@@ -591,6 +591,7 @@ Observer <- R6Class(
     .domain = 'ANY',
     .priority = numeric(0),
     .autoDestroy = logical(0),
+    .autoDestroyHandle = 'ANY',
     .invalidateCallbacks = list(),
     .execCount = integer(0),
     .onResume = 'function',
@@ -620,7 +621,6 @@ registerDebugHook("observerFunc", environment(), label)
       }
       .label <<- label
       .domain <<- domain
-      .autoDestroy <<- autoDestroy
       .priority <<- normalizePriority(priority)
       .execCount <<- 0L
       .suspended <<- suspended
@@ -628,7 +628,9 @@ registerDebugHook("observerFunc", environment(), label)
       .destroyed <<- FALSE
       .prevId <<- ''
 
-      onReactiveDomainEnded(.domain, self$.onDomainEnded)
+      .autoDestroy <<- FALSE
+      .autoDestroyHandle <<- NULL
+      setAutoDestroy(autoDestroy)
 
       # Defer the first running of this until flushReact is called
       .createContext()$invalidate()
@@ -706,11 +708,28 @@ registerDebugHook("observerFunc", environment(), label)
       "Sets whether this observer should be automatically destroyed when its
       domain (if any) ends. If autoDestroy is TRUE and the domain already
       ended, then destroy() is called immediately."
+
+      if (.autoDestroy == autoDestroy) {
+        return(.autoDestroy)
+      }
+
       oldValue <- .autoDestroy
       .autoDestroy <<- autoDestroy
-      if (!is.null(.domain) && .domain$isEnded()) {
-        destroy()
+
+      if (autoDestroy) {
+        if (!.destroyed && !is.null(.domain)) { # Make sure to not try to destroy twice.
+          if (.domain$isEnded()) {
+            destroy()
+          } else {
+            .autoDestroyHandle <<- onReactiveDomainEnded(.domain, .onDomainEnded)
+          }
+        }
+      } else {
+        if (!is.null(.autoDestroyHandle))
+          .autoDestroyHandle()
+        .autoDestroyHandle <<- NULL
       }
+
       invisible(oldValue)
     },
     suspend = function() {
@@ -743,6 +762,11 @@ registerDebugHook("observerFunc", environment(), label)
       suspend()
       .destroyed <<- TRUE
 
+      if (!is.null(.autoDestroyHandle)) {
+        .autoDestroyHandle()
+      }
+      .autoDestroyHandle <<- NULL
+
       if (!is.null(.ctx)) {
         .ctx$invalidate()
       }

tests/testthat/test-reactivity.r

@@ -819,6 +819,66 @@ test_that("observers autodestroy (or not)", {
   })
 })
 
+test_that("observers are garbage collected when destroyed", {
+  domain <- createMockDomain()
+  rv <- reactiveValues(x = 1)
+
+  # Auto-destroy. GC on domain end.
+  a <- observe(rv$x, domain = domain)
+  # No auto-destroy. GC with rv.
+  b <- observe(rv$x, domain = domain, autoDestroy = FALSE)
+  # No auto-destroy and no reactive dependencies. GC immediately.
+  c <- observe({}, domain = domain)
+  c$setAutoDestroy(FALSE)
+  # Similar to b, but we'll set it to autoDestroy later.
+  d <- observe(rv$x, domain = domain, autoDestroy = FALSE)
+  # Like a, but we'll destroy it immediately.
+  e <- observe(rx$x, domain = domain)
+  e$destroy()
+
+  collected <- new.env(parent = emptyenv())
+
+  reg.finalizer(a, function(o) collected$a <- TRUE)
+  reg.finalizer(b, function(o) collected$b <- TRUE)
+  reg.finalizer(c, function(o) collected$c <- TRUE)
+  reg.finalizer(d, function(o) collected$d <- TRUE)
+  reg.finalizer(e, function(o) collected$e <- TRUE)
+
+  rm(list = c("a", "b", "c", "e")) # Not "d"
+
+  gc()
+  # Nothing can be GC'd yet, because all of the observers are
+  # pending execution (i.e. waiting for flushReact).
+  expect_equal(ls(collected), character())
+
+  flushReact()
+  # Now "c" can be garbage collected, because it ran and took
+  # no dependencies (and isn't tied to the session in any way).
+  # And "e" can also be garbage collected, it's been destroyed.
+  gc()
+  expect_equal(ls(collected), c("c", "e"))
+
+  domain$end()
+  # We can GC "a" as well; even though it references rv, it is
+  # destroyed when the session ends.
+  gc()
+  expect_equal(sort(ls(collected)), c("a", "c", "e"))
+
+  # It's OK to turn on auto-destroy even after the session was
+  # destroyed.
+  d$setAutoDestroy(TRUE)
+  # This should no-op.
+  d$setAutoDestroy(FALSE)
+  rm(d)
+  gc()
+  expect_equal(sort(ls(collected)), c("a", "c", "d", "e"))
+
+  rm(rv)
+  # Both rv and "b" can now be collected.
+  gc()
+  expect_equal(sort(ls(collected)), c("a", "b", "c", "d", "e"))
+})
+
 test_that("maskReactiveContext blocks use of reactives", {
   vals <- reactiveValues(x = 123)
 
@@ -916,3 +976,28 @@ test_that("event handling helpers take correct dependencies", {
   expect_equal(execCount(o1), 2)
   expect_equal(execCount(o2), 2)
 })
+
+test_that("reactlog is correct", {
+  op <- options(shiny.reactlog = TRUE)
+  on.exit(options(op))
+
+  # Observer outside of the reactive domain shouldn't affect
+  # the actions below (that will be filtered on domain token)
+  observe({})
+
+  domain <- createMockDomain()
+  withReactiveDomain(domain, {
+    observe({}, label = "my observer")
+  })
+
+  flushReact()
+  log <- .graphStack$as_list()
+  log <- Filter(function(x) {
+    identical(x$session, domain$token)
+  }, log)
+  actions <- Map(function(x) x$action, log)
+
+  # Just make sure that the reactlog hits all of the actions
+  # we expect. An earlier bug caused "exit" not to show up.
+  expect_equal(actions, list("ctx", "invalidate", "ctx", "enter", "exit"))
+})

tests/testthat/test-stacks.R

@@ -43,10 +43,10 @@ test_that("integration tests", {
   df <- causeError(full = FALSE)
   # dumpTests(df)
 
-  expect_equal(df$num, c(32L, 31L, 30L, 19L, 18L, 17L, 16L, 15L,
-    8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L))
+  expect_equal(df$num, c(36L, 35L, 34L, 21L, 20L, 19L, 18L,
+    17L, 8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L))
   expect_equal(df$call, c("A", "B", "<reactive:C>", "C", "renderTable",
-    "func", "origRenderFunc","renderTable({     C() }, server = FALSE)",
+    "func", "origRenderFunc", "renderTable({     C() }, server = FALSE)",
     "isolate", "withCallingHandlers", "captureStackTraces", "doTryCatch",
     "tryCatchOne", "tryCatchList", "tryCatch", "try"))
   expect_equal(nzchar(df$loc), c(TRUE, TRUE, TRUE, FALSE, TRUE,
@@ -56,25 +56,25 @@ test_that("integration tests", {
   df <- causeError(full = TRUE)
   # dumpTests(df)
 
-  expect_equal(df$num, c(35L, 34L, 33L, 32L, 31L, 30L, 29L, 28L,
-    27L, 26L, 25L, 24L, 23L, 22L, 21L, 20L, 19L, 18L, 17L, 16L,
-    15L, 14L, 13L, 12L, 11L, 10L, 9L, 8L, 7L, 6L, 5L, 4L, 3L,
-    2L, 1L))
+  expect_equal(df$num, c(39L, 38L, 37L, 36L, 35L, 34L, 33L,
+    32L, 31L, 30L, 29L, 28L, 27L, 26L, 25L, 24L, 23L, 22L, 21L,
+    20L, 19L, 18L, 17L, 16L, 15L, 14L, 13L, 12L, 11L, 10L, 9L,
+    8L, 7L, 6L, 5L, 4L, 3L, 2L, 1L))
   expect_equal(df$call, c("h", ".handleSimpleError", "stop",
     "A", "B", "<reactive:C>", "..stacktraceon..", ".func", "withVisible",
-    "withCallingHandlers", "contextFunc", "env$runWith", "withReactiveDomain",
-    "ctx$run", "self$.updateValue", "..stacktraceoff..", "C",
-    "renderTable", "func", "origRenderFunc",
+    "withCallingHandlers", "contextFunc", "env$runWith", "tryCatchList",
+    "tryCatch", "withReactiveDomain", "ctx$run", "self$.updateValue",
+    "..stacktraceoff..", "C", "renderTable", "func", "origRenderFunc",
     "renderTable({     C() }, server = FALSE)", "..stacktraceon..",
-    "contextFunc", "env$runWith", "withReactiveDomain", "ctx$run",
-    "..stacktraceoff..", "isolate", "withCallingHandlers",
-    "captureStackTraces", "doTryCatch", "tryCatchOne", "tryCatchList",
-    "tryCatch", "try"))
+    "contextFunc", "env$runWith", "tryCatchList", "tryCatch",
+    "withReactiveDomain", "ctx$run", "..stacktraceoff..", "isolate",
+    "withCallingHandlers", "captureStackTraces", "doTryCatch",
+    "tryCatchOne", "tryCatchList", "tryCatch", "try"))
   expect_equal(nzchar(df$loc), c(FALSE, FALSE, FALSE, TRUE,
     TRUE, TRUE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
-    FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE, FALSE, FALSE,
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, TRUE, FALSE, FALSE,
     FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE,
-    FALSE, FALSE, FALSE, FALSE))
+    FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE, FALSE))
 })
 
 test_that("shiny.error", {