More tests

r-hub · Apr 8, 2024 · c733977 · c733977
1 parent 1db6a87
commit c733977
Show file tree

Hide file tree

Showing 12 changed files with 464 additions and 17 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -38,6 +38,7 @@ Suggests:
     asciicast,
     debugme,
     knitr,
+    mockery,
     pillar,
     rmarkdown,
     testthat (>= 3.0.0),

diff --git a/R/errors.R b/R/errors.R
@@ -203,7 +203,7 @@ err <- local({
 
   new_error <- function(..., call. = TRUE, srcref = NULL, domain = NA) {
     cond <- new_cond(..., call. = call., domain = domain, srcref = srcref)
-    class(cond) <- c("rlib_error_3_0", "rlib_error", "error", "condition")
+    class(cond) <- c("rlib_error_3_1", "rlib_error", "error", "condition")
     cond
   }
 
@@ -372,7 +372,7 @@ err <- local({
         name <- native_name(.NAME)
         err <- new_error("Native call to `", name, "` failed", call. = call1)
         cerror <- if (inherits(e, "simpleError")) "c_error"
-        class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
+        class(err) <- c(cerror, "rlib_error_3_1", "rlib_error", "error", "condition")
         throw_error(err, parent = e)
       }
     )
@@ -407,7 +407,7 @@ err <- local({
         name <- native_name(.NAME)
         err <- new_error("Native call to `", name, "` failed", call. = call1)
         cerror <- if (inherits(e, "simpleError")) "c_error"
-        class(err) <- c(cerror, "rlib_error_3_0", "rlib_error", "error", "condition")
+        class(err) <- c(cerror, "rlib_error_3_1", "rlib_error", "error", "condition")
         throw_error(err, parent = e)
       }
     )
@@ -710,21 +710,22 @@ err <- local({
   # -- condition message with cli ---------------------------------------
 
   cnd_message_robust <- function(cond) {
-    class(cond) <- setdiff(class(cond), "rlib_error_3_0")
+    class(cond) <- setdiff(class(cond), "rlib_error_3_1")
     conditionMessage(cond) %||%
       (if (inherits(cond, "interrupt")) "interrupt") %||%
       ""
   }
 
   cnd_message_cli <- function(cond, full = FALSE) {
-    exp <- paste0(cli::col_yellow("!"), " ")
-    add_exp <- is.null(names(cond$message))
     msg <- cnd_message_robust(cond)
+    exp <- paste0(cli::col_yellow("!"), " ")
+    add_exp <- is.null(names(cond$message)) &&
+      substr(cli::ansi_strip(msg[1]), 1, 1) != "!"
 
     c(
       paste0(if (add_exp) exp, msg),
       if (inherits(cond$parent, "condition")) {
-        msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
+        msg <- if (full && inherits(cond$parent, "rlib_error_3_1")) {
           format(cond$parent,
                  trace = FALSE,
                  full = TRUE,
@@ -750,11 +751,13 @@ err <- local({
 
   cnd_message_plain <- function(cond, full = FALSE) {
     exp <- "! "
-    add_exp <- is.null(names(cond$message))
+    msg <- cnd_message_robust(cond)
+    add_exp <- is.null(names(cond$message)) &&
+      substr(msg[1], 1, 1) != "!"
     c(
-      paste0(if (add_exp) exp, cnd_message_robust(cond)),
+      paste0(if (add_exp) exp, msg),
       if (inherits(cond$parent, "condition")) {
-        msg <- if (full && inherits(cond$parent, "rlib_error_3_0")) {
+        msg <- if (full && inherits(cond$parent, "rlib_error_3_1")) {
           format(cond$parent,
                  trace = FALSE,
                  full = TRUE,
@@ -1126,11 +1129,11 @@ err <- local({
   onload_hook <- function() {
     reg_env <- Sys.getenv("R_LIB_ERROR_REGISTER_PRINT_METHODS", "TRUE")
     if (tolower(reg_env) != "false") {
-      registerS3method("format", "rlib_error_3_0", format_error, baseenv())
+      registerS3method("format", "rlib_error_3_1", format_error, baseenv())
       registerS3method("format", "rlib_trace_3_0", format_trace, baseenv())
-      registerS3method("print", "rlib_error_3_0", print_error, baseenv())
+      registerS3method("print", "rlib_error_3_1", print_error, baseenv())
       registerS3method("print", "rlib_trace_3_0", print_trace, baseenv())
-      registerS3method("conditionMessage", "rlib_error_3_0", cnd_message, baseenv())
+      registerS3method("conditionMessage", "rlib_error_3_1", cnd_message, baseenv())
     }
   }
 

diff --git a/R/onload.R b/R/onload.R
@@ -0,0 +1,3 @@
+.onLoad <- function(libname, pkgname) {
+  err$onload_hook()
+}
diff --git a/R/utils.R b/R/utils.R
@@ -23,7 +23,7 @@ stop <- function(..., call. = TRUE, domain = NA) {
   args <- list(...)
   if (length(args) == 1L && inherits(args[[1L]], "condition")) {
     throw(
-      add_class(args[[1]], c("rlib_error_3_0", "rlib_error"), "end"),
+      add_class(args[[1]], c("rlib_error_3_1", "rlib_error"), "end"),
       frame = parent.frame()
     )
   } else {
@@ -47,7 +47,7 @@ add_class <- function(obj, classes, where = c("start", "end")) {
 }
 
 zip <- function(x, y) {
-  mapply(FUN = c, x, y, SIMPLIFY = FALSE)
+  mapply(FUN = c, x, y, SIMPLIFY = FALSE, USE.NAMES = FALSE)
 }
 
 first_char <- function(x) {
@@ -59,11 +59,11 @@ last_char <- function(x) {
 }
 
 unquote <- function(x) {
-  ifelse(
+  as.character(ifelse(
     first_char(x) == last_char(x) & first_char(x) %in% c("'", '"'),
     substr(x, 2L, nchar(x) - 1L),
     x
-  )
+  ))
 }
 
 has_emoji <- function() {
@@ -88,6 +88,12 @@ parse_url <- function(url) {
     ssh_re_url <- "^git@(?<host>[^:]+):(?<path>.*)[.]git$"
     mch <- re_match(url, ssh_re_url)
 
+    # try without the trailing .git as well
+    if (is.na(mch[[1]])) {
+      ssh_re_url2 <- "^git@(?<host>[^:]+):(?<path>.*)$"
+      mch <- re_match(url, ssh_re_url2)
+    }
+
     if (is.na(mch[[1]])) {
       cli::cli_abort("Invalid URL: {.url {url}}")
     }
@@ -102,6 +108,9 @@ parse_url <- function(url) {
 read_file <- function(path) {
   bin <- readBin(path, "raw", file.size(path))
   chr <- rawToChar(bin)
+  if (is.na(iconv(chr, "UTF-8", "UTF-8"))) {
+    throw(pkg_error("{.path {path}} is not UTF-8, giving up. :("))
+  }
   Encoding(chr) <- "UTF-8"
   chr
 }

diff --git a/tests/testthat/_snaps/cli.md b/tests/testthat/_snaps/cli.md
@@ -0,0 +1,21 @@
+# cli_status
+
+    Code
+      pid <- cli_status("This is a status message")
+    Message
+      > This is a status message
+    Code
+      cli::cli_status_clear(pid, result = "clear")
+
+---
+
+    Code
+      pid <- cli_status("This is a status message")
+    Message
+      > This is a status message
+    Code
+      cli::cli_status_clear(pid, result = "failed")
+    Message
+      x This is a status message
+      
+
diff --git a/tests/testthat/_snaps/utils.md b/tests/testthat/_snaps/utils.md
@@ -0,0 +1,163 @@
+# pkg_error
+
+    Code
+      err
+    Output
+      <rlib_error_3_1/rlib_error/error>
+      Error: 
+      ! This is not good!
+      i You should not use `foo`, use `bar` instead.
+
+# stop
+
+    Code
+      err
+    Output
+      <rlib_error_3_1/rlib_error/error>
+      Error: 
+      ! This is not good!
+      i You should not use `foo`, use `bar` instead.
+
+# stop with message
+
+    Code
+      err
+    Output
+      <rlib_error_3_1/rlib_error/error>
+      Error in `stop("Ooopsie daily!")`:
+      ! Ooopsie daily!
+
+# stopifnot
+
+    Code
+      stopifnot(1 == 2)
+    Condition
+      Error:
+      ! `1` must equal `2`.
+
+# zip
+
+    Code
+      zip(character(), character())
+    Output
+      list()
+    Code
+      zip(letters[1:5], LETTERS[1:5])
+    Output
+      [[1]]
+      [1] "a" "A"
+      
+      [[2]]
+      [1] "b" "B"
+      
+      [[3]]
+      [1] "c" "C"
+      
+      [[4]]
+      [1] "d" "D"
+      
+      [[5]]
+      [1] "e" "E"
+      
+    Code
+      zip("1", letters[1:5])
+    Output
+      [[1]]
+      [1] "1" "a"
+      
+      [[2]]
+      [1] "1" "b"
+      
+      [[3]]
+      [1] "1" "c"
+      
+      [[4]]
+      [1] "1" "d"
+      
+      [[5]]
+      [1] "1" "e"
+      
+
+# unquote
+
+    Code
+      unquote("'quoted'")
+    Output
+      [1] "quoted"
+    Code
+      unquote(c("'quoted'", "not", "\"quoted\""))
+    Output
+      [1] "quoted" "not"    "quoted"
+
+# parse_url
+
+    Code
+      parse_url("https://github.com/r-hub/rhub")
+    Output
+        protocol       host        path
+      1    https github.com /r-hub/rhub
+    Code
+      parse_url("https://[email protected]/r-hub/rhub")
+    Output
+        protocol       host        path
+      1    https github.com /r-hub/rhub
+    Code
+      parse_url("https://user:[email protected]/r-hub/rhub")
+    Output
+        protocol       host        path
+      1    https github.com /r-hub/rhub
+    Code
+      parse_url("https://github.com/r-hub/rhub?q=foo&p=bar")
+    Output
+        protocol       host                    path
+      1    https github.com /r-hub/rhub?q=foo&p=bar
+    Code
+      parse_url("[email protected]:/r-hub/rhub")
+    Output
+        protocol       host        path
+      1    https github.com /r-hub/rhub
+    Code
+      parse_url("[email protected]:/r-hub/rhub.git")
+    Output
+        protocol       host        path
+      1    https github.com /r-hub/rhub
+
+---
+
+    Code
+      parse_url("this is not a URL at all")
+    Condition
+      Error in `parse_url()`:
+      ! Invalid URL: <this is not a URL at all>
+
+# ansi_align_width [plain]
+
+    Code
+      paste0("--", ansi_align_width(c("foo", "bar", "foobar")), "--")
+    Output
+      [1] "--foo   --" "--bar   --" "--foobar--"
+    Code
+      paste0("--", ansi_align_width(c("foo", "bar", cli::col_red("foobar"))), "--")
+    Output
+      [1] "--foo   --" "--bar   --" "--foobar--"
+    Code
+      ansi_align_width(character())
+    Output
+      character(0)
+
+# ansi_align_width [ansi]
+
+    Code
+      paste0("--", ansi_align_width(c("foo", "bar", "foobar")), "--")
+    Output
+      [1] "--foo   --" "--bar   --" "--foobar--"
+    Code
+      paste0("--", ansi_align_width(c("foo", "bar", cli::col_red("foobar"))), "--")
+    Output
+      [1] "--foo   --"                 "--bar   --"                
+      [3] "--\033[31mfoobar\033[39m--"
+    Code
+      ansi_align_width(character())
+    Output
+      character(0)
+
diff --git a/tests/testthat/fixtures/bad.tar.gz b/tests/testthat/fixtures/bad.tar.gz
diff --git a/tests/testthat/fixtures/pkg/DESCRIPTION b/tests/testthat/fixtures/pkg/DESCRIPTION
@@ -0,0 +1,12 @@
+Package: pkg
+Title: What the Package Does (One Line, Title Case)
+Version: 0.0.0.9000
+Authors@R: 
+    person("First", "Last", , "[email protected]", role = c("aut", "cre"),
+           comment = c(ORCID = "YOUR-ORCID-ID"))
+Description: What the package does (one paragraph).
+License: `use_mit_license()`, `use_gpl3_license()` or friends to pick a
+    license
+Encoding: UTF-8
+Roxygen: list(markdown = TRUE)
+RoxygenNote: 7.3.1.9000
diff --git a/tests/testthat/fixtures/pkg/NAMESPACE b/tests/testthat/fixtures/pkg/NAMESPACE
@@ -0,0 +1,2 @@
+# Generated by roxygen2: do not edit by hand
+
diff --git a/tests/testthat/fixtures/pkg_0.0.0.9000.tar.gz b/tests/testthat/fixtures/pkg_0.0.0.9000.tar.gz
diff --git a/tests/testthat/test-cli.R b/tests/testthat/test-cli.R
@@ -0,0 +1,11 @@
+test_that("cli_status", {
+  expect_snapshot({
+    pid <- cli_status("This is a status message")
+    cli::cli_status_clear(pid, result = "clear")
+  })
+
+  expect_snapshot({
+    pid <- cli_status("This is a status message")
+    cli::cli_status_clear(pid, result = "failed")
+  })
+})