R/hook.R

In r-lib/callr: Call R from R

common_hook <- function() {
  substitute(
    {
      # This should not happen in a new R session, but just to be safe
      while ("tools:callr" %in% search()) detach("tools:callr")
      env <- readRDS(`__envfile__`)
      do.call("attach", list(env, pos = length(search()), name = "tools:callr"))
      data <- env$`__callr_data__`
      data$pxlib <- data$load_client_lib(
        data$sofile[[paste0("arch-", .Platform$r_arch)]],
        data$pxdir
      )
      options(error = function() invokeRestart("abort"))
      rm(list = c("data", "env"))

      lapply(
        c(
          "R_ENVIRON",
          "R_ENVIRON_USER",
          "R_PROFILE",
          "R_PROFILE_USER",
          "R_LIBS",
          "R_LIBS_USER",
          "R_LIBS_SITE"
        ),
        function(var) {
          bakvar <- paste0("CALLR_", var, "_BAK")
          val <- Sys.getenv(bakvar, NA_character_)
          if (!is.na(val)) {
            do.call("Sys.setenv", structure(list(val), names = var))
          } else {
            Sys.unsetenv(var)
          }
          Sys.unsetenv(bakvar)
        }
      )

      Sys.unsetenv("CALLR_CHILD_R_LIBS")
      Sys.unsetenv("CALLR_CHILD_R_LIBS_SITE")
      Sys.unsetenv("CALLR_CHILD_R_LIBS_USER")
    },
    list("__envfile__" = env_file)
  )
}

default_load_hook <- function(user_hook = NULL) {
  prepare_client_files()
  hook <- common_hook()

  if (!is.null(user_hook)) {
    hook <- substitute(
      {
        d
        u
      },
      list(d = hook, u = user_hook)
    )
  }
  paste0(deparse(hook), "\n")
}

session_load_hook <- function(user_hook = NULL) {
  chook <- common_hook()
  ehook <- substitute({
    data <- as.environment("tools:callr")$`__callr_data__`
    data$pxlib$disable_fd_inheritance()
    rm(data)
  })

  hook <- substitute(
    {
      c
      e
    },
    list(c = chook, e = ehook)
  )

  if (!is.null(user_hook)) {
    hook <- substitute(
      {
        d
        u
      },
      list(d = hook, u = user_hook)
    )
  }

  hook <- substitute(
    {
      err_ <- TRUE
      callr_startup_hook <- function() {
        on.exit(if (err_) quit("no", 1, TRUE))
        {
          `_hook_`
        }
        err_ <<- FALSE
      }
      callr_startup_hook()
      rm(err_, callr_startup_hook)
    },
    list("_hook_" = hook)
  )

  paste0(deparse(hook), "\n")
}

user_hooks_env <- new.env(parent = emptyenv())

#' Add a user hook to be executed before launching an R subprocess
#'
#' This function allows users of `callr` to specify functions that get invoked
#' whenever an R session is launched. The function can modify the environment
#' variables and command line arguments.
#'
#' The prototype of the hook function is `function (options)`, and it is
#' expected to return the modified `options`.
#' @param ... Named argument specifying a hook function to add, or `NULL` to
#'   delete the named hook.
#' @return `add_hook` is called for its side-effects.
#' @export

add_hook <- function(...) {
  args <- list(...)
  if (length(args) != 1L) {
    stop("More than one argument passed to `add_hook`")
  }

  name <- names(args)
  if (is.null(name)) {
    stop("Argument passed to `add_hook` must be named")
  }

  hook <- args[[1]]
  if (is.null(hook)) {
    rm(list = name, envir = user_hooks_env)
  } else {
    assign(name, match.fun(hook), envir = user_hooks_env)
  }

  invisible()
}

call_user_hooks <- function(options) {
  for (name in names(user_hooks_env)) {
    hook <- user_hooks_env[[name]]
    options <- tryCatch(hook(options), error = function(e) options)
  }
  options
}