tests/testthat/helper-cnd.R

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

cnd_cat <- function(x) {
  cat(paste0(conditionMessage(x), "\n"))
}

expect_no_error <- function(...) {
  expect_error(regexp = NA, ...)
}
expect_no_error_ <- function(object, ...) {
  expect_error(object, regexp = NA, ...)
}
expect_no_warning <- function(...) {
  expect_warning(regexp = NA, ...)
}
expect_no_warning_ <- function(object, ...) {
  expect_warning(object, regexp = NA, ...)
}
expect_no_message <- function(...) {
  expect_message(regexp = NA, ...)
}
expect_no_message_ <- function(object, ...) {
  expect_message(object, regexp = NA, ...)
}

catch_wngs <- function(expr) {
  wngs <- list()

  withCallingHandlers(
    {
      expr
    },
    warning = function(wng) {
      wngs <<- c(wngs, list(wng))
      invokeRestart("muffleWarning")
    }
  )

  wngs
}
catch_warning_msgs <- function(expr) {
  wngs <- catch_wngs(expr)
  flatten_chr(pluck(wngs, "message"))
}

catch_cnds <- function(expr) {
  wngs <- list()
  msgs <- list()

  err <- tryCatch(
    withCallingHandlers(
      {
        force(expr)
        NULL
      },
      message = function(msg) {
        msgs <<- c(msgs, list(msg))
        invokeRestart("muffleMessage")
      },
      warning = function(wng) {
        wngs <<- c(wngs, list(wng))
        invokeRestart("muffleWarning")
      }
    ),
    error = identity
  )

  list(messages = msgs, warnings = wngs, error = err)
}

catch_conditions_msgs <- function(expr) {
  pluck_conditions_msgs(catch_cnds(expr))
}

pluck_conditions_msgs <- function(cnds) {
  cnds$messages <- flatten_chr(pluck(cnds$messages, "message"))
  cnds$warnings <- flatten_chr(pluck(cnds$warnings, "message"))
  cnds$error <- cnds$error$message
  cnds
}

skip_silently <- function(reason, env = caller_env()) {
  expect_true(TRUE)
  return_from(env)
}

expect_data_pronoun_error <- function(object, regexp = NULL, ...) {
  expect_error(
    object,
    regexp,
    ...,
    class = "rlang_error_data_pronoun_not_found"
  )
}

expect_defunct <- function(object, ...) {
  expect_error(object, class = "defunctError")
}

# Workaround for snapshot inconsistencies that started to appear between
# `test()` and `check()`. The helpers environment is now treated differently and
# causes backtrace snapshot failures.
with_base <- function(fn) {
  environment(fn) <- baseenv()
  fn
}

catch_error <- with_base(function(expr) {
  rlang::catch_cnd(expr, "error")
})
catch_warning <- with_base(function(expr) {
  rlang::catch_cnd(expr, "warning")
})
catch_message <- with_base(function(expr) {
  rlang::catch_cnd(expr, "message")
})

# https://github.com/r-lib/testthat/issues/1371
expect_warning2 <- catch_warning

err <- with_base(function(...) {
  (testthat::expect_error(...))
})

local_unexport_signal_abort <- function(frame = caller_env()) {
  local_bindings(
    .env = ns_env("rlang")[[".__NAMESPACE__."]][["exports"]],
    .frame = frame,
    signal_abort = zap()
  )
}

rst_exists <- function(.restart) {
  !is.null(findRestart(.restart))
}