From c733977bb009548bf2a088f27d598237aa167ecc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?G=C3=A1bor=20Cs=C3=A1rdi?= Date: Mon, 8 Apr 2024 16:15:40 +0200 Subject: [PATCH] More tests --- DESCRIPTION | 1 + R/errors.R | 29 ++- R/onload.R | 3 + R/utils.R | 17 +- tests/testthat/_snaps/cli.md | 21 ++ tests/testthat/_snaps/utils.md | 163 +++++++++++++ tests/testthat/fixtures/bad.tar.gz | Bin 0 -> 2048 bytes tests/testthat/fixtures/pkg/DESCRIPTION | 12 + tests/testthat/fixtures/pkg/NAMESPACE | 2 + tests/testthat/fixtures/pkg_0.0.0.9000.tar.gz | Bin 0 -> 554 bytes tests/testthat/test-cli.R | 11 + tests/testthat/test-utils.R | 222 ++++++++++++++++++ 12 files changed, 464 insertions(+), 17 deletions(-) create mode 100644 R/onload.R create mode 100644 tests/testthat/_snaps/cli.md create mode 100644 tests/testthat/_snaps/utils.md create mode 100644 tests/testthat/fixtures/bad.tar.gz create mode 100644 tests/testthat/fixtures/pkg/DESCRIPTION create mode 100644 tests/testthat/fixtures/pkg/NAMESPACE create mode 100644 tests/testthat/fixtures/pkg_0.0.0.9000.tar.gz create mode 100644 tests/testthat/test-cli.R create mode 100644 tests/testthat/test-utils.R diff --git a/DESCRIPTION b/DESCRIPTION index 2f3acb9..cc5f4ad 100644 --- 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 index 3f10eda..5a6b15a 100644 --- 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 new file mode 100644 index 0000000..39d9015 --- /dev/null +++ b/R/onload.R @@ -0,0 +1,3 @@ +.onLoad <- function(libname, pkgname) { + err$onload_hook() +} \ No newline at end of file diff --git a/R/utils.R b/R/utils.R index c79af4f..edf4c47 100644 --- 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@(?[^:]+):(?.*)[.]git$" mch <- re_match(url, ssh_re_url) + # try without the trailing .git as well + if (is.na(mch[[1]])) { + ssh_re_url2 <- "^git@(?[^:]+):(?.*)$" + 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 new file mode 100644 index 0000000..0bbcb33 --- /dev/null +++ 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 new file mode 100644 index 0000000..7f99c17 --- /dev/null +++ b/tests/testthat/_snaps/utils.md @@ -0,0 +1,163 @@ +# pkg_error + + Code + err + Output + + Error: + ! This is not good! + i You should not use `foo`, use `bar` instead. + +# stop + + Code + err + Output + + Error: + ! This is not good! + i You should not use `foo`, use `bar` instead. + +# stop with message + + Code + err + Output + + 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://user@github.com/r-hub/rhub") + Output + protocol host path + 1 https github.com /r-hub/rhub + Code + parse_url("https://user:pass@github.com/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("git@github.com:/r-hub/rhub") + Output + protocol host path + 1 https github.com /r-hub/rhub + Code + parse_url("git@github.com:/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: + +# 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 new file mode 100644 index 0000000000000000000000000000000000000000..a69a59a69ce9de6bcf1eba308d5e078be548b458 GIT binary patch literal 2048 zcmYdFOktokFaQEG6B7myZEj`?rh!Zt4P+WK7@C+Fn3$Uzni-li7#JFw8yhny7|_~b zAoEL$OA?EKPDxKp$}dVTPAp2v#A<}<(I#J+%(P)Hzj>_x4Tbc&QF5luEt)6}}) z5G!CK+tJ#8zk|@Kl`8F1E3M)IWc%)n@5T32`}|}wy&5O8)q1vE7_R{jF$#iaj7DKI zdV}K{;roNg@Pm;TL{S)cL&Nij;b>@pXS@LpN)w5$CzaH4 zdd>e@pkYb5ZmgEccs9YA^>evN`pv38n^=xxPN+&Ht90Y!V`x>S<(UF4pknDB$fL8ZojK*H$QaLK z*sL%5r)DDV?sJNM6-;TnByyjLKODnYC!4ABpk4@#u0-z8^^f^oP@1W+C@WTwV_aOA zZLzW#2H0GE58qSpgV^_DKg9FKpWw+IZ)+4oQxm8Q0>3cRJ-|Hw2K!kW9rKbfuJNPK zcYJ=id|yqY!~X$n`;*1_<@9QGKAyhP8UNsa&kIKn{2xSNSo8nT3p@UQ3w(fY6uX*e sn!)WovTnmTgBXbsNks$An64E&!ZWjL>kb_{ba*%T3;Bk-QvePC0NKC{MgRZ+ literal 0 HcmV?d00001 diff --git a/tests/testthat/test-cli.R b/tests/testthat/test-cli.R new file mode 100644 index 0000000..2beaa51 --- /dev/null +++ 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") + }) +}) diff --git a/tests/testthat/test-utils.R b/tests/testthat/test-utils.R new file mode 100644 index 0000000..9af98b8 --- /dev/null +++ b/tests/testthat/test-utils.R @@ -0,0 +1,222 @@ +test_that("pkg_error", { + err <- tryCatch( + throw(pkg_error( + "!" = "This is not good!", + "i" = "You should not use {.code foo}, use {.code bar} instead.", + .data = list(foo = 1:3), + call. = FALSE + )), + error = function(e) e + ) + expect_snapshot(err) + expect_equal(err$foo, 1:3) +}) + +test_that("stop", { + err <- tryCatch( + stop(pkg_error( + "!" = "This is not good!", + "i" = "You should not use {.code foo}, use {.code bar} instead.", + call. = FALSE + )), + error = function(e) e + ) + expect_snapshot(err) +}) + +test_that("stop with message", { + err <- tryCatch( + stop("Ooopsie daily!"), + error = function(e) e + ) + expect_snapshot(err) +}) + +test_that("stopifnot", { + expect_snapshot(error = TRUE, { + stopifnot(1 == 2) + }) +}) + +test_that("zip", { + expect_snapshot({ + zip(character(), character()) + zip(letters[1:5], LETTERS[1:5]) + zip("1", letters[1:5]) + }) +}) + +test_that("first_char", { + expect_equal(first_char("foo"), "f") + expect_equal(first_char("f"), "f") + expect_equal(first_char(letters), letters) + expect_equal(first_char(paste(letters, LETTERS)), letters) + expect_equal(first_char(""), "") + expect_equal(first_char(character()), character()) +}) + +test_that("last_char", { + expect_equal(last_char("foo"), "o") + expect_equal(last_char("f"), "f") + expect_equal(last_char(letters), letters) + expect_equal(last_char(paste(letters, LETTERS)), LETTERS) + expect_equal(last_char(""), "") + expect_equal(last_char(character()), character()) +}) + +test_that("unquote", { + keep <- list( + "foo", + "'foo", + "foo'", + "\"foo'", + "'foo\"", + letters, + paste0("'", letters), + paste0(letters, "'"), + character() + ) + for (k in keep) expect_equal(unquote(k), k, info = k) + + expect_snapshot({ + unquote("'quoted'") + unquote(c("'quoted'", "not", '"quoted"')) + }) +}) + +test_that("has_emoji", { + mockery::stub(has_emoji, "cli::is_utf8_output", FALSE) + expect_false(has_emoji()) + + mockery::stub(has_emoji, "cli::is_utf8_output", TRUE) + withr::local_options(pkg.emoji = TRUE) + expect_true(has_emoji()) + + withr::local_options(pkg.emoji = FALSE) + expect_false(has_emoji()) + + withr::local_options(pkg.emoji = NULL) + mockery::stub(has_emoji, "Sys.info", list(sysname = "Darwin")) + expect_true(has_emoji()) + + mockery::stub(has_emoji, "Sys.info", list(sysname = "Linux")) + expect_false(has_emoji()) +}) + +test_that("parse_url", { + expect_snapshot({ + parse_url("https://github.com/r-hub/rhub") + parse_url("https://user@github.com/r-hub/rhub") + parse_url("https://user:pass@github.com/r-hub/rhub") + parse_url("https://github.com/r-hub/rhub?q=foo&p=bar") + + parse_url("git@github.com:/r-hub/rhub") + parse_url("git@github.com:/r-hub/rhub.git") + }) + + expect_snapshot(error = TRUE, { + parse_url("this is not a URL at all") + }) +}) + +test_that("read_file", { + tmp <- tempfile() + on.exit(unlink(tmp), add = TRUE) + + cnt <- as.raw(c(0xc3, 0xa9, 0xc3, 0xa1)) + writeBin(cnt, tmp) + cnt2 <- read_file(tmp) + expect_equal(Encoding(cnt2), "UTF-8") + expect_equal(charToRaw(cnt2), cnt) + + writeBin(cnt[1:3], tmp) + expect_error(read_file(tmp), "not UTF-8") +}) + +cli::test_that_cli("ansi_align_width", configs = c("plain", "ansi"), { + expect_snapshot({ + paste0("--", ansi_align_width(c("foo", "bar", "foobar")), "--") + paste0( + "--", + ansi_align_width(c("foo", "bar", cli::col_red("foobar"))), + "--" + ) + ansi_align_width(character()) + }) +}) + +test_that("random_id", { + expect_true(is.character(random_id())) + expect_true(nchar(random_id()) >= 5) +}) + +test_that("readline", { + args <- NULL + mockery::stub( + readline, + "base::readline", + function(...) args <<- list(...) + ) + readline(prompt = "prompt") + expect_equal(args, list("prompt")) +}) + +test_that("is_interactive", { + withr::local_options(rlib_interactive = TRUE) + expect_true(is_interactive()) + + withr::local_options(rlib_interactive = FALSE) + expect_false(is_interactive()) + + withr::local_options(rlib_interactive = NULL) + withr::local_options(knitr.in.progress = TRUE) + expect_false(is_interactive()) + + withr::local_options(knitr.in.progress = NULL) + withr::local_options(rstudio.notebook.executing = TRUE) + expect_false(is_interactive()) + + withr::local_options(rstudio.notebook.executing = NULL) + withr::local_envvar(TESTTHAT = "true") + expect_false(is_interactive()) + + withr::local_envvar(TESTTHAT = NA_character_) + mockery::stub(is_interactive, "interactive", FALSE) + expect_false(is_interactive()) + mockery::stub(is_interactive, "interactive", TRUE) + expect_true(is_interactive()) +}) + +test_that("update", { + orig <- list(a = 1, b = 2) + expect_equal(update(orig, list()), orig) + expect_equal(update(orig, list(a = 2, c = 3)), list(a = 2, b = 2, c = 3)) +}) + +test_that("get_maintainer_email", { + pkg <- test_path("fixtures/pkg") + expect_equal(get_maintainer_email(pkg), "first.last@example.com") + + pkg2 <- test_path("fixtures/pkg_0.0.0.9000.tar.gz") + expect_equal(get_maintainer_email(pkg2), "first.last@example.com") + + bad <- tempfile() + on.exit(unlink(bad, recursive = TRUE), add = TRUE) + dir.create(bad) + expect_error(get_maintainer_email(bad), "file found") + + bad2 <- test_path("fixtures/bad.tar.gz") + expect_error(get_maintainer_email(bad2), "file in package") +}) + +test_that("is_dir", { + tmp <- tempfile() + on.exit(unlink(tmp), add = TRUE) + file.create(tmp) + expect_true(is_dir(tempdir())) + expect_false(is_dir(tmp)) +}) + +test_that("parse_email", { + +})