Allow user-supplied calling handlers

These handlers are registered in the innermost evaluate context. They
are thus guaranteed to be called even within a try().

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: evaluate
 Type: Package
 Title: Parsing and Evaluation Tools that Provide More Details than the Default
-Version: 0.11.1
+Version: 0.11.1.9000
 Authors@R: c(
     person("Hadley", "Wickham", role = "aut"),
     person("Yihui", "Xie", role = c("aut", "cre"), email = "xie@yihui.name", comment = c(ORCID = "0000-0003-0645-5666")),

R/eval.r

@@ -183,11 +183,13 @@ evaluate_call <- function(call, src = NULL,
     for (i in seq_along(funs_names)) assign(funs_names[i], funs[[i]], envir)
   }
 
+  calling_handlers <- output_handler$calling_handlers
+
   multi_args <- length(formals(value_handler)) > 1
   for (expr in call) {
     srcindex <- length(output)
     time <- timing_fn(handle(ev <- withCallingHandlers(
-      withVisible(eval(expr, envir, enclos)),
+      withVisible(eval_with_user_handlers(expr, envir, enclos, calling_handlers)),
       warning = wHandler, error = eHandler, message = mHandler)))
     handle_output(TRUE)
     if (!is.null(time))
@@ -215,6 +217,24 @@ evaluate_call <- function(call, src = NULL,
   output
 }
 
+eval_with_user_handlers <- function(expr, envir, enclos, calling_handlers) {
+  if (!length(calling_handlers)) {
+    return(eval(expr, envir, enclos))
+  }
+
+  if (!is.list(calling_handlers)) {
+    stop("`calling_handlers` must be a list", call. = FALSE)
+  }
+
+  call <- as.call(c(
+    quote(withCallingHandlers),
+    quote(eval(expr, envir, enclos)),
+    calling_handlers
+  ))
+
+  eval(call)
+}
+
 #' Inject functions into the environment of \code{evaluate()}
 #'
 #' Create functions in the environment specified in the \code{envir} argument of

R/output.r

@@ -54,13 +54,18 @@ render <- function(x) if (isS4(x)) methods::show(x) else print(x)
 #' @param value Function to handle the values returned from evaluation. If it
 #'   only has one argument, only visible values are handled; if it has more
 #'   arguments, the second argument indicates whether the value is visible.
+#' @param calling_handlers List of calling handlers installed in the
+#'   innermost context. In particular, these handlers have precedence
+#'   over the exiting handler installed by \code{\link{evaluate}()}
+#'   when \code{stop_on_error} is set to 0.
 #' @return A new \code{output_handler} object
 #' @aliases output_handler
 #' @export
 new_output_handler <- function(source = identity,
                                text = identity, graphics = identity,
                                message = identity, warning = identity,
-                               error = identity, value = render) {
+                               error = identity, value = render,
+                               calling_handlers = list()) {
   source <- match.fun(source)
   stopifnot(length(formals(source)) >= 1)
   text <- match.fun(text)
@@ -78,7 +83,7 @@ new_output_handler <- function(source = identity,
 
   structure(list(source = source, text = text, graphics = graphics,
                  message = message, warning = warning, error = error,
-                 value = value),
+                 value = value, calling_handlers = calling_handlers),
             class = "output_handler")
 }
 

tests/testthat/test-evaluate.r

@@ -96,3 +96,18 @@ test_that("multiple lines of comments do not lose the terminating \\n", {
   ev <- evaluate("# foo\n#bar")
   expect_equal(ev[[1]][["src"]], "# foo\n")
 })
+
+test_that("user can register calling handlers", {
+  cnd <- structure(list(), class = c("foobar", "condition"))
+  hnd <- function(cnd) handled <<- cnd
+
+  handled <- NULL
+  out_hnd <- new_output_handler(calling_handlers = list(foobar = hnd))
+  evaluate("signalCondition(cnd)", output_handler = out_hnd)
+  expect_is(handled, "foobar")
+
+  handled <- NULL
+  out_hnd <- new_output_handler(calling_handlers = list(error = hnd))
+  evaluate("stop('tilt')", stop_on_error = 0, output_handler = out_hnd)
+  expect_is(handled, "error")
+})