tests/testthat/test-log.R

In rtemis.core: Core Utilities for the 'rtemis' Ecosystem

# test-log.R

# Run `body` with `opts` set; restore previous values on exit.
with_opts <- function(opts, body) {
  old <- options(opts)
  on.exit(options(old), add = TRUE)
  force(body)
}

`%||%` <- function(a, b) if (is.null(a)) b else a


# get_verbosity ----
test_that("get_verbosity defaults to 1L", {
  with_opts(list(rtemis.verbosity = NULL), {
    expect_identical(get_verbosity(), 1L)
  })
})

test_that("get_verbosity reads rtemis.verbosity option", {
  with_opts(list(rtemis.verbosity = 2L), {
    expect_identical(get_verbosity(), 2L)
  })
})

test_that("get_verbosity prefers package override when supplied", {
  with_opts(list(rtemis.verbosity = 1L, rtemis.server.verbosity = 0L), {
    expect_identical(get_verbosity("rtemis.server"), 0L)
  })
})

test_that("get_verbosity falls back to global when no package override", {
  with_opts(list(rtemis.verbosity = 2L, rtemis.server.verbosity = NULL), {
    expect_identical(get_verbosity("rtemis.server"), 2L)
  })
})


# strip_ansi ----
test_that("strip_ansi removes SGR escapes", {
  styled <- fmt("hello", col = "red", output_type = "ansi")
  expect_true(grepl("\033\\[", styled))
  expect_identical(strip_ansi(styled), "hello")
})

test_that("strip_ansi leaves plain text unchanged", {
  expect_identical(strip_ansi("plain text"), "plain text")
})


# info / warn / success / debug ----
test_that("info prints when verbosity >= 1", {
  with_opts(list(rtemis.verbosity = 1L), {
    expect_message(info("hello"), "hello")
  })
})

test_that("info is silent at verbosity 0", {
  with_opts(list(rtemis.verbosity = 0L), {
    expect_no_message(info("hello"))
  })
})

test_that("info verbosity argument overrides option", {
  with_opts(list(rtemis.verbosity = 0L), {
    expect_message(info("hello", verbosity = 1L), "hello")
  })
})

test_that("warn prints styled message by default", {
  with_opts(list(rtemis.verbosity = 1L), {
    expect_message(warn("careful"), "careful")
  })
})

test_that("warn(use_warning = TRUE) signals an R warning", {
  expect_warning(warn("real warn", use_warning = TRUE), "real warn")
})

test_that("warn(use_warning = TRUE) yields plain message", {
  w <- tryCatch(
    warn("a ", "b", use_warning = TRUE),
    warning = function(e) conditionMessage(e)
  )
  expect_identical(w, "a b")
  expect_false(grepl("\033\\[", w))
})

test_that("success prints when verbosity >= 1", {
  with_opts(list(rtemis.verbosity = 1L), {
    expect_message(success("done"), "done")
  })
})

test_that("dbg is silent at verbosity 1", {
  with_opts(list(rtemis.verbosity = 1L), {
    expect_no_message(dbg("trace"))
  })
})

test_that("dbg prints at verbosity >= 2", {
  with_opts(list(rtemis.verbosity = 2L), {
    expect_message(dbg("trace"), "trace")
  })
})


# abort ----
test_that("abort signals an error", {
  expect_error(abort("boom", verbosity = 0L))
})

test_that("abort condition carries supplied class plus base classes", {
  cond <- tryCatch(
    abort("boom", class = "my_wire_error", verbosity = 0L),
    condition = function(e) e
  )
  expect_true(inherits(cond, "my_wire_error"))
  expect_true(inherits(cond, "rtemis_error"))
  expect_true(inherits(cond, "error"))
  expect_true(inherits(cond, "condition"))
})

test_that("abort condition class can be caught selectively", {
  caught <- tryCatch(
    abort("only this", class = "my_wire_error", verbosity = 0L),
    my_wire_error = function(e) "caught_specifically",
    error = function(e) "caught_generically"
  )
  expect_identical(caught, "caught_specifically")
})

