R/utils.R

In htmltools: Tools for HTML

# @staticimports pkg:staticimports
#  system_file is_installed

# Implements a "whitespace eating" writer.
#
# WSTextWriter relies on the caller distinguishing between writes of important
# content, and writes of whitespace that may or may not be elided (`.$write()`
# vs `.$writeWS()`).
#
# At any point, `eatWS` may be called, which will cause any recent `writeWS`
# operations (i.e. those since either the beginning of time, or the most recent
# `write` operation) to be undone, AND for any future `writeWS` calls to be
# ignored. A call to `write` will be respected, and will restore normal
# behavior.
#
# Text is automatically converted to UTF-8 before being written.
#' @param bufferSize The initial size of the buffer in which writes are stored.
#'   The buffer will be periodically cleared, if possible, to cache the writes
#'   as a string. If the buffer cannot be cleared (because of the need to be
#'   able to backtrack to fulfill an `eatWS()` call), then the buffer size will
#'   be doubled.
#' @noRd
WSTextWriter <- function(bufferSize=1024) {
  if (bufferSize < 3) {
    stop("Buffer size must be at least 3")
  }

  # The buffer into which we enter all the writes.
  buffer <- character(bufferSize)

  # The index storing the position in the buffer of the most recent write.
  marked <- 0

  # The index storing the position in the buffer of the most recent write or writeWS.
  position <- 0

  # TRUE if we're eating whitespace right now, in which case calls to writeWS are no-ops.
  suppressing <- FALSE

  # Collapses the text in the buffer to create space for more writes. The first
  # element in the buffer will be the concatenation of any writes up to the
  # current marker. The second element in the buffer will be the concatenation
  # of all writes after the marker.
  collapseBuffer <- function() {
    # Collapse the writes in the buffer up to the marked position into the first buffer entry
    nonWS <- ""
    if (marked > 0) {
      nonWS <- paste(buffer[seq_len(marked)], collapse="")
    }

    # Collapse any remaining whitespace
    ws <- ""
    remaining <- position - marked
    if (remaining > 0) {
      # We have some whitespace to collapse. Collapse it into the second buffer entry.
      ws <- paste(buffer[seq(from=marked+1,to=marked+remaining)], collapse="")
    }

    buffer[1] <<- nonWS
    buffer[2] <<- ws
    position <<- 2
    marked <<- 1
  }

  # Logic to do the actual write
  writeImpl <- function(text) {
    # force `text` to evaluate and check that it's the right shape
    # TODO: We could support vectors with multiple elements here and perhaps
    #   find some way to combine with `paste8()`. See
    #   https://github.com/rstudio/htmltools/pull/132#discussion_r302280588
    if (length(text) != 1 || !is.character(text)) {
      stop("Text to be written must be a length-one character vector")
    }

    # Are we at the end of our buffer?
    if (position == length(buffer)) {
      collapseBuffer()
    }

    # The text that is written to this writer will be converted to
    # UTF-8 using enc2utf8. The rendered output will always be UTF-8
    # encoded.
    enc <- enc2utf8(text)

    # Move the position pointer and store the (encoded) write
    position <<- position + 1
    buffer[position] <<- enc
  }

  # The actual object returned
  list(
    # Write content. Updates the marker and stops suppressing whitespace writes.
    #
    # @param text Single element character vector
    write = function(text) {
      writeImpl(text)

      suppressing <<- FALSE
      marked <<- position
    },
    # Write whitespace. If eatWS() was called and its effect has not been
    # canceled, then this method no-ops.
    # @param text Single element character vector containing only
    #   whitespace characters
    writeWS = function(text) {
      if (suppressing) {
        return()
      }
      writeImpl(text)
    },
    # Return the contents of the TextWriter, as a single element character
    # vector, from the beginning to the current writing position (normally this
    # is the end of the last write or writeWS, unless eatWS() was called).
    readAll = function() {
      # Collapse everything in the buffer up to `position`
      paste(buffer[seq_len(position)], collapse="")
    },
    # Removes both recent and upcoming whitespace writes
    eatWS = function() {
      # Reset back to the most recent marker
      position <<- marked
      suppressing <<- TRUE
    }
  )
}

# Given a vector/list, return TRUE if any elements are named, FALSE otherwise.
anyNamed <- function(x) {
  # Zero-length vector
  if (length(x) == 0) return(FALSE)

  nms <- names(x)

  # List with no name attribute
  if (is.null(nms)) return(FALSE)

  # List with name attribute; check for any ""
  any(nzchar(nms))
}

# Given a vector/list, return TRUE if any elements are unnamed, FALSE otherwise.
anyUnnamed <- function(x) {
  # Zero-length vector
  if (length(x) == 0) return(FALSE)

  nms <- names(x)

  # List with no name attribute
  if (is.null(nms)) return(TRUE)

  # List with name attribute; check for any ""
  any(!nzchar(nms))
}

# Get source filename(s) out of a script, stylesheet, or attachment entry of an
# htmlDependency object. The spec is here:
# https://github.com/rstudio/shiny/blob/474f1400/srcts/src/shiny/render.ts#L79-L115
# This returns a character vector of filenames.
#  `attr` should be "src" for script, and "href" for stylesheet and attachment
find_dep_filenames <- function(x, attr = "src") {
  # In the case below, the structure is "abc" or c("abc", "xyz")
  if (is.character(x)) return(x)

  if (is.list(x)) {
    # In the case below, the structure is list(src="abc")
    if (!is.null(x[[attr]])) return(x[[attr]])

    # If we get here, the structure is list(list(src="abc"), list(src="xyz")).
    return(unlist(lapply(x, find_dep_filenames)))
  }

  # If we get here, we didn't find anything.
  character(0)
}