Fix run now errors and interrupts

DESCRIPTION

@@ -20,10 +20,11 @@ Imports:
     rlang
 LinkingTo: Rcpp
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.3.1
+RoxygenNote: 7.3.2
 Suggests:
     knitr,
     rmarkdown,
-    testthat (>= 2.1.0)
+    testthat (>= 2.1.0),
+    R6
 VignetteBuilder: knitr
 Encoding: UTF-8

src/callback_registry.h

@@ -56,7 +56,11 @@ class StdFunctionCallback : public Callback {
   StdFunctionCallback(Timestamp when, std::function<void (void)> func);
 
   void invoke() const {
-    func();
+    Rcpp::unwindProtect([this]() {
+      BEGIN_RCPP
+      func();
+      END_RCPP
+    });
   }
 
   Rcpp::RObject rRepresentation() const;

src/later.cpp

@@ -204,8 +204,15 @@ bool execCallbacksOne(
     if (callbacks.size() == 0) {
       break;
     }
+
+#ifdef RCPP_USING_UNWIND_PROTECT // See https://github.com/r-lib/later/issues/191
+    // This line may throw errors!
+    callbacks[0]->invoke();
+#else
     // This line may throw errors!
     callbacks[0]->invoke_wrapped();
+#endif
+
   } while (runAll);
 
   // I think there's no need to lock this since it's only modified from the

tests/testthat.R

@@ -4,4 +4,19 @@ Sys.setenv("R_TESTS" = "")
 library(testthat)
 library(later)
 
-test_check("later")
+DetailedSummaryReporter <- R6::R6Class("DetailedSummaryReporter", inherit = testthat::SummaryReporter,
+  public = list(
+    start_test = function(context, test) {
+      self$cat_tight("    ", test, ": ")
+    },
+    end_test = function(context, test) {
+      self$cat_line()
+    },
+    start_context = function(context) {
+      self$cat_tight(context, ":\n")
+    },
+    end_context = function(context) { }
+  )
+)
+
+test_check("later", reporter = DetailedSummaryReporter)

tests/testthat/test-private-loops.R

@@ -369,19 +369,18 @@ test_that("Removing parent loop allows loop to be deleted", {
 })
 
 test_that("Interrupt while running in private loop won't result in stuck loop", {
-  skip_on_ci()
-  skip_on_cran()
-  skip_on_os("mac")
-
   l <- create_loop()
-  later(function() { tools::pskill(Sys.getpid(), tools::SIGINT); Sys.sleep(1) }, loop = l)
-  run_now(loop = l)
+  later(function() { rlang::interrupt() }, loop = l)
+  tryCatch({
+    run_now(loop = l)
+  }, interrupt = function(e) NULL)
   expect_identical(current_loop(), global_loop())
 
-  with_loop(l, {
-    tools::pskill(Sys.getpid(), tools::SIGINT)
-    Sys.sleep(1)
-  })
+  tryCatch({
+    with_loop(l, {
+      rlang::interrupt()
+    })
+  }, interrupt = function(e) NULL)
   expect_identical(current_loop(), global_loop())
 })
 

tests/testthat/test-run_now.R

@@ -129,7 +129,11 @@ test_that("Callbacks cannot affect the caller", {
     run_now(1)
     return(200)
   }
-  expect_error(f())
+  # jcheng 2024-10-24: Apparently this works now, maybe because having
+  # RCPP_USING_UNWIND_PROTECT means we don't need to use R_ToplevelExec to call
+  # callbacks?
+  # expect_error(f())
+  expect_identical(f(), 100)
 
 
   # In this case, f() should return normally, and then when g() causes later to
@@ -149,12 +153,7 @@ test_that("Callbacks cannot affect the caller", {
 
 
 
-test_that("interrupt and exception handling", {
-  # These tests may fail in automated test environments due to the way they
-  # handle interrupts. (See #102)
-  skip_on_ci()
-  skip_on_cran()
-
+test_that("interrupt and exception handling, R", {
   # =======================================================
   # Errors and interrupts in R callbacks
   # =======================================================
@@ -176,17 +175,21 @@ test_that("interrupt and exception handling", {
   interrupted <- FALSE
   tryCatch(
     {
-      later(function() { tools::pskill(Sys.getpid(), tools::SIGINT) })
+      later(function() {rlang::interrupt(); Sys.sleep(100) })
       run_now()
     },
     interrupt = function(e) {
       interrupted <<- TRUE
     }
   )
   expect_true(interrupted)
+})
 
-
-
+test_that("interrupt and exception handling, C++", {
+  # Skip on Windows i386 because of known bad behavior
+  if (R.version$os == "mingw32" && R.version$arch == "i386") {
+    skip("C++ exceptions in later callbacks are known bad on Windows i386")
+  }
 
   # =======================================================
   # Exceptions in C++ callbacks
@@ -219,14 +222,12 @@ test_that("interrupt and exception handling", {
           throw std::string();
 
         } else if (value == 3) {
-          // Send an interrupt to the process.
-          kill(getpid(), SIGINT);
-          sleep(3);
-
+          // Interrupt the interpreter
+          Rf_onintr();
         } else if (value == 4) {
-          // Calls R function via Rcpp, which sends interrupt signal and then
-          // sleeps. Note: This gets converted to std::runtime_error.
-          Function("r_sleep_interrupt")();
+          // Calls R function via Rcpp, which interrupts.
+          // sleeps.
+          Function("r_interrupt")();
 
         } else if (value == 5) {
           // Calls R function via Rcpp which calls stop().
@@ -259,14 +260,13 @@ test_that("interrupt and exception handling", {
 
   # cpp_error() searches in the global environment for these R functions, so we
   # need to define them there.
-  .GlobalEnv$r_sleep_interrupt <- function() {
-    tools::pskill(Sys.getpid(), tools::SIGINT)
-    Sys.sleep(3)
+  .GlobalEnv$r_interrupt <- function() {
+    rlang::interrupt()
   }
   .GlobalEnv$r_error <- function() {
     stop("oopsie")
   }
-  on.exit(rm(r_sleep_interrupt, r_error, envir = .GlobalEnv), add = TRUE)
+  on.exit(rm(r_interrupt, r_error, envir = .GlobalEnv), add = TRUE)
 
   errored <- FALSE
   tryCatch(
@@ -282,24 +282,25 @@ test_that("interrupt and exception handling", {
   )
   expect_true(errored)
 
+
+  errored <- FALSE
+  tryCatch(
+    { cpp_error(5); run_now() },
+    error = function(e) errored <<- TRUE
+  )
+  expect_true(errored)
+
   interrupted <- FALSE
   tryCatch(
     { cpp_error(3); run_now() },
     interrupt = function(e) interrupted <<- TRUE
   )
   expect_true(interrupted)
 
-  errored <- FALSE
+  interrupted <- FALSE
   tryCatch(
     { cpp_error(4); run_now() },
     interrupt = function(e) interrupted <<- TRUE
   )
   expect_true(interrupted)
-
-  errored <- FALSE
-  tryCatch(
-    { cpp_error(5); run_now() },
-    error = function(e) errored <<- TRUE
-  )
-  expect_true(errored)
 })