tests/testthat/test-subprocess.R

In r-lib/cliapp: Create Rich Command Line Applications

context("subprocess")

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() {
    cliapp::cli_div()
    cliapp::cli_h1("title")
    cliapp::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("muffleMessage"))) {
      invokeRestart("muffleMessage")
    }
  }

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

  expect_equal(length(msgs), 4)
  lapply(msgs, expect_s3_class, "cliapp_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() {
    cliapp::cli_div()
    cliapp::cli_h1("title")
    cliapp::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("muffleMessage"))) {
        invokeRestart("muffleMessage")
      }
    }),
    rs$run(do)
  )

  expect_equal(length(msgs), 4)
  lapply(msgs, expect_s3_class, "cliapp_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")

  do <- function() {
    options(crayon.enabled = TRUE)
    options(crayon.colors = 256)
    crayon::num_colors(forget = TRUE)
    withCallingHandlers(
      cliapp_message = function(msg) {
        withCallingHandlers(
          cliapp:::cli_server_default(msg),
          message = function(mmsg) {
            class(mmsg) <- c("callr_message", "message", "condition")
            signalCondition(mmsg)
            invokeRestart("muffleMessage")
          }
        )
        invokeRestart("muffleMessage")
      }, {
        cliapp::start_app(theme = cliapp::simple_theme())
        cliapp::cli_h1("Title")
        cliapp::cli_text("This is generated in the {emph subprocess}.")
        "foobar"
      }
    )
  }

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

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

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

  rs$close()
})