diff --git a/.Rbuildignore b/.Rbuildignore index a528b92b..3e691e96 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -38,3 +38,4 @@ ^[\.]?air\.toml$ ^\.vscode$ ^[.]cache$ +^CLAUDE.md$" diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 00000000..49cbf6cd --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,74 @@ +# CLAUDE.md + +This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. + +## What this is + +`cli` is an R package for building command line interfaces: semantic elements (headings, lists, alerts, paragraphs), CSS-like theming, ANSI colors/styles, progress bars, rich error/warning messages, and pluralization. It has both an R layer and a C layer (`src/`), and is a foundational dependency for much of the R ecosystem, so backward compatibility and correctness matter a lot. + +## Development commands + +This package has compiled C code, so you must recompile after editing anything in `src/`. Use the `uncovr` helpers (they handle compilation + instrumentation): + +```r +uncovr::reload() # compile C code and (re)load the package +uncovr::test() # run the test suite (testthat, edition 3) +uncovr::document() # regenerate roxygen2 docs (man/*.Rd and NAMESPACE) +``` + +To run R CMD check (set `NOT_CRAN` so tests that are skipped on CRAN still run): + +```r +withr::with_envvar(c(NOT_CRAN = "true"), rcmdcheck::rcmdcheck()) +``` + +Running a single test file or a single test: + +```r +uncovr::test(filter = "keypress") # run tests/testthat/test-keypress.R +``` + +Code is formatted with [air](https://posit-dev.github.io/air/) (see `air.toml`). A GitHub Action suggests formatting fixes on PRs. + +## Architecture + +### R / C split + +The semantic CLI, theming, and most formatting logic live in R (`R/`). Performance-sensitive and OS-level primitives live in C (`src/`): + +- ANSI/UTF-8/string-width handling (`ansi.c`, `utf8.c`, `width.c`-related, `charwidth.h`) +- the VT100 parser (`vt.c`, `vtparse*.c`) used to interpret/strip terminal control sequences +- the progress bar engine (`progress.c`, `progress-altrep.c`) — progress state is shared with R via an ALTREP +- keypress reading (`keypress*.c`, split into `keypress-unix.c` / `keypress-win.c`) +- hashing (`md5.c`, `sha1.c`, `sha256.c`, `xxhash*.c`) and `diff.c`, `glue.c` + +C entry points are registered in `src/init.c` via `.Call`. `RCC(...)` registers functions that use the **cleancall** mechanism (`cleancall.c/.h`) for C-level resource cleanup; plain `R_CallMethodDef` entries (e.g. `cli_keypress`) are registered the normal way. When you add a C function callable from R, register it in `init.c`. Header `inst/include/cli/progress.h` is the public C API other packages link against — treat changes to it as part of the package's external contract. + +### The "app" model + +CLI output flows through a stack of **app** objects, not direct printing. `start_app()` / `stop_app()` / `default_app()` (in `R/app.R`) manage a global app stack in `cliappenv$stack`. An app (`R/cliapp.R`) is a closure-based object (via `new_class`) holding the active themes, container stack, and output connection. The user-facing `cli_*` functions (e.g. `cli_h1`, `cli_alert`, `cli_ul`) emit a *condition* (a `cliMessage`) that the default app formats and prints. The internal counterparts are named `clii_*` (app methods) and `clii__*` (lower-level helpers). + +`cli({ ... })` (in `R/cli.R`) records multiple `cli_*` calls and emits them as one combined message, using the `cli.record` option and the `cli_recorded` registry. Themes are CSS-like selector/style rules matched against the container tree (`R/themes.R`, `R/simple-theme.R`, `R/containers.R`). + +### Inline markup and glue + +cli text supports interpreted string literals via glue, plus inline classes like `{.url ...}`, `{.file ...}`, `{.emph ...}`. Inline span handling is in `R/inline.R`; glue integration in `R/glue.R`; pluralization (`{?s}`, `{qty()}`) in `R/pluralize.R`. + +### Loading & global state + +`R/onload.R` sets up package-level mutable state in the `clienv` environment (PID, timers, progress/status registries, load time). Note the `.onLoad` cursor-restore finalizer and task callback. Timing is configurable via env vars (`CLI_TICK_TIME`, `CLI_SPEED_TIME`, `R_CLI_HIDE_CURSOR`). + +## Testing conventions + +- testthat edition 3 with snapshot tests. Snapshots live in `tests/testthat/_snaps/`. After an intentional output change, review `testthat::snapshot_review()` / accept with `testthat::snapshot_accept()`. +- `tests/testthat/setup.R` flushes gcov coverage data on teardown (`clic__gcov_flush`) and cleans `.gcda` files — this supports the coverage-instrumented test runs. +- `tests/testthat/helper.R` defines capture helpers central to testing output: `capture_msgs()`, `capture_cli_messages()` (catches `cliMessage` conditions), `capt()`, and `local_cli_config()`. Use these rather than asserting on raw printed output. +- `progresstest/` and `progresstestcpp/` are small embedded test packages exercising the C progress API from C and C++. +- Many tests are environment-sensitive (terminal width, number of ANSI colors, UTF-8 support, TTY detection). Tests pin these via `local_cli_config()` / options so they are reproducible off a real terminal. + +## Documentation + +- Roxygen2 (version 8.0.0) generates `man/` and `NAMESPACE` — never edit those by hand; edit the roxygen comments and run `uncovr::document()`. +- Many `.Rd` examples use **asciicast** ` ```{asciicast ...} ` code chunks (rendered to SVG for the website) rather than plain `\examples`. Match the surrounding style when adding examples. +- `README.md` is generated from `README.Rmd` (via `make` / `Makefile`) — edit the `.Rmd`. +- Update `NEWS.md` for user-facing changes. diff --git a/NEWS.md b/NEWS.md index e348551f..e1892c53 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,5 +1,11 @@ # cli (development version) +* `keypress()` improvements: + - `timeout` argument to wait at most a given number of seconds for a + key press. + - Blocking reads are now interruptible. + - Unicode characters (including emoji) are now read correctly on Windows. + * `ansi_strip()` now also removes generic OSC sequences such as the `\033]0;...\a` window-title sequence emitted by `Rscript.exe` on Windows. diff --git a/R/keypress.R b/R/keypress.R index b2fe94ae..7ab41c37 100644 --- a/R/keypress.R +++ b/R/keypress.R @@ -14,27 +14,45 @@ #' #' @param block Whether to wait for a key press, if there is none #' available now. -#' @return The key pressed, a character scalar. For non-blocking reads -#' `NA` is returned if no keys are available. +#' @param timeout Maximum number of seconds to wait for a key press, if +#' `block` is `TRUE`. The default `Inf` waits indefinitely. If no key +#' is pressed before the timeout expires, `NA` is returned. Ignored +#' for non-blocking reads (`block = FALSE`). The wait is interruptible +#' regardless of the timeout. +#' @return The key pressed, a character scalar. `NA` is returned if no +#' key is available: for non-blocking reads, or when a blocking read +#' times out. #' #' @family keypress function #' @export #' @examplesIf FALSE #' x <- keypress() #' cat("You pressed key", x, "\n") +#' +#' # Wait at most five seconds for a key press +#' x <- keypress(timeout = 5) +#' if (is.na(x)) cat("No key pressed\n") else cat("You pressed key", x, "\n") -keypress <- function(block = TRUE) { +keypress <- function(block = TRUE, timeout = Inf) { if (!has_keypress_support()) { stop("Your platform/terminal does not support `keypress()`.") } block <- as.logical(block) - if (length(block) != 1) { + if (length(block) != 1 || is.na(block)) { stop("'block' must be a logical scalar") } - ret <- .Call(cli_keypress, block) + timeout <- as.double(timeout) + if (length(timeout) != 1 || is.na(timeout) || timeout < 0) { + stop("'timeout' must be a non-negative number of seconds") + } + ret <- call_with_cleanup(cli_keypress, block, timeout) if (ret == "none") NA_character_ else ret } +call_with_cleanup <- function(ptr, ...) { + .Call(cleancall_call, pairlist(ptr, ...), parent.frame()) +} + #' Check if the current platform/terminal supports reading #' single keys. #' @@ -51,7 +69,7 @@ keypress <- function(block = TRUE) { #' * Others. #' #' @return Whether there is support for waiting for individual -#' keypressses. +#' keypresses. #' #' @family keypress function #' @export diff --git a/man/ansi_html.Rd b/man/ansi_html.Rd index dd163a7e..7e294401 100644 --- a/man/ansi_html.Rd +++ b/man/ansi_html.Rd @@ -22,7 +22,7 @@ Character vector of HTML. Convert ANSI styled text to HTML } \examples{ -\dontshow{if (cli:::has_packages(c("htmltools", "withr"))) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (cli:::has_packages(c("htmltools", "withr"))) withAutoprint(\{ # examplesIf} ## Syntax highlight the source code of an R function with ANSI tags, ## and export it to a HTML file. code <- withr::with_options( diff --git a/man/ansi_palettes.Rd b/man/ansi_palettes.Rd index ae8c9ee5..3bf8906c 100644 --- a/man/ansi_palettes.Rd +++ b/man/ansi_palettes.Rd @@ -1,6 +1,5 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/ansi-palette.R -\docType{data} \name{truecolor} \alias{truecolor} \alias{ansi_palettes} diff --git a/man/cli-config.Rd b/man/cli-config.Rd index 5ffb4942..705b1cdb 100644 --- a/man/cli-config.Rd +++ b/man/cli-config.Rd @@ -112,6 +112,14 @@ in Emacs. Once https://github.com/emacs-ess/ESS/pull/1178 is merged, ESS will set this automatically. } +\subsection{\code{R_CLI_ANSI}}{ + +Set to \code{true} (case insensitive) to assume a terminal that supports ANSI +control sequences. Set to \code{false} (case insensitive) to assume a non-ANSI +terminal. The \code{cli.ansi} option, if set, takes precedence. +See \code{\link[=is_ansi_tty]{is_ansi_tty()}}. +} + \subsection{\code{R_CLI_DYNAMIC}}{ Set to \code{true}, \code{TRUE} or \code{True} to assume a dynamic terminal, that supports \verb{\\r}. @@ -130,9 +138,9 @@ See \code{\link[=num_ansi_colors]{num_ansi_colors()}}. \subsection{User facing options}{ \subsection{\code{cli.ansi}}{ -Set to \code{true}, \code{TRUE} or \code{True} to assume a terminal that supports ANSI -control sequences. -Set to anything else to assume a non-ANSI terminal. +Set to \code{TRUE} to assume a terminal that supports ANSI control sequences. +Set to \code{FALSE} to assume a non-ANSI terminal. This option takes precedence +over the \code{R_CLI_ANSI} environment variable. See \code{\link[=is_ansi_tty]{is_ansi_tty()}}. } @@ -292,6 +300,15 @@ Progress handlers to force, ignoring handlers set in See \code{\link[=cli_progress_builtin_handlers]{cli_progress_builtin_handlers()}}. } +\subsection{\code{cli.progress_multiline}}{ + +Whether to render multiple concurrent progress bars on separate lines on +ANSI-capable terminals. Defaults to \code{TRUE}. Set to \code{FALSE} to show only the +most recently updated bar on a single line. Has no effect on non-ANSI +terminals, which always show a single bar. +See \code{\link[=is_ansi_tty]{is_ansi_tty()}} and \code{\link[=cli_progress_bar]{cli_progress_bar()}}. +} + \subsection{\code{cli.progress_say_args}}{ Command line arguments for the \code{say} progress handlers. diff --git a/man/has_keypress_support.Rd b/man/has_keypress_support.Rd index d17fef0d..4a54deb4 100644 --- a/man/has_keypress_support.Rd +++ b/man/has_keypress_support.Rd @@ -9,7 +9,7 @@ has_keypress_support() } \value{ Whether there is support for waiting for individual -keypressses. +keypresses. } \description{ Check if the current platform/terminal supports reading diff --git a/man/is_ansi_tty.Rd b/man/is_ansi_tty.Rd index c610abc6..d37c53f4 100644 --- a/man/is_ansi_tty.Rd +++ b/man/is_ansi_tty.Rd @@ -16,17 +16,28 @@ interactive and there are no sinks, otherwise it will select \code{stderr()}.} \code{TRUE} or \code{FALSE}. } \description{ -We check that all of the following hold: +The detection mechanism is as follows: +\enumerate{ +\item If the \code{cli.ansi} option is set to \code{TRUE}, \code{TRUE} is returned. +\item If the \code{cli.ansi} option is set to \code{FALSE}, \code{FALSE} is returned. +\item If the \code{R_CLI_ANSI} environment variable is set to \code{true} (case +insensitive), then \code{TRUE} is returned. +\item If \code{R_CLI_ANSI} is not empty and set to \code{false} (case insensitive), +\code{FALSE} is returned. +\item If R is running in the Positron console, then \code{TRUE} is returned, +with 'positron' added as a name. Positron does not currently support +hide/show cursor, scrolling regions, inserting and deleting lines +and the alternate screen buffer. +\item Otherwise we autodetect, by checking that all of the following hold: \itemize{ -\item The stream is a terminal. -\item The platform is Unix. +\item The stream is a terminal, see \code{\link[base:isatty]{base::isatty()}}. \item R is not running inside R.app (the macOS GUI). -\item R is not running inside RStudio. \item R is not running inside Emacs. \item The terminal is not "dumb". \item \code{stream} is either the standard output or the standard error stream. } } +} \examples{ is_ansi_tty() } diff --git a/man/keypress.Rd b/man/keypress.Rd index 7764c030..8e45faf1 100644 --- a/man/keypress.Rd +++ b/man/keypress.Rd @@ -4,15 +4,22 @@ \alias{keypress} \title{Read a single keypress at the terminal} \usage{ -keypress(block = TRUE) +keypress(block = TRUE, timeout = Inf) } \arguments{ \item{block}{Whether to wait for a key press, if there is none available now.} + +\item{timeout}{Maximum number of seconds to wait for a key press, if +\code{block} is \code{TRUE}. The default \code{Inf} waits indefinitely. If no key +is pressed before the timeout expires, \code{NA} is returned. Ignored +for non-blocking reads (\code{block = FALSE}). The wait is interruptible +regardless of the timeout.} } \value{ -The key pressed, a character scalar. For non-blocking reads -\code{NA} is returned if no keys are available. +The key pressed, a character scalar. \code{NA} is returned if no +key is available: for non-blocking reads, or when a blocking read +times out. } \description{ It currently only works at Linux/Unix and OSX terminals, @@ -31,9 +38,13 @@ The following special keys are supported: } } \examples{ -\dontshow{if (FALSE) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (FALSE) withAutoprint(\{ # examplesIf} x <- keypress() cat("You pressed key", x, "\n") + +# Wait at most five seconds for a key press +x <- keypress(timeout = 5) +if (is.na(x)) cat("No key pressed\n") else cat("You pressed key", x, "\n") \dontshow{\}) # examplesIf} } \seealso{ diff --git a/man/pluralize.Rd b/man/pluralize.Rd index 34894b4c..ff7764ed 100644 --- a/man/pluralize.Rd +++ b/man/pluralize.Rd @@ -26,7 +26,7 @@ See \link{pluralization} and some examples below. You need to install the glue package to use this function. } \examples{ -\dontshow{if (requireNamespace("glue", quietly = TRUE)) (if (getRversion() >= "3.4") withAutoprint else force)(\{ # examplesIf} +\dontshow{if (requireNamespace("glue", quietly = TRUE)) withAutoprint(\{ # examplesIf} # Regular plurals nfile <- 0; pluralize("Found {nfile} file{?s}.") nfile <- 1; pluralize("Found {nfile} file{?s}.") diff --git a/src/init.c b/src/init.c index 249d9159..e519b830 100644 --- a/src/init.c +++ b/src/init.c @@ -93,7 +93,7 @@ static const R_CallMethodDef callMethods[] = { { "clic_vt_output", (DL_FUNC) clic_vt_output, 3 }, - { "cli_keypress", (DL_FUNC) cli_keypress, 1 }, + { "cli_keypress", (DL_FUNC) cli_keypress, 2 }, { NULL, NULL, 0 } }; diff --git a/src/keypress-internal.h b/src/keypress-internal.h new file mode 100644 index 00000000..d1641df6 --- /dev/null +++ b/src/keypress-internal.h @@ -0,0 +1,12 @@ + +#ifndef KEYPRESS_INTERNAL_H +#define KEYPRESS_INTERNAL_H + +SEXP save_term_status(void); +SEXP restore_term_status(void); +SEXP set_term_echo(SEXP s_echo); + +SEXP test_single_char(SEXP s_bytes); +SEXP test_function_key(SEXP s_bytes); + +#endif diff --git a/src/keypress-unix.c b/src/keypress-unix.c index 980cab2f..51f8702e 100644 --- a/src/keypress-unix.c +++ b/src/keypress-unix.c @@ -6,10 +6,23 @@ void keypress_unix_dummy(void) { } #include "errors.h" #include "keypress.h" +#include "keypress-internal.h" +#include "cleancall.h" #include #include #include #include +#include +#include +#include +#include /* R_CheckUserInterrupt */ + +/* Milliseconds since some unspecified epoch, used to track timeouts. */ +static double keypress_now_ms(void) { + struct timeval tv; + gettimeofday(&tv, NULL); + return (double) tv.tv_sec * 1000.0 + (double) tv.tv_usec / 1000.0; +} keypress_key_t single_char(const char *buf) { @@ -145,7 +158,55 @@ keypress_key_t function_key(const char *buf, size_t buf_size) { return keypress_special(KEYPRESS_UNKNOWN); } -keypress_key_t keypress_read(int block) { +static struct termios orig_term = { 0 }; + +SEXP save_term_status(void) { + if (tcgetattr(0, &orig_term) < 0) { + R_THROW_SYSTEM_ERROR("Cannot query terminal flags"); + } + return R_NilValue; +} + +SEXP restore_term_status(void) { + if (tcsetattr(0, TCSANOW, &orig_term) < 0) { + R_THROW_SYSTEM_ERROR("Cannot restore terminal flags"); + } + return R_NilValue; +} + +SEXP set_term_echo(SEXP s_echo) { + int echo = LOGICAL(s_echo)[0]; + + struct termios term = { 0 }; + if (tcgetattr(0, &term) < 0) { + R_THROW_SYSTEM_ERROR("Cannot query terminal flags"); + } + + if (echo == 0) term.c_lflag &= ~ECHO; + else term.c_lflag |= ECHO; + + if (tcsetattr(0, TCSANOW, &term) < 0) { + R_THROW_SYSTEM_ERROR("Cannot query terminal flags"); + } + + return R_NilValue; +} + +static struct keypress_term_state { + struct termios term; + int flags; + int active; +} keypress_state = { { 0 }, 0, 0 }; + +static void keypress_restore(void *data) { + struct keypress_term_state *st = data; + if (!st->active) return; + st->active = 0; + fcntl(0, F_SETFL, st->flags); + tcsetattr(0, TCSADRAIN, &st->term); +} + +keypress_key_t keypress_read_timeout(int block, double timeout) { char buf[11] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; struct termios term = { 0 }; @@ -155,9 +216,11 @@ keypress_key_t keypress_read(int block) { R_THROW_SYSTEM_ERROR("Cannot query terminal flags"); } - tcflag_t term_flags = term.c_lflag; - int term_vmin = term.c_cc[VMIN]; - int term_vtime = term.c_cc[VTIME]; + /* Original state to restore */ + keypress_state.term = term; + keypress_state.flags = flags; + keypress_state.active = 1; + r_call_on_exit(keypress_restore, &keypress_state); term.c_lflag &= ~ICANON; term.c_lflag &= ~ECHO; @@ -168,21 +231,36 @@ keypress_key_t keypress_read(int block) { R_THROW_SYSTEM_ERROR("Cannot set canonical mode"); } - if (! block) { + if (block) { + /* Interruptible read, optionally bounded by a timeout. We poll in + chunks of at most 100ms so we can check for an R user interrupt + between waits; an infinite timeout (negative or non-finite) just + keeps polling forever. */ + struct pollfd pfd = { 0, POLLIN, 0 }; + int infinite = timeout < 0 || !R_FINITE(timeout); + double deadline = infinite ? 0 : keypress_now_ms() + timeout * 1000.0; + for (;;) { + int wait_ms = 100; + if (!infinite) { + double remaining = deadline - keypress_now_ms(); + /* Timed out: the registered cleanup restores the terminal. */ + if (remaining <= 0) return keypress_special(KEYPRESS_NONE); + if (remaining < wait_ms) wait_ms = (int) remaining; + } + int ret = poll(&pfd, 1, wait_ms); + if (ret > 0) break; + if (ret < 0 && errno != EINTR) { + R_THROW_SYSTEM_ERROR("Cannot poll terminal"); + } + R_CheckUserInterrupt(); + } + } else { if (fcntl(0, F_SETFL, flags | O_NONBLOCK) == -1) { R_THROW_SYSTEM_ERROR("Cannot set terminal to non-blocking"); } } if (read(0, buf, 1) < 0) { - if (fcntl(0, F_SETFL, flags) == -1) { - R_THROW_SYSTEM_ERROR("Cannot set terminal flags"); - } - term.c_lflag = term_flags; - term.c_cc[VMIN] = term_vmin; - term.c_cc[VTIME] = term_vtime; - tcsetattr(0, TCSADRAIN, &term); - if (block) { R_THROW_SYSTEM_ERROR("Cannot read key"); } else { @@ -244,18 +322,6 @@ keypress_key_t keypress_read(int block) { } } - if (fcntl(0, F_SETFL, flags) == -1) { - R_THROW_SYSTEM_ERROR("Cannot set terminal flags"); - } - - term.c_lflag = term_flags; - term.c_cc[VMIN] = term_vmin; - term.c_cc[VTIME] = term_vtime; - - if (tcsetattr(0, TCSADRAIN, &term) < 0) { - R_THROW_SYSTEM_ERROR("Cannot reset terminal flags"); - } - if (buf[0] == '\033') { /* Some excape sequence */ return function_key(buf, sizeof(buf)); @@ -265,4 +331,33 @@ keypress_key_t keypress_read(int block) { } } +static SEXP key_to_sexp(keypress_key_t key) { + if (key.code == KEYPRESS_CHAR) { + return ScalarString(mkCharCE(key.utf8, CE_UTF8)); + } else { + return ScalarString(mkCharCE(keypress_key_names[key.code], CE_UTF8)); + } +} + +SEXP test_single_char(SEXP s_bytes) { + if (TYPEOF(s_bytes) != RAWSXP || XLENGTH(s_bytes) < 1) { + error("'bytes' must be a raw vector of length >= 1"); + } + char buf[2] = { 0, 0 }; + buf[0] = (char) RAW(s_bytes)[0]; + return key_to_sexp(single_char(buf)); +} + +SEXP test_function_key(SEXP s_bytes) { + if (TYPEOF(s_bytes) != RAWSXP) { + error("'bytes' must be a raw vector"); + } + char buf[11] = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 }; + buf[0] = '\033'; + R_xlen_t n = XLENGTH(s_bytes); + if (n > 9) n = 9; + if (n > 0) memcpy(buf + 1, RAW(s_bytes), (size_t) n); + return key_to_sexp(function_key(buf, sizeof(buf))); +} + #endif diff --git a/src/keypress-win.c b/src/keypress-win.c index 52a714e0..2ac4c0c0 100644 --- a/src/keypress-win.c +++ b/src/keypress-win.c @@ -6,7 +6,9 @@ void keypress_win_dummy(void) { } #include "errors.h" #include "keypress.h" +#include "keypress-internal.h" #include +#include /* R_CheckUserInterrupt */ static HANDLE console_in, console_out; @@ -32,26 +34,80 @@ static int disableRawMode(void) { return 0; } -keypress_key_t getWinChar(int block) { +// Below not needed for Windows terminal + +SEXP save_term_status(void) { + return R_NilValue; +} + +SEXP restore_term_status(void) { + return R_NilValue; +} + +SEXP set_term_echo(SEXP s_echo) { + return R_NilValue; +} + +SEXP test_single_char(SEXP s_bytes) { + error("test_single_char is not supported on Windows"); + return R_NilValue; +} + +SEXP test_function_key(SEXP s_bytes) { + error("test_function_key is not supported on Windows"); + return R_NilValue; +} + +keypress_key_t getWinChar(int block, double timeout) { INPUT_RECORD rec; DWORD count; - char buf[2] = { 0, 0 }; + DWORD waitres; + int infinite = timeout < 0 || !R_FINITE(timeout); + ULONGLONG deadline = + infinite ? 0 : GetTickCount64() + (ULONGLONG)(timeout * 1000.0); + char buf[KEYPRESS_UTF8_BUFFER_SIZE + 1] = { 0 }; + WCHAR wbuf[2]; + int wlen; int chr; + /* Holds a pending UTF-16 high surrogate between two key events, since + characters outside the BMP (e.g. emoji) arrive as two WCHARs. */ + static WCHAR high_surrogate = 0; - for (;; Sleep(10)) { + for (;;) { GetNumberOfConsoleInputEvents(console_in, &count); - if ((count == 0) && (block == NON_BLOCKING)) { - return keypress_special(KEYPRESS_NONE); + if (count == 0) { + if (block == NON_BLOCKING) { + return keypress_special(KEYPRESS_NONE); + } + /* Interruptible wait, the Windows equivalent of poll() on Unix. + The console input handle is signalled when input is available. + We wait in chunks of at most 100ms so we can check for an R user + interrupt (e.g. Ctrl+C / Esc in RStudio) between waits, while + honouring the overall timeout (if any). */ + DWORD wait_ms = 100; + if (!infinite) { + ULONGLONG now = GetTickCount64(); + if (now >= deadline) return keypress_special(KEYPRESS_NONE); + ULONGLONG remaining = deadline - now; + if (remaining < wait_ms) wait_ms = (DWORD) remaining; + } + waitres = WaitForSingleObject(console_in, wait_ms); + if (waitres == WAIT_TIMEOUT) { + R_CheckUserInterrupt(); + continue; + } else if (waitres == WAIT_FAILED) { + R_THROW_SYSTEM_ERROR("Cannot wait for console input"); + } } - if (! ReadConsoleInputA(console_in, &rec, 1, &count)) { + if (! ReadConsoleInputW(console_in, &rec, 1, &count)) { R_THROW_SYSTEM_ERROR("Cannot read from console"); } if (rec.EventType != KEY_EVENT) continue; if (! rec.Event.KeyEvent.bKeyDown) continue; - buf[0] = chr = rec.Event.KeyEvent.uChar.AsciiChar; + chr = rec.Event.KeyEvent.uChar.UnicodeChar; switch (rec.Event.KeyEvent.wVirtualKeyCode) { @@ -100,7 +156,28 @@ keypress_key_t getWinChar(int block) { case 21: return keypress_special(KEYPRESS_CTRL_U); case 22: return keypress_special(KEYPRESS_CTRL_W); } - } else if (buf[0]) { + } else if (chr) { + /* Combine surrogate pairs into a single code point. A high + surrogate is buffered until its low surrogate arrives. */ + if (chr >= 0xD800 && chr <= 0xDBFF) { + high_surrogate = (WCHAR) chr; + continue; + } + if (chr >= 0xDC00 && chr <= 0xDFFF) { + if (!high_surrogate) continue; /* lone low surrogate, ignore */ + wbuf[0] = high_surrogate; + wbuf[1] = (WCHAR) chr; + wlen = 2; + high_surrogate = 0; + } else { + high_surrogate = 0; + wbuf[0] = (WCHAR) chr; + wlen = 1; + } + count = WideCharToMultiByte( + CP_UTF8, 0, wbuf, wlen, buf, KEYPRESS_UTF8_BUFFER_SIZE, NULL, NULL); + if (count == 0) continue; /* conversion failed, skip */ + buf[count] = '\0'; return keypress_utf8(buf); } } @@ -108,7 +185,7 @@ keypress_key_t getWinChar(int block) { } } -keypress_key_t keypress_read(int block) { +keypress_key_t keypress_read_timeout(int block, double timeout) { keypress_key_t res; @@ -120,7 +197,7 @@ keypress_key_t keypress_read(int block) { R_THROW_SYSTEM_ERROR("Cannot query console information"); } - res = getWinChar(block); + res = getWinChar(block, timeout); disableRawMode(); diff --git a/src/keypress.c b/src/keypress.c index 543af8d5..bbb71b1b 100644 --- a/src/keypress.c +++ b/src/keypress.c @@ -71,10 +71,17 @@ keypress_key_t keypress_utf8(const char *buf) { return result; } -SEXP cli_keypress(SEXP s_block) { +/* Back-compatible entry point: block forever (or return immediately for a + non-blocking read). New code should use keypress_read_timeout(). */ +keypress_key_t keypress_read(int block) { + return keypress_read_timeout(block, -1.0); +} + +SEXP cli_keypress(SEXP s_block, SEXP s_timeout) { SEXP result = NULL; int block = LOGICAL(s_block)[0]; - keypress_key_t key = keypress_read(block); + double timeout = REAL(s_timeout)[0]; + keypress_key_t key = keypress_read_timeout(block, timeout); if (key.code == KEYPRESS_CHAR) { return ScalarString(mkCharCE(key.utf8, CE_UTF8)); diff --git a/src/keypress.h b/src/keypress.h index 0b49c119..f5d92c0a 100644 --- a/src/keypress.h +++ b/src/keypress.h @@ -64,7 +64,7 @@ #define KEYPRESS_NAME_SIZE 43 /* The longest UTF8 character in bytes */ -#define KEYPRESS_UTF8_BUFFER_SIZE 4 +#define KEYPRESS_UTF8_BUFFER_SIZE 8 typedef struct { int code; @@ -73,11 +73,12 @@ typedef struct { } keypress_key_t; keypress_key_t keypress_read(int block); +keypress_key_t keypress_read_timeout(int block, double timeout); keypress_key_t keypress_special(int key); keypress_key_t keypress_utf8(const char *buf); -SEXP cli_keypress(SEXP s_block); +SEXP cli_keypress(SEXP s_block, SEXP s_timeout); extern const char *keypress_key_names[KEYPRESS_NAME_SIZE]; diff --git a/tests/testthat/test-keypress.R b/tests/testthat/test-keypress.R index e1297c40..4d6eb705 100644 --- a/tests/testthat/test-keypress.R +++ b/tests/testthat/test-keypress.R @@ -102,3 +102,90 @@ test_that("nonblocking", { cat(p$read_output()) }) }) + +# Wait for a marker to appear in a pty process's output, or time out. +keypress_wait_for <- function(p, marker, timeout = 10) { + strip_ansi <- function(x) { + gsub("\033(?:\\[[0-9;?]*[A-Za-z]|\\][^\007]*\007)", "", x, perl = TRUE) + } + out <- "" + deadline <- Sys.time() + timeout + while ( + Sys.time() < deadline && !grepl(marker, strip_ansi(out), fixed = TRUE) + ) { + p$poll_io(200) + out <- paste0(out, p$read_output()) + } + strip_ansi(out) +} + +test_that("keypress() times out", { + skip_on_cran() + skip_on_os("windows") + + opts <- callr::r_process_options( + func = function() { + # Make sure has_keypress_support() is happy in the child, and stop + # cli from writing cursor-control sequences to the pty (otherwise the + # child can block on the tty write and never exit). + Sys.setenv(TERM = "xterm", R_CLI_HIDE_CURSOR = "false") + cat("READY\n") + flush(stdout()) + t0 <- Sys.time() + res <- cli::keypress(timeout = 1) + dt <- as.numeric(Sys.time() - t0, units = "secs") + list(res = res, elapsed = dt) + }, + stdout = NULL, + stderr = NULL + ) + opts$extra$pty <- TRUE + + p <- callr::r_process$new(opts) + on.exit(p$kill(), add = TRUE) + + expect_match(keypress_wait_for(p, "READY"), "READY", fixed = TRUE) + + # We never press a key, so keypress() should return NA on its own after + # roughly one second, and the process should finish without hanging. + p$wait(timeout = 5000) + expect_false(p$is_alive()) + res <- p$get_result() + expect_true(is.na(res$res)) + expect_gte(res$elapsed, 1) +}) + +test_that("keypress() is interruptible", { + skip_on_cran() + skip_on_os("windows") + + opts <- callr::r_process_options( + func = function() { + # Make sure has_keypress_support() is happy in the child, and stop + # cli from writing cursor-control sequences to the pty (otherwise the + # child can block on the tty write and never exit). + Sys.setenv(TERM = "xterm", R_CLI_HIDE_CURSOR = "false") + cat("READY\n") + flush(stdout()) + tryCatch(cli::keypress(), interrupt = function(...) "interrupted") + }, + stdout = NULL, + stderr = NULL + ) + opts$extra$pty <- TRUE + + p <- callr::r_process$new(opts) + on.exit(p$kill(), add = TRUE) + + expect_match(keypress_wait_for(p, "READY"), "READY", fixed = TRUE) + + # Give keypress() a moment to enter its poll loop, then interrupt it. + Sys.sleep(0.5) + p$interrupt() + + # The interrupt should be caught and turned into "interrupted", and the + # process should finish on its own (rather than hanging). + p$wait(timeout = 5000) + expect_false(p$is_alive()) + expect_equal(p$get_result(), "interrupted") +})