fix: Calling igraph from a warning handler no longer corrupts the call that warned

src/rinterface_extra.c

@@ -2377,13 +2377,84 @@ void Rx_igraph_error(void) {
   Rf_error("%s", Rx_igraph_error_reason);
 }
 
+/* Signalling a warning runs R code -- calling handlers, a testthat or knitr
+ * capture, `options(warn = 1)` printing -- while the C function that raised it
+ * is still on the stack: its vectors are registered on the finally stack,
+ * and the attributes of a graph it is about to return are kept alive only by
+ * the preserve list. That R code may call igraph again, and the nested call
+ * would free the outer vectors (`R_igraph_finalizer()` calls
+ * IGRAPH_FINALLY_FREE()), drop the preserve list and overwrite a pending
+ * error. The frame below saves that state, opens a new finally stack level so
+ * that nested calls only ever free their own entries, and restores everything
+ * once the warning has been signalled, also when a handler jumps out. */
+typedef struct {
+  char message[sizeof(Rx_igraph_warning_reason)];
+  char error_reason[sizeof(Rx_igraph_error_reason)];
+  int errors_count;
+  bool in_r_check;
+  SEXP preserved;
+} Rx_igraph_warning_frame_t;
+
+/* HELPER: internal C; must use IGRAPH_CHECK */
+static SEXP Rx_igraph_warning_signal(void *data) {
+  Rx_igraph_warning_frame_t *frame = (Rx_igraph_warning_frame_t *) data;
+  /* Rf_warning() would take its call from the innermost context, which is
+   * now the one R_UnwindProtect() opened, and so lose the call of the R
+   * function that called into C unless that function is byte-compiled.
+   * base::warning() names the closure below it, as Rf_warning() did
+   * before; domain = NA leaves the message untranslated, as Rf_warning()
+   * does. */
+  SEXP message = PROTECT(Rf_mkString(frame->message));
+  SEXP domain = PROTECT(Rf_ScalarLogical(NA_LOGICAL));
+  SEXP expr = PROTECT(Rf_lang3(Rf_install("warning"), message, domain));
+  SET_TAG(CDDR(expr), Rf_install("domain"));
+  Rf_eval(expr, R_BaseEnv);
+  UNPROTECT(3);
+  return R_NilValue;
+}
+
 /* HELPER: internal C; must use IGRAPH_CHECK */
