Merge commit '9c93b8f0be372cfd495d87fa18e5854b04c45ea8'

Author: hadley

NAMESPACE

@@ -156,6 +156,7 @@ export(it)
 export(local_edition)
 export(local_mock)
 export(local_mocked_bindings)
+export(local_on_cran)
 export(local_reproducible_output)
 export(local_snapshotter)
 export(local_test_context)

NEWS.md

@@ -1,5 +1,7 @@
 # testthat (development version)
 
+* New `local_on_cran(TRUE)` allows you to simulate how your tests will run on CRAN (#2112).
+* `expect_no_*()` now executes the entire code block, rather than stopping at the first message or warning (#1991).
 * `expect_no_failures()` and `expect_no_successes()` are now deprecated as `expect_success()` now test for no failures and `expect_failure()` tests for no successes (#)
 * New `pass()` function to use in place of `succeed()` (#2113).
 * `expectation()` is now a combination of `new_expectation()` and `exp_signal()` (#2125).

R/deprec-condition.R

@@ -101,7 +101,7 @@ capture_messages <- function(code) {
     code,
     message = function(condition) {
       out$push(condition)
-      maybe_restart("muffleMessage")
+      tryInvokeRestart("muffleMessage")
     }
   )
 
@@ -121,7 +121,7 @@ capture_warnings <- function(code, ignore_deprecation = FALSE) {
       }
 
       out$push(condition)
-      maybe_restart("muffleWarning")
+      tryInvokeRestart("muffleWarning")
     }
   )
 

R/evaluate-promise.R

@@ -20,14 +20,14 @@ evaluate_promise <- function(code, print = FALSE) {
   handle_warning <- function(condition) {
     if (!is_deprecation(condition)) {
       warnings$push(condition)
-      maybe_restart("muffleWarning")
+      tryInvokeRestart("muffleWarning")
     }
   }
 
   messages <- Stack$new()
   handle_message <- function(condition) {
     messages$push(condition)
-    maybe_restart("muffleMessage")
+    tryInvokeRestart("muffleMessage")
   }
 
   path <- withr::local_tempfile()

R/example.R renamed to R/examples.R

@@ -19,7 +19,12 @@
 #' @name comparison-expectations
 NULL
 
-expect_compare <- function(operator = c("<", "<=", ">", ">="), act, exp) {
+expect_compare_ <- function(
+  operator = c("<", "<=", ">", ">="),
+  act,
+  exp,
+  trace_env = caller_env()
+) {
   operator <- match.arg(operator)
   op <- match.fun(operator)
 
@@ -42,7 +47,7 @@ expect_compare <- function(operator = c("<", "<=", ">", ">="), act, exp) {
       exp$lab,
       act$val - exp$val
     )
-    return(fail(msg, trace_env = caller_env()))
+    return(fail(msg, trace_env = trace_env))
   }
   pass(act$val)
 }
@@ -52,7 +57,7 @@ expect_lt <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare("<", act, exp)
+  expect_compare_("<", act, exp)
 }
 
 #' @export
@@ -61,7 +66,7 @@ expect_lte <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare("<=", act, exp)
+  expect_compare_("<=", act, exp)
 }
 
 #' @export
@@ -70,7 +75,7 @@ expect_gt <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare(">", act, exp)
+  expect_compare_(">", act, exp)
 }
 
 #' @export
@@ -79,7 +84,7 @@ expect_gte <- function(object, expected, label = NULL, expected.label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
-  expect_compare(">=", act, exp)
+  expect_compare_(">=", act, exp)
 }
 
 

R/expect-comparison.R

@@ -115,7 +115,7 @@ expect_error <- function(
   label = NULL
 ) {
   if (edition_get() >= 3) {
-    expect_condition_matching(
+    expect_condition_matching_(
       "error",
       {{ object }},
       regexp = regexp,
@@ -163,7 +163,7 @@ expect_warning <- function(
       warn("The `all` argument is deprecated")
     }
 
-    expect_condition_matching(
+    expect_condition_matching_(
       "warning",
       {{ object }},
       regexp = regexp,
@@ -208,7 +208,7 @@ expect_message <- function(
   label = NULL
 ) {
   if (edition_get() >= 3) {
-    expect_condition_matching(
+    expect_condition_matching_(
       "message",
       {{ object }},
       regexp = regexp,
@@ -240,7 +240,7 @@ expect_condition <- function(
   label = NULL
 ) {
   if (edition_get() >= 3) {
-    expect_condition_matching(
+    expect_condition_matching_(
       "condition",
       {{ object }},
       regexp = regexp,
@@ -273,7 +273,7 @@ expect_condition <- function(
   }
 }
 
-expect_condition_matching <- function(
+expect_condition_matching_ <- function(
   base_class,
   object,
   regexp = NULL,
@@ -309,7 +309,12 @@ expect_condition_matching <- function(
   # Access error fields with `[[` rather than `$` because the
   # `$.Throwable` from the rJava package throws with unknown fields
   if (!is.null(msg)) {
-    return(fail(msg, info = info, trace = act$cap[["trace"]], trace_env = trace_env))
+    return(fail(
+      msg,
+      info = info,
+      trace = act$cap[["trace"]],
+      trace_env = trace_env
+    ))
   }
   # If a condition was expected, return it. Otherwise return the value
   # of the expression.
@@ -346,7 +351,7 @@ cnd_matcher <- function(
       if (!is.null(class) && !inherits(x, class)) {
         return(FALSE)
       }
-      if (!is.null(regexp) && !isNA(regexp)) {
+      if (!is.null(regexp) && !identical(regexp, NA)) {
         withCallingHandlers(
           grepl(regexp, conditionMessage(x), ...),
           error = function(e) {

R/expect-condition.R

@@ -30,14 +30,14 @@ NULL
 #' @rdname logical-expectations
 expect_true <- function(object, info = NULL, label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
-  expect_waldo_constant(act, TRUE, info = info, ignore_attr = TRUE)
+  expect_waldo_constant_(act, TRUE, info = info, ignore_attr = TRUE)
 }
 
 #' @export
 #' @rdname logical-expectations
 expect_false <- function(object, info = NULL, label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
-  expect_waldo_constant(act, FALSE, info = info, ignore_attr = TRUE)
+  expect_waldo_constant_(act, FALSE, info = info, ignore_attr = TRUE)
 }
 
 #' Does code return `NULL`?
@@ -56,12 +56,18 @@ expect_false <- function(object, info = NULL, label = NULL) {
 #' show_failure(expect_null(y))
 expect_null <- function(object, info = NULL, label = NULL) {
   act <- quasi_label(enquo(object), label, arg = "object")
-  expect_waldo_constant(act, NULL, info = info)
+  expect_waldo_constant_(act, NULL, info = info)
 }
 
 # helpers -----------------------------------------------------------------
 
-expect_waldo_constant <- function(act, constant, info, ...) {
+expect_waldo_constant_ <- function(
+  act,
+  constant,
+  info,
+  ...,
+  trace_env = caller_env()
+) {
   comp <- waldo_compare(
     act$val,
     constant,
@@ -77,7 +83,7 @@ expect_waldo_constant <- function(act, constant, info, ...) {
       deparse(constant),
       paste0(comp, collapse = "\n\n")
     )
-    return(fail(msg, info = info, trace_env = caller_env()))
+    return(fail(msg, info = info, trace_env = trace_env))
   }
 
   pass(act$val)

R/expect-constant.R

@@ -67,7 +67,7 @@ expect_equal <- function(
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
   if (edition_get() >= 3) {
-    expect_waldo_equal("equal", act, exp, info, ..., tolerance = tolerance)
+    expect_waldo_equal_("equal", act, exp, info, ..., tolerance = tolerance)
   } else {
     if (!is.null(tolerance)) {
       comp <- compare(act$val, exp$val, ..., tolerance = tolerance)
@@ -97,7 +97,7 @@ expect_identical <- function(
   exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
 
   if (edition_get() >= 3) {
-    expect_waldo_equal("identical", act, exp, info, ...)
+    expect_waldo_equal_("identical", act, exp, info, ...)
   } else {
     ident <- identical(act$val, exp$val, ...)
     if (ident) {
@@ -119,7 +119,14 @@ expect_identical <- function(
   }
 }
 
-expect_waldo_equal <- function(type, act, exp, info, ...) {
+expect_waldo_equal_ <- function(
+  type,
+  act,
+  exp,
+  info,
+  ...,
+  trace_env = caller_env()
+) {
   comp <- waldo_compare(
     act$val,
     exp$val,
@@ -137,7 +144,7 @@ expect_waldo_equal <- function(type, act, exp, info, ...) {
       "`expected`",
       paste0(comp, collapse = "\n\n")
     )
-    return(fail(msg, info = info, trace_env = caller_env()))
+    return(fail(msg, info = info, trace_env = trace_env))
   }
   pass(act$val)
 }
@@ -194,42 +201,3 @@ expect_equivalent <- function(
   }
   pass(act$val)
 }
-
-
-#' Does code return a reference to the expected object?
-#'
-#' `expect_reference()` compares the underlying memory addresses of
-#' two symbols. It is for expert use only.
-#'
-#' @section 3rd edition:
-#' `r lifecycle::badge("deprecated")`
-#'
-#' `expect_reference()` is deprecated in the third edition. If you know what
-#' you're doing, and you really need this behaviour, just use `is_reference()`
-#' directly: `expect_true(rlang::is_reference(x, y))`.
-#'
-#' @inheritParams expect_equal
-#' @family expectations
-#' @keywords internal
-#' @export
-expect_reference <- function(
-  object,
-  expected,
-  info = NULL,
-  label = NULL,
-  expected.label = NULL
-) {
-  edition_deprecate(3, "expect_reference()")
-
-  act <- quasi_label(enquo(object), label, arg = "object")
-  exp <- quasi_label(enquo(expected), expected.label, arg = "expected")
-
-  if (!is_reference(act$val, exp$val)) {
-    msg <- sprintf("%s not a reference to %s.", act$lab, exp$lab)
-    return(fail(msg, info = info))
-  }
-  pass(act$val)
-}
-
-# expect_reference() needs dev version of rlang
-utils::globalVariables("is_reference")

R/expect-equality.R

@@ -103,10 +103,17 @@ expect_match_ <- function(
   all = TRUE,
   info = NULL,
   label = NULL,
-  negate = FALSE
+  negate = FALSE,
+  trace_env = caller_env()
 ) {
   matches <- grepl(regexp, act$val, perl = perl, fixed = fixed, ...)
   condition <- if (negate) !matches else matches
+  ok <- if (all) all(condition) else any(condition)
+
+  if (ok) {
+    return(pass(act$val))
+  }
+
   escape <- if (fixed) identity else escape_regex
 
   if (length(act$val) == 1) {
@@ -117,14 +124,12 @@ expect_match_ <- function(
       paste0("* ", escape(encodeString(act$val)), collapse = "\n")
     )
   }
-  if (if (all) !all(condition) else !any(condition)) {
-    msg <- sprintf(
-      if (negate) "%s does match %s.\n%s" else "%s does not match %s.\n%s",
-      escape(act$lab),
-      encodeString(regexp, quote = '"'),
-      values
-    )
-    return(fail(msg, info = info, trace_env = caller_env()))
-  }
-  pass(act$val)
+
+  msg <- sprintf(
+    if (negate) "%s does match %s.\n%s" else "%s does not match %s.\n%s",
+    escape(act$lab),
+    encodeString(regexp, quote = '"'),
+    values
+  )
+  return(fail(msg, info = info, trace_env = trace_env))
 }