diff --git a/src/rinterface_extra.c b/src/rinterface_extra.c index 824afd4b40c..87f7d6744e0 100644 --- a/src/rinterface_extra.c +++ b/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 */ diff --git a/tests/testthat/test-warning-reentrancy.R b/tests/testthat/test-warning-reentrancy.R new file mode 100644 index 00000000000..b71afcfc150 --- /dev/null +++ b/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))) +})