test_that("abort message is plain (no ANSI)", {
  cond <- tryCatch(
    abort("plain text only", verbosity = 0L),
    condition = function(e) e
  )
  expect_identical(conditionMessage(cond), "plain text only")
  expect_false(grepl("\033\\[", conditionMessage(cond)))
})

test_that("abort wire message does not include the operator-side glyph", {
  # The error glyph is prepended only to the console echo; the condition
  # message (which travels over the wire / into a browser UI) must remain
  # bare so downstream consumers don't need to strip a decorative prefix.
  cond <- tryCatch(
    abort("bare", verbosity = 0L),
    condition = function(e) e
  )
  expect_false(grepl(glyph_error, conditionMessage(cond), fixed = TRUE))
})

test_that("abort message is plain when caller wraps a parent with ANSI", {
  # Parent conditions from foreign packages (cli, rlang, etc.) may contain
  # ANSI in their message. Our wrap message itself is plain — the parent
  # ANSI only matters for the *console echo* (handled in a separate test).
  inner <- structure(
    class = c("error", "condition"),
    list(message = fmt("inner", col = "red", output_type = "ansi"), call = NULL)
  )
  cond <- tryCatch(
    abort("outer", parent = inner, verbosity = 0L),
    condition = function(e) e
  )
  expect_identical(conditionMessage(cond), "outer")
})

test_that("abort propagates parent condition", {
  inner <- structure(
    class = c("inner_err", "error", "condition"),
    list(message = "inner reason", call = NULL)
  )
  cond <- tryCatch(
    abort("outer wrap", parent = inner, verbosity = 0L),
    condition = function(e) e
  )
  expect_identical(cond$parent, inner)
})

test_that("abort writes console output when verbosity >= 1", {
  # The console echo carries the most-specific class name (or "rtemis_error"
  # when class = NULL), NOT the human message - the human message is left
  # to R's default error printer so the two channels don't duplicate.
  with_opts(list(rtemis.verbosity = 1L), {
    expect_message(
      expect_error(abort("loud boom")),
      "rtemis_error"
    )
    expect_message(
      expect_error(abort("typed boom", class = "my_specific_error")),
      "my_specific_error"
    )
  })
})

test_that("abort suppresses console output at verbosity 0", {
  with_opts(list(rtemis.verbosity = 0L), {
    expect_no_message(expect_error(abort("quiet boom")))
  })
})

test_that("abort attaches data fields to the condition", {
  cond <- tryCatch(
    abort(
      "rate limited",
      class = "my_api_error",
      data = list(status_code = 429L, provider = "anthropic"),
      verbosity = 0L
    ),
    condition = function(e) e
  )
  expect_identical(cond$status_code, 429L)
  expect_identical(cond$provider, "anthropic")
  # Data fields must not leak into the human-readable message.
  expect_identical(conditionMessage(cond), "rate limited")
})

test_that("abort data fields are visible to selective handlers", {
  status <- tryCatch(
    abort(
      "boom",
      class = "my_api_error",
      data = list(status_code = 503L),
      verbosity = 0L
    ),
    my_api_error = function(e) e$status_code
  )
  expect_identical(status, 503L)
})

test_that("abort rejects unnamed or partially named data", {
  expect_error(
    abort("boom", data = list(1L), verbosity = 0L),
    "fully named list"
  )
  expect_error(
    abort("boom", data = list(a = 1L, 2L), verbosity = 0L),
    "fully named list"
  )
  expect_error(
    abort("boom", data = c(a = 1L), verbosity = 0L),
    "fully named list"
  )
})

test_that("abort rejects data names that collide with condition fields", {
  expect_error(
    abort("boom", data = list(message = "clobber"), verbosity = 0L),
    "collide"
  )
  expect_error(
    abort("boom", data = list(calls = "clobber", ok = 1L), verbosity = 0L),
    "collide"
  )
})

test_that("abort rejects a `trace` field in data", {
  # `trace` is not a field abort() sets, so this is not a clobber check: it
  # stops a caller from reintroducing the testthat/rlang reporter crash that
  # naming the stack `$calls` was meant to avoid.
  expect_error(
    abort("boom", data = list(trace = "clobber"), verbosity = 0L),
    "must not set `trace`"
  )
  expect_error(
    abort("boom", data = list(trace = sys.calls(), ok = 1L), verbosity = 0L),
    "must not set `trace`"
  )
})

