R/misc.R

In CBTF: Caught by the Fuzz! - A Minimalistic Fuzz-Test Runner

##===========================================================================
##
## Copyright (c) 2025 Marco Colombo
##
## This program is free software: you can redistribute it and/or modify
## it under the terms of the GNU General Public License as published by
## the Free Software Foundation, either version 3 of the License, or
## (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
## GNU General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this program.  If not, see <http://www.gnu.org/licenses/>.
##
##===========================================================================

#' @title Validate that an argument is of the specified class
#'
#' @param arg Argument to validate.
#' @param class A character string for the candidate class or type.
#' @param from Name of the caller function.
#' @param scalar Whether to consider the argument valid only if it's a scalar
#'        value (`FALSE` by default).
#' @param remove_empty Discard empty elements before checking that `arg` is
#'        empty (`FALSE` by default).
#'
#' @return
#' Nothing in case of success, otherwise an error is thrown.
#'
#' @noRd
validate_class <- function(arg, class, from = "fuzz",
                           scalar = FALSE, remove_empty = FALSE) {
  name <- sprintf("'%s'", all.vars(match.call())[1])
  if (missing(arg) || sum(inherits(arg, class)) == 0L ||
      (!is.list(arg) && length(arg) == 1 && is.na(arg))) {
    fuzz_error(name, "should be of class", paste(class, collapse = ", "),
               from = from)
  }
  if (scalar && length(arg) > 1)
    fuzz_error(name, "should be a", class, "scalar", from = from)
  if (remove_empty)
    arg <- arg[nchar(arg) > 0]
  if (length(arg) == 0)
    fuzz_error(name, "is an empty", class, from = from)
}

#' @title Stop with an error message
#'
#' @param ... Strings that are joined together in the error message.
#' @param from Name of the caller function.
#'
#' @noRd
fuzz_error <- function(..., from = "fuzz") {
  stop(do.call(paste, c(sprintf("[%s]", from), list(...))), call. = FALSE)
}

#' @title Check that a function can be fuzzed
#'
#' @param fun Name of the function to validate.
#' @param pkg Name of the package where functions are searched. A `NULL`
#'        value corresponds to the global namespace.
#' @param skip_readline Whether functions containing calls to [readline] should
#'        be considered non-fuzzable (`TRUE` by default).
#'
#' @return
#' In case of failure, a character string containing the reason why the
#' function cannot be fuzzed; otherwise the function itself.
#'
#' @noRd
check_fuzzable <- function(fun, pkg, skip_readline = TRUE) {
  ## attempt to get a function from its name
  fun <- try(if (is.null(pkg)) get(fun)
             else utils::getFromNamespace(fun, pkg),
             silent = TRUE)

  ## skip non-existing names
  if (inherits(fun, "try-error"))
    return(sprintf("Object not found in the %s namespace",
                   if (is.null(pkg)) "global" else sprintf("'%s'", pkg)))

  ## skip non-functions
  if (!is.function(fun))
    return("Not a function")

  ## skip functions accept no arguments
  if (suppressWarnings(length(formals(fun))) == 0 && !is.primitive(fun))
    return("Doesn't accept arguments")

  ## skip functions that wait for user input
  if (skip_readline && contains_readline(fun))
    return("Contains readline()")

  return(fun)
}

#' Generate coloured summary statistics from the results
#'
#' This computes summary statistics from the fuzzing results, prints a
#' message for the overall success or failure, and returns a summary string.
#'
#' @param object An object of class `cbtf`.
#' @param verbose Whether a message on the overall pass or fail of the fuzz
#'        run should be printed out (`TRUE` by default).
#'
#' @return
#' A summary results string formatted with ANSI colour codes.
#'
#' @noRd
compute_summary_stats <- function(object, verbose = TRUE) {
  results <- unlist(lapply(object$runs, function(x) x$res))
  success <- sum(results %in% c("FAIL", "WARN")) == 0
  if (verbose) {
    if (success)
      cli::cli_alert_success(" \U0001F3C3 You didn't get caught by the fuzz!")
    else
      cli::cli_alert_danger(" \U0001F6A8   CAUGHT BY THE FUZZ!   \U0001F6A8")
  }

  stats <- as.list(table(results))
  summary.stats <- paste(tocolour("FAIL", sum(stats$FAIL)),
                         tocolour("WARN", sum(stats$WARN)),
                         tocolour("SKIP", sum(stats$SKIP)),
                         tocolour("OK",   sum(stats$OK), success),
                         sep = " | ")
  paste("[", summary.stats, "]")
}

#' Add colour formatting to a string
#'
#' @param res A character vector with "OK", "SKIP", "WARN" or "FAIL".
#' @param num A numerical value: if it evaluates to a positive finite value
#'        and `colour` is `TRUE`, then the string is coloured. The default
#'        value (`Inf`) implies that colour is applied, but `num` is not
#'        printed out.
#' @param colour A logical value that determines if the colour should be
#'        applied. If `FALSE`, nothing gets coloured independently of `num`.
#'
#' @return
#' A character vector formatted with ANSI colour codes.
#'
#' @noRd
tocolour <- function(res, num = Inf, colour = TRUE) {
  if (num > 0 && colour) {
    cols <- list(FAIL = cli::col_yellow("FAIL"),
                 WARN = cli::col_magenta("WARN"),
                 SKIP = cli::col_blue("SKIP"),
                 OK   = cli::col_green("OK"))
    res <- mapply(function(x) cols[[x]], res)
  }
  paste0(res, if (!is.infinite(num)) sprintf(" %d", num))
}

#' Check if the body of a function contains calls to readline()
#'
#' @param fun An expression.
#'
#' @return
#' A logical value.
#'
#' @noRd
contains_readline <- function(expr) {
  if (is.function(expr))
    expr <- body(expr)
  any(sapply(expr, function(line) {
    if (length(line) > 1)
      return(contains_readline(line))
    any(grepl("^readline", deparse(line)))
  }))
}

#' Append to each input a listified call to that input
#'
#' @param input A named list.
#'
#' @return
#' A named list with the original elements followed by their listified
#' version.
#'
#' @noRd
append_listified <- function(input) {
  transformed <- lapply(input, list)
  if (any(nzchar(names(transformed))))
    names(transformed) <- sprintf("list(%s)", names(transformed))
  c(input, transformed)
}