fix: let a callback call igraph again

src/rcallback.c

@@ -60,7 +60,7 @@ igraph_error_t R_igraph_motifs_handler(const igraph_t *graph,
 
   /* Call the R function: callback(vids, isoclass) */
   PROTECT(R_fcall = Rf_lang3(callback, vids_r, isoclass_r));
-  PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv));
+  PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv));
 
   /* Check if result is an error condition (from tryCatch) */
   if (Rf_inherits(result, "error")) {
@@ -110,7 +110,7 @@ igraph_error_t R_igraph_clique_handler(const igraph_vector_int_t *clique, void *
 
   /* Call the R function: callback(clique) */
   PROTECT(R_fcall = Rf_lang2(callback, clique_r));
-  PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv));
+  PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv));
 
   /* Check if result is an error condition (from tryCatch) */
   if (Rf_inherits(result, "error")) {
@@ -182,7 +182,7 @@ igraph_error_t R_igraph_cycle_handler(
 
   /* Call the R function: callback(vertices, edges) */
   PROTECT(R_fcall = Rf_lang3(callback, vertices_r, edges_r));
-  PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv));
+  PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv));
 
   /* Check if result is an error condition (from tryCatch) */
   if (Rf_inherits(result, "error")) {
@@ -242,7 +242,7 @@ igraph_error_t R_igraph_isomorphism_handler(
 
   /* Call the R function: callback(map12, map21) */
   PROTECT(R_fcall = Rf_lang3(callback, map12_r, map21_r));
-  PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv));
+  PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv));
 
   /* Check if result is an error condition (from tryCatch) */
   if (Rf_inherits(result, "error")) {
@@ -336,7 +336,7 @@ igraph_error_t R_igraph_bfs_handler(
 
   /* Call the R callback with the converted data */
   PROTECT(R_fcall = Rf_lang2(callback, args));
-  PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv));
+  PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv));
 
   /* Check if result is an error or interrupt condition */
   if (Rf_inherits(result, "error")) {
@@ -415,7 +415,7 @@ igraph_error_t R_igraph_dfs_handler_in(
 
   /* Call the R callback */
   PROTECT(R_fcall = Rf_lang2(callback, args));
-  PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv));
+  PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv));
 
   /* Check if result is an error or interrupt condition */
   if (Rf_inherits(result, "error")) {
@@ -464,7 +464,7 @@ igraph_error_t R_igraph_dfs_handler_out(
 
   /* Call the R callback */
   PROTECT(R_fcall = Rf_lang2(callback, args));
-  PROTECT(result = Rf_eval(R_fcall, R_GlobalEnv));
+  PROTECT(result = Rx_igraph_eval_callback(R_fcall, R_GlobalEnv));
 
   /* Check if result is an error or interrupt condition */
   if (Rf_inherits(result, "error")) {
@@ -574,11 +574,11 @@ igraph_error_t R_igraph_levc_handler(
   PROTECT(l2 = R_MakeExternalPtr((void*)&cont, R_NilValue, R_NilValue));
   PROTECT(l3 = R_MakeExternalPtr(arpack_extra, R_NilValue, R_NilValue));
   PROTECT(R_multip_call = Rf_lang3(l1, l2, l3));
-  PROTECT(s_multip = Rf_eval(R_multip_call, data->env_arp));
+  PROTECT(s_multip = Rx_igraph_eval_callback(R_multip_call, data->env_arp));
 
   /* Build the call: callback(membership, community, value, vector, multiplier, extra) */
   PROTECT(R_fcall = Rx_igraph_i_lang7(callback, s_memb, s_comm, s_evalue, s_evector, s_multip, data->extra));
-  PROTECT(res = Rf_eval(R_fcall, data->env));
+  PROTECT(res = Rx_igraph_eval_callback(R_fcall, data->env));
 
   /* Check if result is an error condition (from tryCatch) */
   if (Rf_inherits(res, "error")) {

src/rinterface.h

@@ -43,6 +43,8 @@ SEXP Rx_igraph_add_env(SEXP graph);
 
 void Rx_igraph_attribute_clean_preserve_list(void);
 void Rx_igraph_set_in_r_check(bool set);
+bool Rx_igraph_callback_running(void);
+SEXP Rx_igraph_eval_callback(SEXP call, SEXP rho);
 void Rx_igraph_error(void);
 void Rx_igraph_warning(void);
 void Rx_igraph_interrupt(void);

src/rinterface_extra.c

@@ -299,7 +299,7 @@ SEXP Rx_igraph_safe_eval_in_env(SEXP expr_call, SEXP rho, Rx_igraph_safe_eval_re
   SET_TAG(CDDR(CDR(try_catch_call)), Rf_install("interrupt"));
 
   /* execute the call */
-  SEXP retval = PROTECT(Rf_eval(try_catch_call, rho));
+  SEXP retval = PROTECT(Rx_igraph_eval_callback(try_catch_call, rho));
 
   /* did we get an error or an interrupt? */
   if (result) {
@@ -2371,6 +2371,60 @@ void Rx_igraph_set_in_r_check(bool set) {
   Rx_igraph_in_r_check = set;
 }
 
+/* How many R callbacks a running algorithm is waiting on.
+ *
+ * R code that igraph reaches from inside an algorithm -- a search callback, an
+ * attribute combination function, an ARPACK multiplication -- can find its way
+ * back into igraph without meaning to: `length()` on a graph calls `vcount()`,
+ * and lifecycle gets there through `rlang::trace_back()` while it assembles a
+ * backtrace for a deprecation warning. While that is going on the "finally"
+ * stack belongs to the algorithm that is still running, and the nested call
+ * must not unwind it (see R_igraph_finalizer()). */
+static int Rx_igraph_running_callbacks = 0;
+
+/* HELPER: internal C; must use IGRAPH_CHECK */
+bool Rx_igraph_callback_running(void) {
+  return Rx_igraph_running_callbacks > 0;
+}
+
+typedef struct Rx_igraph_i_callback_t {
+  SEXP call;
+  SEXP rho;
+} Rx_igraph_i_callback_t;
+
+/* HELPER: internal C; must use IGRAPH_CHECK */
+static SEXP Rx_igraph_i_eval_callback(void *data) {
+  Rx_igraph_i_callback_t *callback = data;
+  return Rf_eval(callback->call, callback->rho);
+}
+
+/* HELPER: internal C; must use IGRAPH_CHECK */
+static void Rx_igraph_i_left_callback(void *data, Rboolean jump) {
+  (void) data;
+  (void) jump;
+  Rx_igraph_running_callbacks--;
+}
+
+/* HELPER: internal C; must use IGRAPH_CHECK */
+SEXP Rx_igraph_eval_callback(SEXP call, SEXP rho) {
+  Rx_igraph_i_callback_t callback = { call, rho };
+  SEXP continuation = PROTECT(R_MakeUnwindCont());
+  SEXP result;
+
+  Rx_igraph_running_callbacks++;
+  /* R_UnwindProtect() rather than a plain decrement afterwards: a callback
+   * that raises an error unwinds past us, and a count left standing would
+   * silence R_igraph_finalizer() for the rest of the session. */
+  result = R_UnwindProtect(
+    Rx_igraph_i_eval_callback, &callback,
+    Rx_igraph_i_left_callback, NULL,
+    continuation
+  );
+
+  UNPROTECT(1);
+  return result;
+}
+
 /* HELPER: internal C; must use IGRAPH_CHECK */
 void Rx_igraph_error(void) {
   Rx_igraph_errors_count = 0;
@@ -2648,6 +2702,17 @@ SEXP Rx_igraph_set_verbose(SEXP verbose) {
 
 /* TOP-LEVEL: called from R via .Call; must use IGRAPH_R_CHECK */
 SEXP R_igraph_finalizer(void) {
+  /* Every igraph function calls this on exit, to clean up after an algorithm
+   * that was left half-way. One reached from a callback is not that case: the
+   * "finally" stack then holds the structures of the algorithm that is still
+   * running, and freeing them leaves it working on destroyed memory -- the
+   * algorithm carries on and trips over an assertion, or takes R down with it.
+   * The algorithm cleans up after itself when it finishes, and the error path
+   * of the callback frees the stack before it aborts. */
+  if (Rx_igraph_callback_running()) {
+    return R_NilValue;
+  }
+
   IGRAPH_FINALLY_FREE();
   int px = 0;
   SEXP rho;
@@ -6070,7 +6135,7 @@ igraph_error_t Rx_igraph_i_arpack_callback(igraph_real_t *to, const igraph_real_
   memcpy(REAL(s_from), from, sizeof(igraph_real_t) * (size_t) n);
 
   PROTECT(R_fcall = Rf_lang3(data->fun, s_from, data->extra));
-  PROTECT(s_to = Rf_eval(R_fcall, data->rho));
+  PROTECT(s_to = Rx_igraph_eval_callback(R_fcall, data->rho));
   memcpy(to, REAL(s_to), sizeof(igraph_real_t) * (size_t) n);
 
   UNPROTECT(3);

tests/testthat/_snaps/nested-igraph-calls.md

@@ -0,0 +1,15 @@
+# a callback may signal a deprecation
+
+    Code
+      order <- bfs(g, root = 1, callback = function(...) {
+        is.igraph(g)
+        FALSE
+      })$order
+    Condition
+      Warning:
+      `is.igraph()` was deprecated in igraph 2.0.0.
+      i Please use `is_igraph()` instead.
+      Warning:
+      `is.igraph()` was deprecated in igraph 2.0.0.
+      i Please use `is_igraph()` instead.
+

tests/testthat/test-nested-igraph-calls.R

@@ -0,0 +1,124 @@
+# Reaching igraph again from inside a callback is easy to do without meaning
+# to: `length()` on a graph calls `vcount()`, and lifecycle gets there through
+# `rlang::trace_back()` while it assembles a backtrace for a deprecation
+# warning. Every one of these used to leave the running algorithm working on
+# structures that the nested call had freed, which ended in an igraph assertion
+# or took R down with it.
+
+# The smallest nested igraph call there is. Callbacks continue on FALSE.
+call_igraph_again <- function(...) {
+  vcount(make_ring(3))
+  FALSE
+}
+
+test_that("a search callback may call igraph again", {
+  g <- make_ring(5, directed = TRUE)
+
+  expect_no_error(bfs(g, root = 1, callback = call_igraph_again))
+  expect_no_error(dfs(g, root = 1, in.callback = call_igraph_again))
+  expect_no_error(dfs(g, root = 1, out.callback = call_igraph_again))
+})
+
+test_that("a clique callback may call igraph again", {
+  g <- make_full_graph(4)
+
+  expect_no_error(cliques(g, min = 2, callback = call_igraph_again))
+  expect_no_error(max_cliques(g, min = 2, callback = call_igraph_again))
+})
+
+test_that("a motif callback may call igraph again", {
+  g <- make_ring(5, directed = TRUE)
+
+  expect_no_error(motifs(g, 3, callback = call_igraph_again))
+})
+
+test_that("a cycle callback may call igraph again", {
+  g <- make_ring(5, directed = TRUE)
+
+  expect_no_error(simple_cycles(g, callback = call_igraph_again))
+})
+
+test_that("an isomorphism callback may call igraph again", {
+  g <- make_ring(5, directed = TRUE)
+  h <- make_ring(5, directed = TRUE)
+
+  expect_no_error(isomorphisms(g, h, callback = call_igraph_again))
+  expect_no_error(
+    subgraph_isomorphisms(g, h, method = "vf2", callback = call_igraph_again)
+  )
+})
+
+test_that("a community callback may call igraph again", {
+  g <- make_graph("Zachary")
+
+  expect_no_error(cluster_leading_eigen(g, callback = call_igraph_again))
+})
+
+test_that("an ARPACK multiplication may call igraph again", {
+  multiply <- function(x, extra) {
+    vcount(make_ring(3))
+    x
+  }
+
+  expect_no_error(arpack(
+    multiply,
+    options = list(n = 5, nev = 1, ncv = 3, which = "LM"),
+    sym = TRUE
+  ))
+})
+
+test_that("an attribute combination function may call igraph again", {
+  combine <- function(x) {
+    vcount(make_ring(3))
+    sum(x)
+  }
+
+  g <- make_graph(c(1, 2, 1, 2))
+  E(g)$weight <- c(1, 2)
+  expect_no_error(simplify(g, edge.attr.comb = list(weight = combine)))
+
+  h <- make_ring(5)
+  V(h)$size <- 1:5
+  expect_no_error(
+    contract(h, c(1, 1, 2, 2, 3), vertex.attr.comb = list(size = combine))
+  )
+})
+
+test_that("a callback may signal a deprecation", {
+  # The motivating case: lifecycle reaches `vcount()` through the backtrace it
+  # assembles, so a deprecated function used as a callback took igraph down.
+  # Two vertices keep the snapshot short: the callback runs for each of them,
+  # and the "warning" verbosity a snapshot needs turns off the deduplication
+  # that leaves a user with one warning.
+  g <- make_ring(2, directed = TRUE)
+  rlang::local_options(lifecycle_verbosity = "warning")
+
+  expect_snapshot({
+    order <- bfs(g, root = 1, callback = function(...) {
+      is.igraph(g)
+      FALSE
+    })$order
+  })
+})
+
+test_that("a callback may look at the graph it is given (#253)", {
+  g <- set_vertex_attr(make_tree(10), "xx", value = 10:19)
+  callback <- function(graph, data, extra) {
+    V(graph)[data[["vid"]]]$xx
+    format(graph)
+    FALSE
+  }
+
+  expect_no_error(bfs(g, root = 1, mode = "out", callback = callback))
+})
+
+test_that("an error in a callback still reaches the caller", {
+  # The nested call must not swallow the abort path along with the unwinding.
+  g <- make_ring(5, directed = TRUE)
+  callback <- function(...) {
+    vcount(make_ring(3))
+    cli::cli_abort("from the callback")
+  }
+
+  expect_error(bfs(g, root = 1, callback = callback), "from the callback")
+})

tests/testthat/test-structural-properties.R

@@ -211,8 +211,6 @@ test_that("BFS callback does not blow up when an error is raised within the call
 })
 
 test_that("BFS callback does not blow up when another igraph function is raised within the callback", {
-  skip("nested igraph call handling not implemented yet")
-
   callback <- function(graph, data, extra) {
     neighbors(graph, 1)
     FALSE