test_that("abort accepts NULL and empty-list data", {
  cond <- tryCatch(
    abort("boom", data = list(), verbosity = 0L),
    condition = function(e) e
  )
  expect_identical(conditionMessage(cond), "boom")
  cond <- tryCatch(
    abort("boom", data = NULL, verbosity = 0L),
    condition = function(e) e
  )
  expect_identical(conditionMessage(cond), "boom")
})


test_that("abort does not claim the `trace` condition field", {
  # rlang and testthat treat `$trace` as an `rlang::trace_back()` object and
  # call `nrow()` on it. A `pairlist` there returns NULL, so testthat's
  # `format.expectation()` errors on `NA` and takes the whole reporter down --
  # every rtemis error in a failing test becomes unreadable. Leaving the name
  # unclaimed also lets testthat show its own backtrace, pruned to user frames.
  cond <- tryCatch(abort("boom", verbosity = 0L), condition = function(e) e)
  expect_false("trace" %in% names(cond))
  expect_null(cond[["trace"]])
  expect_true(length(cond[["calls"]]) > 0L)
  expect_true(all(vapply(cond[["calls"]], is.call, logical(1L))))
})


# format_trace ----
test_that("format_trace returns empty string for NULL or empty trace", {
  expect_identical(format_trace(NULL), "")
  expect_identical(format_trace(list()), "")
})

test_that("format_trace accepts a condition and extracts $calls", {
  cond <- tryCatch(
    abort("boom", verbosity = 0L),
    condition = function(e) e
  )
  out <- format_trace(cond)
  expect_type(out, "character")
  expect_true(nchar(out) > 0L)
})

test_that("format_trace numbers frames with newest last", {
  trace <- list(quote(f()), quote(g()), quote(h()))
  out <- format_trace(trace)
  lines <- strsplit(out, "\n", fixed = TRUE)[[1L]]
  expect_length(lines, 3L)
  expect_match(lines[[1L]], "^ 1: f\\(\\)$")
  expect_match(lines[[2L]], "^ 2: g\\(\\)$")
  expect_match(lines[[3L]], "^ 3: h\\(\\)$")
})

test_that("format_trace truncates lines longer than max_width", {
  long_call <- as.call(c(list(as.name("f")), as.list(rep("xxxxxxxx", 20L))))
  out <- format_trace(list(long_call), max_width = 40L)
  # Line is "%2d: " (5 chars) plus deparsed call, truncated to max_width.
  body <- sub("^ *\\d+: ", "", out)
  expect_identical(nchar(body), 40L)
  expect_true(endsWith(body, "..."))
})

test_that("format_trace renders an rlang trace via rlang's formatter", {
  # Packages built on `rlang::abort()` put their stack on `$trace` as an
  # rlang trace object, not on `$calls`. Deparsing that would walk the
  # underlying data.frame's columns, so it is handed to rlang to format.
  skip_if_not_installed("rlang")
  cond <- tryCatch(rlang::abort("upstream boom"), condition = function(e) e)
  expect_null(cond[["calls"]])
  out <- format_trace(cond)
  expect_type(out, "character")
  expect_length(out, 1L)
  expect_true(nchar(out) > 0L)
  # rlang's tree layout, not our "%2d: " numbering, and no column garbage.
  expect_no_match(out, "^c\\(0L, 1L", fixed = FALSE)
  expect_match(out, "abort")
})

test_that("format_trace ignores a $trace that is not an rlang trace", {
  # The class gate means a bogus `$trace` is skipped rather than mangled.
  cond <- structure(
    class = c("rtemis_error", "error", "condition"),
    list(message = "boom", trace = list(quote(f()), quote(g())))
  )
  expect_identical(format_trace(cond), "")
  # `$calls` still wins when both are present.
  cond2 <- structure(
    class = c("rtemis_error", "error", "condition"),
    list(message = "boom", calls = list(quote(h())), trace = "junk")
  )
  expect_match(format_trace(cond2), "h\\(\\)")
})