use rlang::abort throughout instead of stop; use check_installed inst…

…ead of custom fxn #129

NAMESPACE

@@ -63,6 +63,8 @@ importFrom(base64enc,base64encode)
 importFrom(crul,mock)
 importFrom(fauxpas,HTTPRequestTimeout)
 importFrom(magrittr,"%>%")
+importFrom(rlang,abort)
+importFrom(rlang,check_installed)
 importFrom(rlang,is_empty)
 importFrom(rlang,is_na)
 importFrom(rlang,is_null)

R/HttpLibAdapterRegistry.R

@@ -30,7 +30,7 @@ HttpLibAdapaterRegistry <- R6::R6Class(
     register = function(x) {
       # FIXME: when other adapters supported, change this inherits test
       if (!inherits(x, c("CrulAdapter", "HttrAdapter", "Httr2Adapter"))) {
-        stop("'x' must be an adapter, such as CrulAdapter", call. = FALSE)
+        abort("'x' must be an adapter, such as CrulAdapter")
       }
       self$adapters <- c(self$adapters, x)
     }

R/RequestPattern.R

@@ -94,7 +94,7 @@ RequestPattern <- R6::R6Class(
     initialize = function(method, uri = NULL, uri_regex = NULL,
                           query = NULL, body = NULL, headers = NULL) {
       if (is.null(uri) && is.null(uri_regex)) {
-        stop("one of uri or uri_regex is required", call. = FALSE)
+        abort("one of uri or uri_regex is required")
       }
 
       self$method_pattern <- MethodPattern$new(pattern = method)
@@ -173,10 +173,10 @@ RequestPattern <- R6::R6Class(
     },
     validate_basic_auth = function(x) {
       if (!inherits(x, "list") || length(unique(unname(unlist(x)))) == 1) {
-        stop(
-          "'basic_auth' option should be a list of length 2: username and password",
-          call. = FALSE
-        )
+        abort(c(
+          "error in basic auth",
+          "'basic_auth' option should be list of length 2: username, password"
+        ))
       }
     },
     make_basic_auth = function(x, y) {
@@ -500,7 +500,7 @@ BodyPattern <- R6::R6Class(
       if (bctype == "json") {
         jsonlite::fromJSON(body)
       } else if (bctype == "xml") {
-        check_for_pkg("xml2")
+        check_installed("xml2")
         try_xml2list <- rlang::try_fetch({
           body_xml <- xml2::read_xml(body)
           xml_as_list <- xml2::as_list(body_xml)

R/StubRegistry.R

@@ -88,12 +88,10 @@ StubRegistry <- R6::R6Class(
       if (stub$to_s() %in% xx) {
         self$request_stubs <- self$request_stubs[-which(stub$to_s() %in% xx)]
       } else {
-        stop(
-          "Request stub \n\n  ",
-          stub$to_s(),
-          "\n\n is not registered.",
-          call. = FALSE
-        )
+        abort(c(
+          "This request stub is not registered:",
+          stub$to_s()
+        ))
       }
     },
 

R/StubbedRequest.R

@@ -187,7 +187,7 @@ StubbedRequest <- R6::R6Class(
         self$method <- verb
       }
       if (is.null(uri) && is.null(uri_regex)) {
-        stop("one of uri or uri_regex is required", call. = FALSE)
+        abort("one of uri or uri_regex is required")
       }
       self$uri <- uri
       self$uri_regex <- uri_regex
@@ -281,7 +281,7 @@ StubbedRequest <- R6::R6Class(
         bod_sum <- summary(body)
         close.connection(body)
         if (bod_sum$class != "file") {
-          stop("'to_return' only supports connections of type 'file'")
+          abort("'to_return' only supports connections of type 'file'")
         }
         structure(bod_sum$description, type = "file")
       } else {
@@ -296,13 +296,10 @@ StubbedRequest <- R6::R6Class(
             raw()
           } else {
             webmockr_stub_registry$remove_request_stub(self)
-            stop(
-              paste0(
-                "Unknown type of `body`: ",
-                "must be NULL, FALSE, character, raw or list; stub removed"
-              ),
-              call. = FALSE
-            )
+            abort(c(
+              "Unknown `body` type",
+              "*" = "must be NULL, FALSE, character, raw or list; stub removed"
+            ))
           }
         } else if (inherits(body, "raw")) {
           body
@@ -317,14 +314,11 @@ StubbedRequest <- R6::R6Class(
           }
         } else if (!is.list(body)) {
           webmockr_stub_registry$remove_request_stub(self)
-          stop(
-            paste0(
-              "Unknown type of `body`: ",
-              "must be numeric, NULL, FALSE, character, json, ",
-              "raw, list, or file connection; stub removed"
-            ),
-            call. = FALSE
-          )
+          abort(c(
+            "Unknown `body` type",
+            "*" = "must be: numeric, NULL, FALSE, character, json, raw, list, or file connection",
+            "*" = "stub removed"
+          ))
         } else {
           charToRaw(jsonlite::toJSON(body, auto_unbox = TRUE))
         }

R/adapter-crul.R

@@ -99,8 +99,8 @@ CrulAdapter <- R6::R6Class("CrulAdapter",
 
       # if crul_resp$content is character, it must be a file path (I THINK?)
       if (is.null(write_disk_path)) {
-        stop("if writing to disk, write_disk_path must be given; ",
-             "see ?vcr::vcr_configure")
+        abort(c("if writing to disk, write_disk_path must be given",
+          "see ?vcr::vcr_configure"))
       }
 
       response$content <- file.path(

R/adapter-httr.R

@@ -65,7 +65,7 @@ httr_cookies_df <- function() {
 check_user_pwd <- function(x) {
   if (is.null(x)) return(x)
   if (grepl("^https?://", x)) {
-    stop(sprintf("expecting string of pattern 'user:pwd', got '%s'", x))
+    abort(c("expecting string of pattern 'user:pwd'", sprintf("got '%s'", x)))
   }
   return(x)
 }
@@ -105,7 +105,7 @@ build_httr_request = function(x) {
 #' to turn off. default: `TRUE`
 #' @return Silently returns `TRUE` when enabled and `FALSE` when disabled.
 httr_mock <- function(on = TRUE) {
-  check_for_pkg("httr")
+  check_installed("httr")
   webmockr_handle <- function(req) {
     webmockr::HttrAdapter$new()$handle_request(req)
   }

R/adapter-httr2.R

@@ -99,7 +99,7 @@ build_httr2_request = function(x) {
 #' @param on (logical) `TRUE` to turn on, `FALSE` to turn off. default: `TRUE`
 #' @return Silently returns `TRUE` when enabled and `FALSE` when disabled.
 httr2_mock <- function(on = TRUE) {
-  check_for_pkg("httr2")
+  check_installed("httr2")
   if (on) {
     httr2::local_mocked_responses(~ Httr2Adapter$new()$handle_request(.x), env = .GlobalEnv)
   } else {

R/adapter.R

@@ -55,14 +55,13 @@ Adapter <- R6::R6Class("Adapter",
     #' @description Create a new Adapter object
     initialize = function() {
       if (is.null(self$client)) {
-        stop(
-          "Adapter parent class should not be called directly.\n",
-          "Use one of the following package-specific adapters instead:\n",
-          "  - CrulAdapter$new()\n",
-          "  - HttrAdapter$new()\n",
-          "  - Httr2Adapter$new()\n",
-          call. = FALSE
-        )
+        abort(c(
+          "Adapter parent class should not be called directly",
+          "*" = "Use one of the following package-specific adapters instead:",
+          "*" = "  CrulAdapter$new()",
+          "*" = "  HttrAdapter$new()",
+          "*" = "  Httr2Adapter$new()"
+        ))
       }
     },
 
@@ -216,7 +215,7 @@ Adapter <- R6::R6Class("Adapter",
           msgz <- ""
         }
         ending <- "\n============================================================"
-        stop(paste0(msgx, msgy, msgz, ending), call. = FALSE)
+        abort(paste0(msgx, msgy, msgz, ending))
       }
 
       return(resp)

R/flipswitch.R

@@ -24,7 +24,7 @@ enable <- function(adapter = NULL, options = list(), quiet = FALSE) {
   adnms <- vapply(http_lib_adapter_registry$adapters, function(w) w$client, "")
   if (!is.null(adapter)) {
     if (!adapter %in% webmockr_adapters) {
-      stop("adapter must be one of 'crul', 'httr', or 'httr2'")
+      abort("adapter must be one of 'crul', 'httr', or 'httr2'")
     }
     if (!requireNamespace(adapter, quietly = TRUE)) {
       message(adapter, " not installed, skipping enable")
@@ -50,8 +50,8 @@ enable <- function(adapter = NULL, options = list(), quiet = FALSE) {
 #' @rdname enable
 enabled <- function(adapter = "crul") {
   if (!adapter %in% webmockr_adapters) {
-    stop("'adapter' must be in the set ", 
-      paste0(webmockr_adapters, collapse = ", "))
+    abort(c("'adapter' must be in the set ", 
+          paste0(webmockr_adapters, collapse = ", ")))
   }
   webmockr_lightswitch[[adapter]]
 }
@@ -62,7 +62,7 @@ disable <- function(adapter = NULL, options = list(), quiet = FALSE) {
   adnms <- vapply(http_lib_adapter_registry$adapters, function(w) w$client, "")
   if (!is.null(adapter)) {
     if (!adapter %in% webmockr_adapters) {
-      stop("adapter must be one of 'crul', 'httr', or 'httr2'")
+      abort("adapter must be one of 'crul', 'httr', or 'httr2'")
     }
     if (!requireNamespace(adapter, quietly = TRUE)) {
       message(adapter, " not installed, skipping disable")

R/pluck_body.R

@@ -34,9 +34,8 @@ pluck_body <- function(x) {
 
   # unknown, fail out
   } else {
-    stop("couldn't fetch request body; file an issue at \n",
-         "  https://github.com/ropensci/webmockr/issues/",
-         call. = FALSE)
+    abort("couldn't fetch request body; file an issue at \n",
+         "  https://github.com/ropensci/webmockr/issues/")
   }
 }
 

R/stub_request.R

@@ -191,7 +191,7 @@
 #' }
 stub_request <- function(method = "get", uri = NULL, uri_regex = NULL) {
   if (is.null(uri) && is.null(uri_regex)) {
-    stop("one of uri or uri_regex is required", call. = FALSE)
+    abort("one of uri or uri_regex is required")
   }
   tmp <- StubbedRequest$new(method = method, uri = uri, uri_regex = uri_regex)
   webmockr_stub_registry$register_stub(tmp)

R/to_raise.R

@@ -17,7 +17,7 @@
 #' in this case `to_raise()` makes sense. In another case, if a unit test
 #' expects to test some aspect of an HTTP response object that httr, httr2,
 #' or crul typically returns, then you'll want `to_return()`.
-#' 
+#'
 #' @details The behavior in the future will be:
 #'
 #' When multiple exceptions are passed, the first is used on the first
@@ -29,12 +29,14 @@
 to_raise <- function(.data, ...) {
   assert(.data, "StubbedRequest")
   tmp <- list(...)
-  if (!all(vapply(tmp, function(x) inherits(x, "R6ClassGenerator"),
-    logical(1)))) {
-    stop("all objects must be error classes from fauxpas")
+  if (!all(vapply(
+    tmp, function(x) inherits(x, "R6ClassGenerator"),
+    logical(1)
+  ))) {
+    abort("all objects must be error classes from fauxpas")
   }
   if (!all(vapply(tmp, function(x) grepl("HTTP", x$classname), logical(1)))) {
-    stop("all objects must be error classes from fauxpas")
+    abort("all objects must be error classes from fauxpas")
   }
   .data$to_raise(tmp)
   return(.data)

R/to_return.R

@@ -83,11 +83,11 @@ to_return <- function(.data, ..., .list = list(), times = 1) {
     !any(c("status", "body", "headers") %in% names(z)) &&
     length(z) != 0
   ) {
-    stop("'to_return' only accepts status, body, headers")
+    abort("'to_return' only accepts status, body, headers")
   }
   assert(z$status, c("numeric", "integer"))
   assert(z$headers, "list")
-  if (!all(hz_namez(z$headers))) stop("'headers' must be a named list")
+  if (!all(hz_namez(z$headers))) abort("'headers' must be a named list")
   replicate(times,
     .data$to_return(status = z$status, body = z$body, headers = z$headers))
   return(.data)

R/webmockr-package.R

@@ -22,5 +22,6 @@
 #' @importFrom fauxpas HTTPRequestTimeout
 #' @importFrom crul mock
 #' @importFrom base64enc base64encode
+#' @importFrom rlang abort check_installed
 ## usethis namespace: end
 NULL

R/wi_th.R

@@ -100,13 +100,13 @@ wi_th <- function(.data, ..., .list = list()) {
     !any(c("query", "body", "headers", "basic_auth") %in% names(z)) &&
       length(z) != 0
   ) {
-    stop("'wi_th' only accepts query, body, headers, basic_auth")
+    abort("'wi_th' only accepts query, body, headers, basic_auth")
   }
-  if (any(duplicated(names(z)))) stop("can not have duplicated names")
+  if (any(duplicated(names(z)))) abort("can not have duplicated names")
   assert(z$query, c("list", "partial"))
-  if (!all(hz_namez(z$query))) stop("'query' must be a named list")
+  if (!all(hz_namez(z$query))) abort("'query' must be a named list")
   assert(z$headers, "list")
-  if (!all(hz_namez(z$headers))) stop("'headers' must be a named list")
+  if (!all(hz_namez(z$headers))) abort("'headers' must be a named list")
   assert(z$basic_auth, "character")
   assert_eq(z$basic_auth, 2)
   .data$with(

R/zzz.R

@@ -214,15 +214,6 @@ hz_namez <- function(x) {
   }
 }
 
-# check for a package
-check_for_pkg <- function(x) {
-  if (!requireNamespace(x, quietly = TRUE)) {
-    stop(sprintf("Please install '%s'", x), call. = FALSE)
-  } else {
-    invisible(TRUE)
-  }
-}
-
 # lower case names in a list, return that list
 names_to_lower <- function(x) {
   names(x) <- tolower(names(x))

tests/testthat/test-Adapter.R

@@ -3,7 +3,17 @@ context("Adapter class")
 test_that("Adapter class can't be instantiated", {
   expect_is(Adapter, "R6ClassGenerator")
   expect_error(
-    Adapter$new(), 
+    Adapter$new(),
     "Adapter parent class should not be called directly"
   )
 })
+
+test_that("Adapter initialize method errors as expected", {
+  adap <- R6::R6Class("CrulAdapter", 
+    inherit = Adapter,
+    public = list(
+      client = NULL
+    )
+  )
+  expect_error(adap$new(), "should not be called directly")
+})

tests/testthat/test-to_return_body.R

@@ -55,6 +55,6 @@ test_that("to_return: setting body with wrong type errors well", {
   expect_error(
     stub_request("get", "https://google.com") %>%
       to_return(body = TRUE),
-    "Unknown type of `body`"
+    "Unknown `body` type"
   )
 })