New cli_extract_vars for metaprogramming on {cli} strings

NAMESPACE

@@ -96,6 +96,7 @@ export(cli_code)
 export(cli_div)
 export(cli_dl)
 export(cli_end)
+export(cli_extract_vars)
 export(cli_fmt)
 export(cli_format)
 export(cli_format_method)

NEWS.md

@@ -1,5 +1,8 @@
 # cli (development version)
 
+* New `cli_extract_vars()` function to extract variable and function names
+  from cli format strings without evaluating them (#750, @MichaelChirico).
+
 * `cli_progress_bar()` has a new argument `quiet`. If TRUE, then 
   progress bar will be suppressed.
 

R/cli-errors.R

@@ -19,7 +19,7 @@ cli_error <- function(
   if (length(.data)) {
     cnd[names(.data)] <- .data
   }
-  if (length(class)) {
+  if (length(.class)) {
     class(cnd) <- c(.class, class(cnd))
   }
 

R/glue.R

@@ -31,11 +31,22 @@ glue <- function(
     text <- trim(text)
   }
 
+  in_transformer <- FALSE
   f <- function(expr) {
+    in_transformer <<- TRUE
+    on.exit(in_transformer <<- FALSE)
     eval_func <- as.character(.transformer(expr, .envir) %||% character())
   }
 
-  res <- .Call(glue_, text, f, .open, .close, .cli)
+  res <- withCallingHandlers(
+    .Call(glue_, text, f, .open, .close, .cli),
+    error = function(e) {
+      if (!in_transformer) {
+        class(e) <- c("cli_glue_error", "cli_error", class(e))
+        stop(e)
+      }
+    }
+  )
 
   res <- drop_null(res)
   if (any(lengths(res) == 0L)) {

R/inline.R

@@ -283,12 +283,15 @@ clii__inline <- function(app, text, .list) {
 
 inline_regex <- function() "(?s)^[.]([-[:alnum:]_]+)[[:space:]]+(.*)"
 
-make_cmd_transformer <- function(values, .call = NULL) {
+make_cmd_transformer <- function(values, .call = NULL, .eval = TRUE) {
   values$marker <- random_id()
   values$qty <- NA_integer_
   values$num_subst <- 0L
   values$postprocess <- FALSE
   values$pmarkers <- list()
+  if (!.eval) {
+    values$exprs <- expression()
+  }
 
   # These are common because of purrr's default argument names, so we
   # hardcode them es exceptions. They are in packages
@@ -329,6 +332,7 @@ make_cmd_transformer <- function(values, .call = NULL) {
       if (!has_match) {
         throw(cli_error(
           call. = caller,
+          .class = c("cli_style_error", "cli_error"),
           "Invalid cli literal: {.code {{{abbrev(code, 10)}}}} starts with a dot.",
           "i" = "Interpreted literals must not start with a dot in cli >= 3.4.0.",
           "i" = paste(
@@ -362,15 +366,21 @@ make_cmd_transformer <- function(values, .call = NULL) {
       expr <- parse(text = code, keep.source = FALSE) %??%
         cli_error(
           call. = caller,
+          .class = c("cli_parse_error", "cli_error"),
           "Could not parse cli {.code {{}}} expression:
            {.code {abbrev(code, 20)}}."
         )
-      res <- eval(expr, envir = envir) %??%
-        cli_error(
-          call. = caller,
-          "Could not evaluate cli {.code {{}}} expression:
-           {.code {abbrev(code, 20)}}."
-        )
+      if (.eval) {
+        res <- eval(expr, envir = envir) %??%
+          cli_error(
+            call. = caller,
+            "Could not evaluate cli {.code {{}}} expression:
+             {.code {abbrev(code, 20)}}."
+          )
+      } else {
+        values$exprs <- c(values$exprs, expr)
+        res <- 1L
+      }
 
       id <- paste0("v", length(values))
       values[[id]] <- res
@@ -381,10 +391,16 @@ make_cmd_transformer <- function(values, .call = NULL) {
   }
 }
 
-glue_cmd <- function(..., .envir, .call = sys.call(-1), .trim = TRUE) {
+glue_cmd <- function(
+  ...,
+  .envir,
+  .call = sys.call(-1),
+  .trim = TRUE,
+  .eval = TRUE
+) {
   str <- paste0(unlist(list(...), use.names = FALSE), collapse = "")
   values <- new.env(parent = emptyenv())
-  transformer <- make_cmd_transformer(values, .call = .call)
+  transformer <- make_cmd_transformer(values, .call = .call, .eval = .eval)
   pstr <- glue(
     str,
     .envir = .envir,
@@ -398,6 +414,55 @@ glue_cmd <- function(..., .envir, .call = sys.call(-1), .trim = TRUE) {
   )
 }
 
+#' Extract variable and function names from cli format strings
+#'
+#' Parses cli [inline markup][inline-markup] and glue substitutions in
+#' `text` without evaluating the embedded R expressions, returning the
+#' symbol names referenced inside `{...}` interpolation blocks via
+#' [base::all.vars()].
+#'
+#' Static analysis tools (such as `lintr::object_usage_linter()`) can use
+#' `cli_extract_vars()` to discover variables and functions referenced in
+#' cli calls. Malformed cli strings or R expressions signal an error of
+#' class `"cli_error"` (with subclasses `"cli_glue_error"`,
+#' `"cli_style_error"`, `"cli_parse_error"`, and
+#' `"cli_pluralization_error"`), so static analysis callers should wrap
+#' `cli_extract_vars()` in [base::tryCatch()].
+#'
+#' If `text` is a named character vector (for example, as passed to
+#' [cli_dl()], [cli_li()], [cli_bullets()], or [cli_abort()]), both
+#' `names(text)` and `text` are inspected.
+#'
+#' @param text Character vector of cli format strings.
+#' @param functions Logical scalar passed to [base::all.vars()]: whether to
+#'   include function names in addition to variable names. Defaults to
+#'   `TRUE`.
+#' @param unique Logical scalar passed to [base::all.vars()]: whether to
+#'   deduplicate extracted symbol names. Defaults to `TRUE`.
+#' @return Character vector of extracted symbol names.
+#'
+#' @export
+#' @examples
+#' cli_extract_vars(
+#'   "{.arg x} has {length(x)} elements, but it should be {.emph {length(y)}}"
+#' )
+#' cli_extract_vars(
+#'   "{.arg x} has {length(x)} elements, but it should be {.emph {length(y)}}",
+#'   functions = FALSE
+#' )
+
+cli_extract_vars <- function(text, functions = TRUE, unique = TRUE) {
+  if (length(text) == 0L) {
+    return(character())
+  }
+  text <- c(names(text), as.character(text))
+  call <- sys.call()
+  exprs <- lapply(text, function(x) {
+    glue_cmd(x, .envir = emptyenv(), .call = call, .eval = FALSE)$values$exprs
+  })
+  all.vars(do.call(c, exprs), functions = functions, unique = unique)
+}
+
 glue_no_cmd <- function(...) {
   str <- paste0(unlist(list(...), use.names = FALSE), collapse = "")
   values <- new.env(parent = emptyenv())

R/pluralize.R

@@ -83,6 +83,12 @@ parse_plural <- function(code, values) {
   }
 }
 
+stop_pluralization <- function(..., call. = sys.call(-1)) {
+  cnd <- simpleError(.makeMessage(...), call = call.)
+  class(cnd) <- c("cli_pluralization_error", "cli_error", class(cnd))
+  stop(cnd)
+}
+
 process_plural <- function(qty, code) {
   parts <- strsplit(str_tail(code), "/", fixed = TRUE)[[1]]
   if (last_character(code) == "/") {
@@ -101,7 +107,7 @@ process_plural <- function(qty, code) {
       parts[3]
     }
   } else {
-    stop("Invalid pluralization directive: `", code, "`")
+    stop_pluralization("Invalid pluralization directive: `", code, "`")
   }
 }
 
@@ -110,10 +116,10 @@ post_process_plurals <- function(str, values) {
     return(str)
   }
   if (values$num_subst == 0) {
-    stop("Cannot pluralize without a quantity")
+    stop_pluralization("Cannot pluralize without a quantity")
   }
   if (values$num_subst != 1) {
-    stop("Multiple quantities for pluralization")
+    stop_pluralization("Multiple quantities for pluralization")
   }
 
   qty <- make_quantity(values$qty)

_pkgdown.yml

@@ -230,6 +230,7 @@ reference:
   - cat_bullet
   - cli-config
   - cli_debug_doc
+  - cli_extract_vars
   - cli_fmt
   - cat_line
   - cat_print

tests/testthat/_snaps/substitution.md

@@ -5,14 +5,14 @@
     Condition
       Error:
       ! ! Could not evaluate cli `{}` expression: ` asdfasdfasdf `.
-      Caused by error in `eval(expr, envir = envir)` at inline.R:368:<col>:
+      Caused by error in `eval(expr, envir = envir)` at inline.R:374:<col>:
       ! object 'asdfasdfasdf' not found
     Code
       cli_text("foo {cmd {dsfsdf()}}")
     Condition
       Error:
       ! ! Could not parse cli `{}` expression: `cmd {dsfsdf()}`.
-      Caused by error in `parse(text = code, keep.source = FALSE)` at inline.R:362:<col>:
+      Caused by error in `parse(text = code, keep.source = FALSE)` at inline.R:366:<col>:
       ! <text>:1:5: unexpected '{'
       1: cmd {
               ^