R/import-standalone-defer.R

In tidyverse/rlang: Functions for Base Types and Core R and 'Tidyverse' Features

# Compatibility file: do not edit by hand
# Source: <https://github.com/r-lib/withr/blob/main/R/standalone-defer.R>
#
# ---
# repo: r-lib/withr
# source: standalone-defer.R
# last-updated: 2022-03-03
# license: https://unlicense.org
# ---
#
# This drop-in file implements withr::defer(). Please find the most
# recent version in withr's repository.
#
# ## Changelog:
#
# 2022-03-03
# * Support for `source()` and `knitr::knit()`
# * Handlers are now stored in environments instead of lists to avoid
#   infinite recursion issues.
# * The handler list is now soft-namespaced.

# nocov start

defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) { }

local({

defer <<- defer <- function(expr, envir = parent.frame(), priority = c("first", "last")) {
  priority <- match.arg(priority)
  invisible(
    add_handler(
      envir,
      handler = new_handler(substitute(expr), parent.frame()),
      front = priority == "first"
    )
  )
}

new_handler <- function(expr, envir) {
  hnd <- new.env(FALSE, size = 2)
  hnd[["expr"]] <- expr
  hnd[["envir"]] <- envir
  hnd
}

add_handler <- function(envir,
                        handler,
                        front,
                        frames = as.list(sys.frames()),
                        calls = as.list(sys.calls())) {
  envir <- exit_frame(envir, frames, calls)

  if (front) {
    handlers <- c(list(handler), get_handlers(envir))
  } else {
    handlers <- c(get_handlers(envir), list(handler))
  }

  set_handlers(envir, handlers, frames = frames, calls = calls)
  handler
}

set_handlers <- function(envir, handlers, frames, calls) {
  if (is.null(get_handlers(envir))) {
    # Ensure that list of handlers called when environment "ends"
    setup_handlers(envir)
  }

  attr(envir, "withr_handlers") <- handlers
}

# Evaluate `frames` lazily
setup_handlers <- function(envir,
                           frames = as.list(sys.frames()),
                           calls = as.list(sys.calls())) {
  if (is_top_level_global_env(envir, frames)) {
    # For session scopes we use reg.finalizer()
    if (is_interactive()) {
      message(
        sprintf("Setting global deferred event(s).\n"),
        "i These will be run:\n",
        "  * Automatically, when the R session ends.\n",
        "  * On demand, if you call `withr::deferred_run()`.\n",
        "i Use `withr::deferred_clear()` to clear them without executing."
      )
    }
    reg.finalizer(envir, function(env) deferred_run(env), onexit = TRUE)
  } else {
    # for everything else we use on.exit()

    call <- make_call(execute_handlers, envir)
    # We have to use do.call here instead of eval because of the way on.exit
    # determines its evaluation context
    # (https://stat.ethz.ch/pipermail/r-devel/2013-November/067867.html)

    do.call(base::on.exit, list(call, TRUE), envir = envir)
  }
}

exit_frame <- function(envir,
                       frames = as.list(sys.frames()),
                       calls = as.list(sys.calls())) {
  frame_loc <- frame_loc(envir, frames)
  if (!frame_loc) {
    return(envir)
  }

  if (in_knitr(envir)) {
    out <- knitr_frame(envir, frames, calls, frame_loc)
    if (!is.null(out)) {
      return(out)
    }
  }

  out <- source_frame(envir, frames, calls, frame_loc)
  if (!is.null(out)) {
    return(out)
  }

  envir
}

knitr_frame <- function(envir, frames, calls, frame_loc) {
  knitr_ns <- asNamespace("knitr")

  # This doesn't handle correctly the recursive case (knitr called
  # within a chunk). Handling this would be a little fiddly for an
  # uncommon edge case.
  for (i in seq(1, frame_loc)) {
    if (identical(topenv(frames[[i]]), knitr_ns)) {
      return(frames[[i]])
    }
  }

  NULL
}

source_frame <- function(envir, frames, calls, frame_loc) {
  i <- frame_loc

  if (i < 4) {
    return(NULL)
  }

  is_call <- function(x, fn) {
    is.call(x) && identical(x[[1]], fn)
  }
  calls <- as.list(calls)

  if (!is_call(calls[[i - 3]], quote(source))) {
    return(NULL)
  }
  if (!is_call(calls[[i - 2]], quote(withVisible))) {
    return(NULL)
  }
  if (!is_call(calls[[i - 1]], quote(eval))) {
    return(NULL)
  }
  if (!is_call(calls[[i - 0]], quote(eval))) {
    return(NULL)
  }

  frames[[i - 3]]
}

frame_loc <- function(envir, frames) {
  n <- length(frames)
  if (!n) {
    return(0)
  }

  for (i in seq_along(frames)) {
    if (identical(frames[[n - i + 1]], envir)) {
      return(n - i + 1)
    }
  }

  0
}

in_knitr <- function(envir) {
  knitr_in_progress() && identical(knitr::knit_global(), envir)
}

is_top_level_global_env <- function(envir, frames) {
  if (!identical(envir, globalenv())) {
    return(FALSE)
  }

  # Check if another global environment is on the stack
  !any(vapply(frames, identical, NA, globalenv()))
}

get_handlers <- function(envir) {
  attr(envir, "withr_handlers")
}

execute_handlers <- function(envir) {
  handlers <- get_handlers(envir)
  errors <- list()
  for (handler in handlers) {
    tryCatch(eval(handler$expr, handler$envir),
      error = function(e) {
        errors[[length(errors) + 1]] <<- e
      }
    )
  }
  attr(envir, "withr_handlers") <- NULL

  for (error in errors) {
    stop(error)
  }
}

make_call <- function(...) {
  as.call(list(...))
}

# base implementation of rlang::is_interactive()
is_interactive <- function() {
  opt <- getOption("rlang_interactive")
  if (!is.null(opt)) {
    return(opt)
  }
  if (knitr_in_progress()) {
    return(FALSE)
  }
  if (identical(Sys.getenv("TESTTHAT"), "true")) {
    return(FALSE)
  }
  interactive()
}

knitr_in_progress <- function() {
  isTRUE(getOption("knitr.in.progress"))
}

}) # defer() namespace

# nocov end