tests/testthat/test-subprocess.R

In r-pkgs/boxes: Helpers for Developing Command Line Interfaces

test_that("events are properly generated", {
  ## This needs callr >= 3.0.0.90001, which is not yet on CRAN
  if (packageVersion("callr") < "3.0.0.9001") skip("Need newer callr")

  do <- function() {
    options(cli.message_class = "callr_message")
    cli::cli_div()
    cli::cli_h1("title")
    cli::cli_text("text")
  }

  rs <- callr::r_session$new()
  on.exit(rs$kill(), add = TRUE)

  msgs <- list()
  handler <- function(msg) {
    msgs <<- c(msgs, list(msg))
    if (!is.null(findRestart("cli_message_handled"))) {
      invokeRestart("cli_message_handled")
    }
    if (!is.null(findRestart("callr_r_session_muffle"))) {
      invokeRestart("callr_r_session_muffle")
    }
  }

  withCallingHandlers(
    rs$run(do),
    cli_message = handler)

  expect_equal(length(msgs), 4)
  lapply(msgs, expect_s3_class, "cli_message")
  expect_equal(msgs[[1]]$type, "div")
  expect_equal(msgs[[2]]$type, "h1")
  expect_equal(msgs[[3]]$type, "text")
  expect_equal(msgs[[4]]$type, "end")

  rs$close()
})

test_that("subprocess with default handler", {
  ## This needs callr >= 3.0.0.90001, which is not yet on CRAN
  if (packageVersion("callr") < "3.0.0.9001") skip("Need newer callr")

  do <- function() {
    options(cli.message_class = "callr_message")
    cli::cli_div()
    cli::cli_h1("title")
    cli::cli_text("text")
  }

  rs <- callr::r_session$new()
  on.exit(rs$kill(), add = TRUE)

  msgs <- list()
  withr::with_options(list(
    cli.default_handler = function(msg)  {
      msgs <<- c(msgs, list(msg))
      if (!is.null(findRestart("cli_message_handled"))) {
        invokeRestart("cli_message_handled")
      }
    }),
    rs$run(do)
  )

  expect_equal(length(msgs), 4)
  lapply(msgs, expect_s3_class, "cli_message")
  expect_equal(msgs[[1]]$type, "div")
  expect_equal(msgs[[2]]$type, "h1")
  expect_equal(msgs[[3]]$type, "text")
  expect_equal(msgs[[4]]$type, "end")

  rs$close()
})

test_that("output in child process", {
  ## This needs callr >= 3.0.0.90001, which is not yet on CRAN
  if (packageVersion("callr") < "3.0.0.9001") skip("Need newer callr")

  # We need to do our own condition handling, otherwise callr will
  # handle `cli_message` and copy it to the main process.
  # So on `cli_message` we just call the default handler, which will
  # call `message()`, and on `message` we'll copy the formatted message
  # to the main process.

  do <- function() {
    options(cli.num_colors = 256)
    withCallingHandlers({
        cli::start_app(theme = cli::simple_theme())
        cli::cli_h1("Title")
        cli::cli_text("This is generated in the {.emph subprocess}.")
        "foobar"
      },
      cli_message = function(msg) {
        withCallingHandlers({
          cli:::cli_server_default(msg)
          invokeRestart("cli_message_handled") },
          message = function(mmsg) {
            class(mmsg) <- c("callr_message", "message", "condition")
            signalCondition(mmsg)
        })
      }
    )
  }

  rs <- callr::r_session$new()
  on.exit(rs$kill(), add = TRUE)

  # Store the formatted messages from callr
  # We also need to muffle the default handler here

  msgs <- list()
  result <- withCallingHandlers(
    rs$run_with_output(do),
    callr_message = function(msg) {
      msgs <<- c(msgs, list(msg))
      if (!is.null(msg$muffle) && !is.null(findRestart(msg$muffle))) {
        invokeRestart(msg$muffle)
      }
    }
  )

  expect_equal(result$stdout, "")
  expect_equal(result$stderr, "")
  expect_identical(result$result, "foobar")
  expect_null(result$error)
  str <- paste(vcapply(msgs, "[[", "message"), collapse = "")
  expect_true(ansi_has_any(str))
  expect_match(str, "Title")
  expect_match(str, "This is generated")

  rs$close()
})

test_that("substitution in child process", {

  do <- function() {
    options(cli.message_class = "callr_message")
    cli::cli_text("This is process {Sys.getpid()}.")
  }

  rs <- callr::r_session$new()
  on.exit(rs$kill(), add = TRUE)

  out <- capt0(rs$run(do))
  expect_match(out, glue::glue("This is process {rs$get_pid()}"))

  rs$close()
})