Simplify some validations and add further tests

R/later.R

@@ -74,14 +74,12 @@ create_loop <- function(parent = current_loop()) {
   id <- .globals$next_id
   .globals$next_id <- id + 1L
 
-  if (!is.null(parent) && !inherits(parent, "event_loop")) {
-    stop("`parent` must be NULL or an event_loop object.")
-  }
-
   if (is.null(parent)) {
     parent_id <- -1L
-  } else {
+  } else if (inherits(parent, "event_loop")) {
     parent_id <- parent$id
+  } else {
+    stop("`parent` must be NULL or an event_loop object.")
   }
   createCallbackRegistry(id, parent_id)
 
@@ -108,10 +106,6 @@ create_loop <- function(parent = current_loop()) {
 }
 
 notify_r_ref_deleted <- function(loop) {
-  if (identical(loop, global_loop())) {
-    stop("Can't notify that reference to global loop is deleted.")
-  }
-
   res <- notifyRRefDeleted(loop$id)
   if (res) {
     rm(list = as.character(loop$id), envir = .loops)
@@ -122,10 +116,6 @@ notify_r_ref_deleted <- function(loop) {
 #' @rdname create_loop
 #' @export
 destroy_loop <- function(loop) {
-  if (identical(loop, global_loop())) {
-    stop("Can't destroy global loop.")
-  }
-
   res <- deleteCallbackRegistry(loop$id)
   if (res) {
     rm(list = as.character(loop$id), envir = .loops)

src/later.cpp

@@ -134,10 +134,10 @@ shared_ptr<CallbackRegistry> getGlobalRegistry() {
 bool deleteCallbackRegistry(int loop_id) {
   ASSERT_MAIN_THREAD()
   if (loop_id == GLOBAL_LOOP) {
-    Rf_error("Can't delete global loop.");
+    Rf_error("Can't destroy global loop.");
   }
   if (loop_id == getCurrentRegistryId()) {
-    Rf_error("Can't delete current loop.");
+    Rf_error("Can't destroy current loop.");
   }
 
   return callbackRegistryTable.remove(loop_id);
@@ -149,10 +149,10 @@ bool deleteCallbackRegistry(int loop_id) {
 bool notifyRRefDeleted(int loop_id) {
   ASSERT_MAIN_THREAD()
   if (loop_id == GLOBAL_LOOP) {
-    Rf_error("Can't delete global loop.");
+    Rf_error("Can't notify that reference to global loop is deleted.");
   }
   if (loop_id == getCurrentRegistryId()) {
-    Rf_error("Can't delete current loop.");
+    Rf_error("Can't notify that reference to current loop is deleted.");
   }
 
   return callbackRegistryTable.notifyRRefDeleted(loop_id);

tests/testthat/_snaps/private-loops.md

@@ -9,17 +9,17 @@
 ---
 
     Code
-      with_loop(l, run_now())
+      run_now(loop = l)
     Condition
-      Error in `with_loop()`:
-      ! loop has been destroyed!
+      Error in `execCallbacks()`:
+      ! CallbackRegistry does not exist.
 
 ---
 
     Code
       destroy_loop(global_loop())
     Condition
-      Error in `destroy_loop()`:
+      Error in `deleteCallbackRegistry()`:
       ! Can't destroy global loop.
 
 # Temporary event loops
@@ -33,72 +33,78 @@
       Error in `with_loop()`:
       ! loop has been destroyed!
 
-# next_op_secs works
+# list_queue
 
     Code
-      next_op_secs(loop)
+      list_queue(l)
     Condition
-      Error in `nextOpSecs()`:
+      Error in `list_queue_()`:
       ! CallbackRegistry does not exist.
 
-# parameter validation works
+# next_op_secs works
 
     Code
-      create_loop(parent = "invalid")
+      next_op_secs(loop)
     Condition
-      Error in `create_loop()`:
-      ! `parent` must be NULL or an event_loop object.
+      Error in `nextOpSecs()`:
+      ! CallbackRegistry does not exist.
 
----
+# parameter validation works
 
     Code
-      destroy_loop(global_loop())
+      with_loop(loop, destroy_loop(loop))
     Condition
-      Error in `destroy_loop()`:
-      ! Can't destroy global loop.
+      Error in `deleteCallbackRegistry()`:
+      ! Can't destroy current loop.
 
 ---
 
     Code
-      loop <- create_loop(parent = NULL)
-      destroy_loop(loop)
       with_loop(loop, { })
     Condition
       Error in `with_loop()`:
       ! loop has been destroyed!
 
-# esoteric error handlers
+---
 
     Code
-      with_loop(loop, deleteCallbackRegistry(current_loop()$id))
+      loop_empty(loop)
     Condition
-      Error in `deleteCallbackRegistry()`:
-      ! Can't delete current loop.
+      Error in `idle()`:
+      ! CallbackRegistry does not exist.
 
 ---
 
     Code
-      with_loop(loop, {
-        .loops[[as.character(loop$id)]] <- NULL
-        current_loop()
-      })
+      create_loop(parent = "invalid")
     Condition
-      Error in `current_loop()`:
-      ! Current loop with id 43 not found.
+      Error in `create_loop()`:
+      ! `parent` must be NULL or an event_loop object.
 
----
+# esoteric error handlers
 
     Code
       notify_r_ref_deleted(global_loop())
     Condition
-      Error in `notify_r_ref_deleted()`:
+      Error in `notifyRRefDeleted()`:
       ! Can't notify that reference to global loop is deleted.
 
 ---
 
     Code
-      deleteCallbackRegistry(global_loop()$id)
+      with_loop(loop, notify_r_ref_deleted(loop))
     Condition
-      Error in `deleteCallbackRegistry()`:
-      ! Can't delete global loop.
+      Error in `notifyRRefDeleted()`:
+      ! Can't notify that reference to current loop is deleted.
+
+---
+
+    Code
+      with_loop(loop, {
+        .loops[[as.character(loop$id)]] <- NULL
+        current_loop()
+      })
+    Condition
+      Error in `current_loop()`:
+      ! Current loop with id 43 not found.
 

tests/testthat/test-later-fd.R

@@ -110,15 +110,17 @@ test_that("later_fd() errors when passed destroyed loops", {
 })
 
 test_that("later_fd C API works", {
+  skip_if(using_ubsan())
   env <- new.env()
   Rcpp::cppFunction(
     depends = 'later',
     includes = '
       #include <later_api.h>
+      void func(int *value, void *data) {}
     ',
     code = '
       int testfd() {
-        later::later_fd([](int *, void *){}, NULL, 0, NULL, 0, 0);
+        later::later_fd(func, nullptr, 0, nullptr, 0.0, 0);
         return 0;
       }
     ',

tests/testthat/test-private-loops.R

@@ -60,7 +60,7 @@ test_that("Private event loops", {
 
   # Can't run later-y things with destroyed loop
   expect_snapshot(error = TRUE, with_loop(l, later(function() message("foo"))))
-  expect_snapshot(error = TRUE, with_loop(l, run_now()))
+  expect_snapshot(error = TRUE, run_now(loop = l))
 
   # GC with functions in destroyed loops, even if callback isn't executed.
   l <- create_loop(parent = NULL)
@@ -445,6 +445,9 @@ test_that("list_queue", {
   with_loop(l, run_now())
   q <- list_queue(l)
   expect_equal(length(q), 0)
+
+  destroy_loop(l)
+  expect_snapshot(error = TRUE, list_queue(l))
 })
 
 test_that("next_op_secs works", {
@@ -465,13 +468,13 @@ test_that("next_op_secs works", {
 })
 
 test_that("parameter validation works", {
+  loop <- create_loop(parent = NULL)
+  expect_snapshot(error = TRUE, with_loop(loop, destroy_loop(loop)))
+  expect_true(destroy_loop(loop))
+  expect_false(destroy_loop(loop))
+  expect_snapshot(error = TRUE, with_loop(loop, {}))
+  expect_snapshot(error = TRUE, loop_empty(loop))
   expect_snapshot(error = TRUE, create_loop(parent = "invalid"))
-  expect_snapshot(error = TRUE, destroy_loop(global_loop()))
-  expect_snapshot(error = TRUE, {
-    loop <- create_loop(parent = NULL)
-    destroy_loop(loop)
-    with_loop(loop, {})
-  })
 })
 
 test_that("print.event_loop works correctly", {
@@ -487,15 +490,12 @@ test_that("print.event_loop works correctly", {
 
 test_that("esoteric error handlers", {
   loop <- create_loop(parent = NULL)
-  expect_snapshot(error = TRUE, {
-    with_loop(loop, deleteCallbackRegistry(current_loop()$id))
-  })
+  expect_snapshot(error = TRUE, notify_r_ref_deleted(global_loop()))
+  expect_snapshot(error = TRUE, with_loop(loop, notify_r_ref_deleted(loop)))
   expect_snapshot(error = TRUE, {
     with_loop(loop, {
       .loops[[as.character(loop$id)]] <- NULL
       current_loop()
     })
   })
-  expect_snapshot(error = TRUE, notify_r_ref_deleted(global_loop()))
-  expect_snapshot(error = TRUE, deleteCallbackRegistry(global_loop()$id))
 })