-void Rx_igraph_warning(void) {
-  if (Rx_igraph_warnings_count > 0) {
-    Rx_igraph_warnings_count = 0;
+static void Rx_igraph_warning_restore(void *data, Rboolean jump) {
+  IGRAPH_UNUSED(jump);
+  Rx_igraph_warning_frame_t *frame = (Rx_igraph_warning_frame_t *) data;
+
+  /* A nested call that left without its finalizer leaves entries
+   * at this level; they belong to nobody else. */
+  IGRAPH_FINALLY_FREE();
+  IGRAPH_FINALLY_EXIT();
 
-    Rf_warning("%s", Rx_igraph_warning_reason);
+  if (Rx_igraph_attribute_preserve_list) {
+    SETCDR(Rx_igraph_attribute_preserve_list, frame->preserved);
   }
+  memcpy(Rx_igraph_error_reason, frame->error_reason, sizeof(Rx_igraph_error_reason));
+  Rx_igraph_errors_count = frame->errors_count;
+  Rx_igraph_in_r_check = frame->in_r_check;
+}
+
+/* HELPER: internal C; must use IGRAPH_CHECK */
+void Rx_igraph_warning(void) {
+  if (Rx_igraph_warnings_count == 0) {
+    return;
+  }
+  Rx_igraph_warnings_count = 0;
+
+  Rx_igraph_warning_frame_t frame;
+  memcpy(frame.message, Rx_igraph_warning_reason, sizeof(frame.message));
+  memcpy(frame.error_reason, Rx_igraph_error_reason, sizeof(frame.error_reason));
+  frame.errors_count = Rx_igraph_errors_count;
+  frame.in_r_check = Rx_igraph_in_r_check;
+  frame.preserved = Rx_igraph_attribute_preserve_list ?
+    CDR(Rx_igraph_attribute_preserve_list) : R_NilValue;
+  PROTECT(frame.preserved);
+
+  SEXP cont = PROTECT(R_MakeUnwindCont());
+  IGRAPH_FINALLY_ENTER();
+  R_UnwindProtect(
+    Rx_igraph_warning_signal, &frame,
+    Rx_igraph_warning_restore, &frame,
+    cont
+  );
+  UNPROTECT(2);
 }
 
 /* HELPER: internal C; must use IGRAPH_CHECK */

tests/testthat/test-warning-reentrancy.R

@@ -0,0 +1,102 @@
+# A warning from the C core is signalled while the C function that raised it
+# is still on the stack. R code that runs at that point, a calling handler for
+# instance, may call igraph again; the nested call must not free the vectors of
+# the outer call or drop the attributes of the graph it is about to return.
+
+test_that("a warning handler that calls igraph does not corrupt the call", {
+  g <- make_ring(4)
+  expected <- suppressWarnings(triad_census(g))
+
+  out <- withCallingHandlers(
+    triad_census(g),
+    warning = function(w) {
+      degree(make_ring(3))
+      invokeRestart("muffleWarning")
+    }
+  )
+
+  expect_identical(out, expected)
+})
+
+test_that("a logging handler can look at the graph that warned", {
+  graphs <- list(make_ring(4), make_star(5))
+  log <- character()
+
+  census <- lapply(graphs, function(g) {
+    withCallingHandlers(
+      triad_census(g),
+      warning = function(w) {
+        log <<- c(log, paste0(vcount(g), ": ", conditionMessage(w)))
+        invokeRestart("muffleWarning")
+      }
+    )
+  })
+
+  expect_length(log, 1)
+  expect_match(log, "^4: Triad census called on an undirected graph")
+  expect_identical(census, suppressWarnings(lapply(graphs, triad_census)))
+})
+
+test_that("a returned graph keeps its attributes when the handler collects garbage", {
+  g <- make_ring(5)
+  V(g)$name <- letters[1:5]
+  E(g)$weight <- 1:5
+
+  out <- withCallingHandlers(
+    connect(g, 1),
+    warning = function(w) {
+      for (i in 1:5) {
+        h <- make_ring(20)
+        V(h)$name <- as.character(1:20)
+      }
+      gc()
+      invokeRestart("muffleWarning")
+    }
+  )
+
+  expect_identical(V(out)$name, letters[1:5])
+  expect_identical(E(out)$weight, 1:5)
+})
+
+test_that("igraph stays usable after a warning handler jumps out", {
+  g <- make_ring(4)
+
+  expect_identical(
+    tryCatch(triad_census(g), warning = function(w) "caught"),
+    "caught"
+  )
+  expect_error(
+    withCallingHandlers(
+      triad_census(g),
+      warning = function(w) {
+        degree(g)
+        stop("from the handler")
+      }
+    ),
+    "from the handler"
+  )
+  expect_identical(degree(g), rep(2, 4))
+})
+
+test_that("C warnings keep their text, source and count", {
+  messages <- character()
+  withCallingHandlers(
+    triad_census(make_ring(4)),
+    warning = function(w) {
+      messages <<- c(messages, conditionMessage(w))
+      invokeRestart("muffleWarning")
+    }
+  )
+
+  expect_length(messages, 1)
+  expect_match(
+    messages,
+    "^Triad census called on an undirected graph\\. All connections will be treated as mutual\\.\nSource: misc/motifs\\.c:[0-9]+$"
+  )
+})
+
+test_that("C warnings name the R function that called into C", {
+  # Also when that function is not byte-compiled, as under load_all() or covr.
+  w <- tryCatch(triad_census(make_ring(4)), warning = identity)
+  expect_identical(conditionCall(w), quote(triad_census_impl(graph = graph)))
+})