R.utils: Various Programming Utilities

Documented in withoutGString

###########################################################################/**
# @RdocClass Arguments
#
# @title "Static class to validate and process arguments"
#
# \description{
#  @classhierarchy
# }
#
# \section{Fields and Methods}{
#  @allmethods
# }
#
# @author
#
# @keyword programming
#*/###########################################################################
setConstructorS3("Arguments", function(...) {
  extend(Object(), "Arguments")
})



#########################################################################/**
# @RdocMethod getFilename
#
# @title "Gets and validates a filename"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{filename}{A @character string.}
#   \item{nchar}{An @integer @vector of length two specifying the range
#     of valid filename lengths.}
#   \item{class}{A @character string specifying the class of valid
#     filenames.}
#   \item{.name}{The name of the argument validated.}
#   \item{.type}{Not used.}
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string if filename is valid,
#  otherwise an exception is thrown.
# }
#
# \section{Missing values}{
#   If \code{filename} is a missing value, then an exception is thrown.
# }
#
# \details{
#   When argument \code{class="safe"}, the following 86 ASCII characters
#   are allowed in filenames:
#   \preformatted{
#      #$%&'()+,-.0123456789;=         (24 including initial space)
#     @ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_  (31)
#     `abcdefghijklmnopqrstuvwxyz{|}~  (31)
#   }
#   This class of filenames has been extensively tested on for
#   cross-platform support on Microsoft Windows, macOS, and various
#   Unix flavors.
# }
#
# \references{
#   [1] Microsoft, \emph{Naming Files, Paths, and Namespaces}, 2018.
#       \url{https://learn.microsoft.com/en-us/windows/win32/fileio/naming-a-file}.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/#########################################################################
setMethodS3("getFilename", "Arguments", function(static, filename, nchar=c(1,128), class=c("safe"), .name=NULL, .type="filename", ...) {
##
## OLD NOTES:
##   Valid filename characters:
## * The FTP RFCs require (7-bit) ASCII characters (and presumably not control
##   characters either). The 95 printable ASCII characters are (note initial
##   space):
##
##    !"#$%&'()*+,-./0123456789:;<=>?  (32)
##   @ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_  (32)
##   `abcdefghijklmnopqrstuvwxyz{|}~   (31)
##
## * On Windows the following 9 characters aren't allowed: \ / : * ? " < > !.
##   This leaves us with:
##
##    #$%&'()+,-.0123456789;=          (24)
##   @ABCDEFGHIJKLMNOPQRSTUVWXYZ[]^_   (31)
##   `abcdefghijklmnopqrstuvwxyz{|}~   (31)

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument '.name':
  if (is.null(.name)) {
    .name <- as.character(deparse(substitute(filename)))
  }

  # Argument 'filename':
  if (is.na(filename)) {
    throw("Argument 'filename' cannot be a missing value: ", filename)
  }
  filename <- getCharacter(static, filename, nchar=nchar, .name=.name)

  # Argument 'class':
  class <- match.arg(class)


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Filter out valid characters
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  chars <- filename

  # Always valid characters
  chars <- gsub("[abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0-9_.,]", "", chars)
  chars <- gsub("[-]", "", chars)
  chars <- gsub("[+]", "", chars)

  # Filter out according to classes.
  if ("safe" %in% class) {
    chars <- gsub("[ ]", "", chars)
    chars <- gsub("[\\[\\]]", "", chars)
    chars <- gsub("[#$%&'()`{|}~]", "", chars)
    chars <- gsub("[=]", "", chars)
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Check for remaining (=invalid) characters
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (nchar(chars, type="chars") > 0L) {
    chars <- unlist(strsplit(chars, split=""))
    chars <- sort(unique(chars))
    chars <- sprintf("'%s'", chars)
    chars <- paste(chars, collapse=", ")
    throw(sprintf("Not a valid %s. Argument '%s' contains non-valid %s characters (%s): %s", .type, .name, .type, chars, filename))
  }

  filename
}, static=TRUE, private=TRUE)



#########################################################################/**
# @RdocMethod getReadablePathname
#
# @title "Gets a readable pathname"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{file}{A @character string specifying the file.}
#   \item{path}{A @character string specifying the path.}
#   \item{mustExist}{If @TRUE, the pathname must exists and be readable,
#     otherwise an exception is thrown. If @FALSE, no such test is
#     performed.}
#   \item{absolute}{If @TRUE, the absolute pathname is returned.}
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string of the absolute pathname of the file.
# }
#
# \section{Missing values}{
#   If \code{file} or \code{path} is @NA and \code{mustExist} is @FALSE,
#   then (character) @NA is returned, otherwise an exception is thrown.
# }
#
# \section{Windows}{
#  If a too long pathname is detected on Windows, an informative warning
#  is given.
#  The maximum number of symbols in a Windows pathname is 256, including
#  file separators '/' or '\', but excluding the drive letter, and initial
#  file separator (e.g. 'C:/'), and the string terminator ('\\0'), cf.
#  'MSDN - Naming a File or Directory', Microsoft. In R, the limit is
#  one symbol less, i.e. 255.
# }
#
# @author
#
# \seealso{
#   @seemethod "getWritablePathname"
#   @see "R.utils::filePath".
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getReadablePathname", "Arguments", function(static, file=NULL, path=NULL, mustExist=TRUE, absolute=FALSE, adjust=c("none", "url"), ...) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'file':
  if (!is.null(file)) {
    if (inherits(file, "connection")) {
      throw("In this context, argument 'file' cannot be a connection.")
    }
    file <- getCharacter(static, file, length=c(1,1))
  }
  # Ignore 'path'?
  if (isAbsolutePath(file)) path <- NULL

  # Argument 'path':
  if (!is.null(path)) {
    path <- getCharacter(static, path, length=c(1,1))
  }

  if (is.null(file) && is.null(path)) {
    throw("Both argument 'file' and 'path' are NULL.")
  }

  # Argument 'mustExist':
  mustExist <- getLogical(static, mustExist)

  # Backward compatibility (absolutePath -> absolute)
  absolutePath <- list(...)$absolutePath
  if (!is.null(absolutePath)) absolute <- absolutePath

  # Argument 'absolute':
  absolute <- getLogical(static, absolute)

  # Argument 'adjust':
  adjust <- match.arg(adjust)

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Process arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (mustExist) {
    if (!is.null(file) && is.na(file)) {
      throw("No such file/directory because argument 'file' is NA.")
    }
    if (!is.null(path) && is.na(path)) {
      throw("No such file/directory because argument 'path' is NA.")
    }
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Make sure <path>/<file> is properly split up
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (is.null(path)) {
    pathname <- file
  } else if (is.null(file)) {
    pathname <- path
  } else {
    pathname <- file.path(path, file)
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Windows: The maximum number of symbols in a Windows pathname is 256,
  # in R it's 255. For more details, see:
  # https://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (.Platform$OS.type == "windows") {
    if (!is.na(pathname) && nchar(pathname, type="chars") > 255L) {
      msg <- sprintf("A too long pathname (%d characters) was detected on Windows, where maximum number of symbols is 256 and in R it is one less: %s", nchar(pathname, type="chars"), pathname)
      warning(msg)
    }
  }

  path <- dirname(pathname)
  file <- basename(pathname)
  pathname <- NULL


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Adjust filename?
  # FIXME: Adjust also directory names. /HB 2014-05-04
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (adjust == "url") {
    # Decode non-problematic filename characters, e.g. '%20' -> ' '
    file <- URLdecode(file)

    # But encode problematic ones, e.g. ':', '*'
    file <- gsub(":", "%3A", file, fixed=TRUE)
    file <- gsub("*", "%2A", file, fixed=TRUE)
    file <- gsub("\\", "%5C", file, fixed=TRUE)

    # Encode tilde (~) unless first character
    # FIX ME: Needed or not? /HB 2014-05-04
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Expand links
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # NB: Here 'mustExist=TRUE' means that filePath() will always return
  # a pathname, not that it will give an error if file does not exist.
  pathname <- filePath(path, file, expandLinks="any", mustExist=TRUE)

  if (absolute) {
    pathname <- getAbsolutePath(pathname)
  }


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Windows: The maximum number of symbols in a Windows pathname is 256,
  # in R it's 255. For more details, see:
  # https://msdn.microsoft.com/en-us/library/aa365247(VS.85).aspx
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  if (.Platform$OS.type == "windows") {
    if (!is.na(pathname) && nchar(pathname, type="chars") > 255L) {
      msg <- sprintf("A too long pathname (%d characters) was detected on Windows, where maximum number of symbols is 256 and in R it is one less: %s", nchar(pathname, type="chars"), pathname)
      warning(msg)
    }
  }


  if (mustExist) {
    # Check if file exists
    if (!file.exists(pathname)) {
      # Locate the first parent directory that does not exist
      depth <- 1
      while(TRUE) {
        parent <- getParent(pathname, depth=depth)
        if (is.na(parent) || is.null(parent) || isDirectory(parent))
          break
        depth <- depth + 1
      } # while()

      reason <- NULL
      if (is.na(parent) || is.null(parent)) {
        parent <- getParent(pathname)
        if (is.na(parent) || is.null(parent)) {
          reason <- "no such file in the current working directory"
        } else {
          reason <- sprintf("none of the parent directories [%s/] exist", parent)
        }
      } else {
        reason <- sprintf("%s/ exists, but nothing beyond", parent)
      }
      if (!is.null(reason) && !isAbsolutePath(pathname)) {
        reason <- sprintf("%s; current directory is '%s'", reason, getwd())
      }
      reason <- sprintf(" (%s)", reason)
      throw("Pathname not found: ", pathname, reason)
    }

    # Check if file permissions allow reading
    if (fileAccess(pathname, mode=4) == -1) {
      throw("Pathname exists, but there is no permission to read file: ", pathname)
    }
  } # if (mustExist)

  pathname
}, static=TRUE)


setMethodS3("getReadablePath", "Arguments", function(static, path=NULL, mustExist=TRUE, ...) {
  if (is.null(path))
    return(NULL)

  path <- getReadablePathname(static, path=path, mustExist=mustExist, ...)
  if (mustExist && !is.na(path) && !isDirectory(path)) {
    throw("Argument 'path' is not a directory: ", path)
  }

  path
}, static=TRUE, protected=TRUE)



#########################################################################/**
# @RdocMethod getReadablePathnames
#
# @title "Gets a readable pathname"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{files}{A @character @vector of filenames.}
#   \item{paths}{A @character @vector of paths.}
#   \item{...}{Arguments passed to @seemethod "getReadablePathname".}
# }
#
# \value{
#  Returns a @character @vector of the pathnames for the files.
# }
#
# @author
#
# \seealso{
#   @seemethod "getReadablePathname"
#   @see "R.utils::filePath".
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getReadablePathnames", "Arguments", function(static, files=NULL, paths=NULL, ...) {
  nbrOfFiles <- length(files)
  # Argument 'paths':
  if (length(paths) > nbrOfFiles) {
    throw("Argument 'paths' is longer than argument 'files': ",
                                          length(paths), " > ", nbrOfFiles)
  }

  # Expand argument 'paths' to be of same length as 'files'
  if (!is.null(paths)) {
    paths <- rep(paths, length.out=nbrOfFiles)
  }

  pathnames <- list()
  for (kk in seq_len(nbrOfFiles)) {
    pathnames[[kk]] <- getReadablePathname(static, files[kk],
                                                       path=paths[kk], ...)
  }

  unlist(pathnames)
}, static=TRUE)


#########################################################################/**
# @RdocMethod getWritablePathname
#
# @title "Gets a writable pathname"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Arguments passed to @seemethod "getReadablePathname".}
#   \item{mustExist}{If @TRUE and the pathname does not exists,
#     an Exception is thrown, otherwise not.}
#   \item{mustNotExist}{If the file exists, and \code{mustNotExist} is
#     @TRUE, an Exception is thrown. If the file exists, and
#     \code{mustNotExist} is @FALSE, or the file does not exists, the
#     pathname is accepted.}
#   \item{mkdirs}{If @TRUE, \code{mustNotExist} is @FALSE, and the path to
#     the file does not exist, it is (recursively) created.}
#   \item{maxTries}{A positive @integer specifying how many times the
#     method should try to create a missing directory before giving up.
#     For more details, see @see "R.utils::mkdirs".}
# }
#
# \value{
#  Returns a @character string of the pathname of the file.
#  If the argument was invalid an @see "R.oo::Exception" is thrown.
# }
#
# \section{Missing values}{
#   If any argument in \code{...} is @NA, an exception is thrown.
# }
#
# @author
#
# \seealso{
#   @seemethod "getReadablePathname".
#   @see "R.utils::filePath".
#   @see "R.utils::mkdirs".
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getWritablePathname", "Arguments", function(static, ..., mustExist=FALSE, mustNotExist=FALSE, mkdirs=TRUE, maxTries=5L) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'mustExist':
  mustExist <- getLogical(static, mustExist)

  # Argument 'mustNotExist':
  mustNotExist <- getLogical(static, mustNotExist)

  # Argument 'mkdirs':
  mkdirs <- getLogical(static, mkdirs)

  # Create pathname
  pathname <- getReadablePathname(static, ..., mustExist=mustExist)

  if (is.na(pathname)) {
    throw("Cannot retrieve writable file/directory because it is NA.")
  }

  if (isFile(pathname)) {
    # Check if it is ok that the file already exists
    if (mustNotExist) {
      throw("File already exists: ", pathname)
    }

    # Check if file permissions allow to modify existing
    if (fileAccess(pathname, mode=2) == -1) {
      throw("No permission to modify existing file: ", pathname)
    }
  } else {
    # Check if directory exists
    path <- getParent(pathname)
    if (!isDirectory(path)) {
      # Does the directory have to exists (mkdirs=FALSE)?
      if (!mkdirs) {
        path <- getReadablePath(static, path, mustExist=TRUE)
      }

      # If not, first try to create the parent directory, iff missing.
      # This should give a more informative error message, if it fails.
      pathP <- getParent(path)
      createParent <- !isDirectory(pathP)
      if (createParent) {
        pathnameP <- getWritablePathname(static, file="dummy-not-tested", path=pathP, mustExist=FALSE, mustNotExist=FALSE, mkdirs=TRUE, maxTries=maxTries)
      }

      # Try to create the directory
      mkdirs(path, mustWork=TRUE, maxTries=maxTries)
    }

    filename <- basename(pathname)
    if (filename != "dummy-not-tested") {
      # Check if file permissions allow to create a file in the directory
      pathT <- ifelse(is.null(path), ".", path)
      if (fileAccess(pathT, mode=2) == -1) {
        throw("No write permission for directory: ", path)
      }

      # Try to create a file
      filenameT <- basename(tempfile())
      pathnameT <- filePath(path, filenameT)

      on.exit({
        if (isFile(pathnameT)) {
          # Try to remove the temporary file
          res <- FALSE
          suppressWarnings({
            for (tt in 1:maxTries) {
              res <- file.remove(pathnameT)
              if (res) break
              # If not, wait a bit and try again...
              Sys.sleep(0.5)
            }
          })
          if (!res) {
            warning("Failed to remove temporary file: ", sQuote(pathnameT))
          }
        }
      }, add=TRUE)

      tryCatch({
        cat(file=pathnameT, Sys.time())
      }, error = function(ex) {
        throw("No permission to create a new file in directory: ", path)
      })
    } # if (filename != "dummy-not-tested")
  } # if (isFile(pathname))

  pathname
}, static=TRUE)



setMethodS3("getWritablePath", "Arguments", function(static, path=NULL, ...) {
  # Special case: If path == NULL, the skip
  if (is.null(path))
    return(NULL)

  pathname <- getWritablePathname(static, file="dummy-not-created", path=path, ...)
  getParent(pathname)
}, static=TRUE, protected=TRUE)



setMethodS3("getDirectory", "Arguments", function(static, path=NULL, ..., mustExist=FALSE, mkdirs=TRUE) {
  # Argument 'mustExist':
  mustExist <- getLogical(static, mustExist)

  # Argument 'mkdirs':
  mkdirs <- getLogical(static, mkdirs)

  # Create pathname
  pathname <- getReadablePathname(static, path=path, ..., mustExist=mustExist)

  if (is.na(pathname)) {
    throw("Cannot retrieve directory because it is NA.")
  }

  # Nothing to do?
  if (isDirectory(pathname)) {
    return(pathname)
  }

  if (!mkdirs) {
    throw("Directory does not exist: ", pathname)
  }

  mkdirs(pathname, mustWork=TRUE)

  pathname
}, static=TRUE, protected=TRUE)



#########################################################################/**
# @RdocMethod getVector
#
# @title "Validates a vector"
#
# \description{
#  @get "title" by checking its length (number of elements).
# }
#
# @synopsis
#
# \arguments{
#   \item{x}{A single @vector.}
#   \item{length}{A @numeric @vector of length two or more. If two, it
#     is the minimum and maximum length of \code{x}. Otherwise, it is the
#     set of possible lengths of \code{x}.}
#   \item{.name}{A @character string for name used in error messages.}
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns the same @vector, if it is valid. Otherwise an exception is
#  thrown.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getVector", "Arguments", function(static, x, length=NULL, .name=NULL, ...) {
  if (length(length) == 0)
    return(x)

  if (is.null(.name))
    .name <- as.character(deparse(substitute(x)))

  # See ?is.vector for how it is defined. /HB 2009-05-19
  attrs <- attributes(x)
  attributes(x) <- attrs[intersect(names(attrs), c("names", "dim"))]

  if (length[1] > 0 && !is.vector(x)) {
    throw(sprintf("Argument '%s' is not a vector: %s", .name, storage.mode(x)))
  }

  xlen <- length(x)

  if (length(length) == 1)
    length <- c(1,length)

  if (length(length) == 2) {
    if (xlen < length[1] || xlen > length[2]) {
      if (length[1] == length[2] && length[1] == 1) {
        throw(sprintf("Argument '%s' should be a single value not %d values.", .name, xlen))
      } else if (length[1] == length[2]) {
        throw(sprintf("Number of elements in argument '%s' should be exactly %d not %d value(s).", .name, length[1], xlen))
      } else {
        throw(sprintf("Number of elements in argument '%s' is out of range [%d,%d]: %d", .name, length[1], length[2], xlen))
      }
    }
  } else {
    if (!is.element(xlen, length)) {
      throw(sprintf("Number of elements in argument '%s' is not in {%s}: %d",
                                   .name, seqToHumanReadable(length), xlen))
    }
  }

  attributes(x) <- attrs

  x
}, static=TRUE, private=TRUE)




#########################################################################/**
# @RdocMethod getCharacters
# @aliasmethod getCharacter
#
# @title "Coerces to a character vector and validates"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{s}{A @vector.}
#   \item{nchar}{A @numeric @vector of length one or two. If one,
#     the maximum number of characters ("length") in \code{s}. If two,
#     the minimum and maximum length of \code{s}.}
#   \item{useNames}{If @TRUE, the 'names' attribute is preserved, otherwise
#     it is dropped.}
#   \item{asGString}{If @TRUE, each string is treated as a @see "GString".}
#   \item{.name}{A @character string for name used in error messages.}
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character @vector, if it is valid. Otherwise an exception is
#  thrown.
# }
#
# \section{Missing values}{
#   If \code{s} contains missing values, and \code{nchar} is not @NULL,
#   then an exception is thrown.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getCharacters", "Arguments", function(static, s, length=NULL, trim=FALSE, nchar=NULL, useNames=TRUE, asGString=getOption("Arguments$getCharacters/args/asGString", TRUE), .name=NULL, ...) {
  if (is.null(.name))
    .name <- as.character(deparse(substitute(s)))

  s <- getVector(static, s, length=length, .name=.name)

  # Nothing to check?
  if (length(s) == 0L)
    return(s)

  # Coerce GString:s to character strings?
  if (asGString) {
    # Treat only strings with GString markup.  This avoids lots of
    # GString overhead if there are no GStrings.
    hasMarkup <- (regexpr("${", s, fixed=TRUE) != -1)
    idxs <- which(hasMarkup & !is.na(s))
    s[idxs] <- unlist(lapply(s[idxs], FUN=function(x) {
      x <- GString(x)
      as.character(x)
    }), use.names=FALSE)
  }

  if (trim) {
    # Trim the strings
    # (using s[] to preserve attributes)
    s[] <- unlist(lapply(s, FUN=trim), use.names=FALSE)
  }

  # Coerce to character strings
  # (using s[] to preserve attributes)
  s[] <- unlist(lapply(s, FUN=as.character), use.names=FALSE)

  if (!useNames) {
    names(s) <- NULL
  }

  # Nothing to check?
  if (is.null(nchar))
    return(s)

  # At this point, missing values are not allowed
  if (any(is.na(s))) {
    throw("Argument 'nchar' cannot be specified if character vector contains missing values: ", hpaste(sQuote(s)))
  }

  if (length(nchar) == 1L)
    nchar <- c(1L, nchar)

  # Check the string length of each character string
  for (kk in seq_along(s)) {
    slen <- nchar(s[kk], type="chars")
    if (slen < nchar[1L] || slen > nchar[2L]) {
      throw(sprintf("String length of elements #%d in '%s' is out of range [%d,%d]: %d '%s'", kk, .name, nchar[1L], nchar[2L], slen, s[kk]))
    }
  }

  s
}, static=TRUE)

setMethodS3("getCharacter", "Arguments", function(static, ..., length=c(0,1)) {
  getCharacters(static, ..., length=length)
}, static=TRUE)




#########################################################################/**
# @RdocMethod getNumerics
# @aliasmethod getNumeric
#
# @title "Coerces to a numeric vector and validates"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{x}{A @vector.}
#   \item{range}{Two @numerics for the allowed ranged. If @NULL, range is
#     not checked.}
#   \item{asMode}{A @character specifying the mode to coerce to.}
#   \item{disallow}{A @character @vector specifying disallowed value sets,
#                     i.e. \code{"NA"}, \code{"NaN"}, and/or \code{"Inf"}.}
#   \item{...}{Arguments passed to @method "getVector".}
#   \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
#  Returns a @numeric @vector.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getNumerics", "Arguments", function(static, x, range=NULL, asMode=NULL, disallow=NULL, ..., .name=NULL) {
  # Argument '.name':
  if (is.null(.name)) {
    .name <- as.character(deparse(substitute(x)))
  }
  x <- getVector(static, x, ..., .name=.name)
  xMode <- storage.mode(x)

  # Coerce the mode of 'x'
  if (is.null(asMode)) {
    if (is.element(xMode, c("integer", "double"))) {
      asMode <- xMode
    } else {
      asMode <- "double"
    }
  }

  # Update/coerce mode?
  if (xMode != asMode) {
    storage.mode(x) <- asMode
  }

  # Nothing to do?
  if (length(x) == 0)
    return(x)

  if (!is.null(disallow)) {
    if (is.element("NaN", disallow) && any(is.nan(x))) {
      throw(sprintf("Argument '%s' contains %d NaN value(s).",
                                                   .name, sum(is.nan(x))))
    }

    if (is.element("NA", disallow) && any(is.na(x) & !is.nan(x))) {
      throw(sprintf("Argument '%s' contains %d NA value(s).",
                                                    .name, sum(is.na(x))))
    }

    # For conveniency, disallow 'Inf' here too; other range takes care of it.
    if (is.element("Inf", disallow) && any(is.infinite(x))) {
      throw(sprintf("Argument '%s' contains %d (-/+)Inf value(s).",
                                             .name, sum(is.infinite(x))))
    }
  }

  # Nothing to check?
  if (is.null(range))
    return(x)

  # Argument 'range':
  if (length(range) != 2) {
    throw("Argument 'range' should be of length 2: ", length(range))
  }
  if (range[2] < range[1]) {
    throw(sprintf("Argument 'range' is not ordered: c(%s,%s)", range[1], range[2]))
  }

  # Suppress warnings when there are no finite values in x.
  suppressWarnings({
    xrange <- range(x, na.rm=TRUE)
  })

  if (xrange[1] < range[1] || xrange[2] > range[2]) {
    xrange <- as.character(xrange)
    range <- as.character(range)
    if (length(x) == 1) {
      throw(sprintf("Argument '%s' is out of range [%s,%s]: %s",
                          .name, range[1], range[2], x))
    } else {
      throw(sprintf("Range of argument '%s' is out of range [%s,%s]: [%s,%s]",
                          .name, range[1], range[2], xrange[1], xrange[2]))
    }
  }

  x
}, static=TRUE)

setMethodS3("getNumeric", "Arguments", function(static, ..., length=1) {
  getNumerics(static, ..., length=length)
}, static=TRUE)




#########################################################################/**
# @RdocMethod getDoubles
# @aliasmethod getDouble
#
# @title "Coerces to a double vector and validates"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Arguments passed to @method "getNumeric".}
#   \item{disallow}{Disallowed values. See @method "getNumerics" for details.}
# }
#
# \value{
#  Returns a @double @vector.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getDoubles", "Arguments", function(static, ..., disallow=c("NA","NaN")) {
  getNumerics(static, ..., asMode="double", disallow=disallow)
}, static=TRUE)

setMethodS3("getDouble", "Arguments", function(static, ..., length=1) {
  getDoubles(static, ..., length=length)
}, static=TRUE)




#########################################################################/**
# @RdocMethod getIntegers
# @aliasmethod getInteger
#
# @title "Coerces to a integer vector and validates"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Arguments passed to @method "getNumeric".}
#   \item{disallow}{Disallowed values. See @method "getNumerics" for details.}
# }
#
# \value{
#  Returns a @integer @vector.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getIntegers", "Arguments", function(static, ..., disallow=c("NA","NaN")) {
  getNumerics(static, ..., asMode="integer", disallow=disallow)
}, static=TRUE)

setMethodS3("getInteger", "Arguments", function(static, ..., length=1) {
  getIntegers(static, ..., length=length)
}, static=TRUE)



#########################################################################/**
# @RdocMethod getIndices
# @aliasmethod getIndex
#
# @title "Coerces to a integer vector and validates"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{x}{A single @vector.  If @logical, @see "base::which" is used.}
#   \item{...}{Arguments passed to @method "getIntegers".}
#   \item{range}{Allowed range. See @method "getNumerics" for details.}
#   \item{max}{The maximum of the default range.}
#   \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
#  Returns an @integer @vector.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getIndices", "Arguments", function(static, x, ..., max=Inf, range=c(1*(max > 0L),max), .name=NULL) {
  if (is.null(.name))
    .name <- as.character(deparse(substitute(x)))

  # Argument 'x':
  if (is.logical(x)) {
    x <- which(x)
  }

  # Argument 'max':
  if (length(max) != 1) {
    throw("Argument 'max' must be a single value: ", length(max))
  }
  max <- as.numeric(max)
  if (is.na(max)) {
    throw("Argument 'max' is NA/NaN: ", max)
  } else if (max < 0) {
    throw("Argument 'max' must be positive: ", max)
  }

  # Argument 'range':
  if (!is.null(range)) {
    if (length(range) != 2) {
      throw("Argument 'range' should be of length 2: ", length(range))
    }
    if (range[2] < range[1]) {
      throw(sprintf("Argument 'range' is not ordered: c(%s,%s)", range[1], range[2]))
    }
  }

  # Identify indices
  x <- getIntegers(static, x, ..., range=range, .name=.name)

  # Special dealing with range = c(0,0)
  if (!is.null(range)) {
    if (range[2] < 1L) {
      xt <- x[is.finite(x)]
      if (length(xt) > 0) {
        throw(sprintf("Argument 'x' contains %d non-missing indices although the range ([%s,%s]) implies that there should be none.", length(xt), range[1L], range[2L]))
      }
    }
  }

  x
}, static=TRUE)

setMethodS3("getIndex", "Arguments", function(static, ..., length=1) {
  getIndices(static, ..., length=length)
}, static=TRUE)




#########################################################################/**
# @RdocMethod getLogicals
# @aliasmethod getLogical
#
# @title "Coerces to a logical vector and validates"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{x}{A @vector.}
#   \item{disallow}{A @character @vector specifying disallowed value sets
#      after coercing, i.e. \code{"NA"}.}
#   \item{...}{Arguments passed to @method "getVector".}
#   \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
#  Returns a @numeric @vector.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getLogicals", "Arguments", function(static, x, ..., disallow=c("NA", "NaN"), coerce=FALSE, .name=NULL) {
  if (is.null(.name))
    .name <- as.character(deparse(substitute(x)))
  x <- getVector(static, x, ..., .name=.name)

  # Coerce to logicals?
  if (coerce)
    x <- as.logical(x)

  if (!is.null(disallow)) {
    if (is.element("NA", disallow) && any(is.na(x))) {
      throw(sprintf("Argument '%s' contains %d NA value(s).",
                                                    .name, sum(is.na(x))))
    }
  }

  # Assert that 'x' is logical before returning
  if (any(!is.logical(x)))
    throw(sprintf("Argument '%s' is non-logical: %s", .name, class(x)))

  x
}, static=TRUE)

setMethodS3("getLogical", "Arguments", function(static, ..., length=1) {
  getLogicals(static, ..., length=length)
}, static=TRUE)



#########################################################################/**
# @RdocMethod getVerbose
#
# @title "Coerces to Verbose object"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{verbose}{A single object. If a @see "Verbose", it is immediately
#      returned.  If a @numeric value, it is used as the threshold.
#      Otherwise the object is coerced to a @logical value and if @TRUE,
#      the threshold is \code{defaultThreshold}.}
#   \item{defaultThreshold}{A @numeric value for the default threshold, if
#       \code{verbose} was interpreted as a @logical value.}
#   \item{useNullVerbose}{If \code{verbose} can be interpreted as @FALSE,
#       return a @see NullVerbose object if @TRUE.}
#   \item{...}{Passed to the constructor of @see "Verbose".}
#   \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
#  Returns a @see Verbose (or a @see "NullVerbose") object.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getVerbose", "Arguments", function(static, verbose, defaultThreshold=-1, useNullVerbose=TRUE, ..., .name=NULL) {
  if (inherits(verbose, "Verbose"))
    return(verbose)

  if (is.null(.name))
    .name <- as.character(deparse(substitute(verbose)))

  if (is.numeric(verbose)) {
    verbose <- getDouble(static, verbose, .name=.name)
    verbose <- Verbose(threshold=verbose, ...)
  } else {
    verbose <- getLogical(static, verbose, .name=.name)
    if (!verbose && useNullVerbose) {
      verbose <- NullVerbose()
    } else {
      defaultThreshold <- getNumeric(static, defaultThreshold)
      verbose <- Verbose(threshold=defaultThreshold, ...)
    }
  }

  verbose
}, static=TRUE)


#########################################################################/**
# @RdocMethod getRegularExpression
#
# @title "Gets a valid regular expression pattern"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{pattern}{A @character string to be validated.}
#   \item{.name}{A @character string for name used in error messages.}
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns a @character string.
# }
#
# @author
#
# \seealso{
#   @see "base::grep".
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getRegularExpression", "Arguments", function(static, pattern=NULL, ..., .name=NULL) {
  if (is.null(.name)) {
    .name <- as.character(deparse(substitute(pattern)))
  }

  if (is.null(pattern)) {
    throw(sprintf("Argument '%s' is not a valid regular expression: NULL",
                                                                   .name))
  }

  pattern <- getCharacter(static, pattern, .name=.name, length=c(1,1))

  # Validate it
  tryCatch({
    regexpr(pattern, "dummy string", ...)
  }, error = function(ex) {
    throw(sprintf("Argument '%s' is not a valid regular expression: %s. Error message from regexpr() was: %s", .name, pattern, ex$message))
  })

  pattern
}, static=TRUE)



#########################################################################/**
# @RdocMethod getEnvironment
#
# @title "Gets an existing environment"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{envir}{An @environment, the name of a loaded package, or @NULL.
#      If @NULL, the global environment is returned.}
#   \item{.name}{A @character string for name used in error messages.}
#   \item{...}{Not used.}
# }
#
# \value{
#  Returns an @environment.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword IO
#*/#########################################################################
setMethodS3("getEnvironment", "Arguments", function(static, envir=NULL, .name=NULL, ...) {
  if (is.null(.name))
    .name <- as.character(deparse(substitute(envir)))

  if (is.null(envir)) {
    return(.GlobalEnv)
  }

  if (is.character(envir)) {
    name <- getCharacter(static, envir, length=c(1,1))
    envirs <- gsub("^package:", "", search())
    pos <- which(name == envirs)
    if (length(pos) == 0)
      throw("Argument 'envir' is not the name of a loaded package: ", envir)
    envir <- pos.to.env(pos)
  }

  if (!is.environment(envir)) {
    throw(sprintf("Argument '%s' is not an environment: %s",
                                                   .name, class(envir)[1]))
  }
}, static=TRUE)






#########################################################################/**
# @RdocMethod getInstanceOf
#
# @title "Gets an instance of the object that is of a particular class"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{object}{The object that should be returned as an instance of
#      class \code{class}.}
#   \item{class}{A @character string specifying the name of the class that
#      the returned object should inherit from.}
#   \item{coerce}{If @TRUE and the object is not of the wanted class, then
#      method will be coerced to that class, if possible.  Otherwise,
#      an error is thrown.}
#   \item{...}{Not used.}
#   \item{.name}{A @character string for name used in error messages.}
# }
#
# \value{
#   Returns an object inheriting from class \code{class}.
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#
# @keyword programming
#*/#########################################################################
setMethodS3("getInstanceOf", "Arguments", function(static, object, class, coerce=FALSE, ..., .name=NULL) {
  if (is.null(.name)) {
    .name <- as.character(deparse(substitute(object)))
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'class':
  class <- getCharacter(static, class)

  # Argument 'coerce':
  coerce <- getLogical(static, coerce)

  # Argument 'object':
  if (!inherits(object, class)) {
    if (coerce) {
      object <- as(object, class, ...)
    } else {
      throw(sprintf("Argument '%s' is neither of nor inherits class %s: %s",
                     .name, class[1], paste(class(object), collapse=", ")))
    }
  }

  # Return the object
  object
}, static=TRUE, protected=TRUE)


withoutGString <- function(..., envir=parent.frame()) {
  # Temporarily disable 'asGString' for Arguments$getCharacters()
  oopts <- options("Arguments$getCharacters/args/asGString"=FALSE)
  on.exit(options(oopts))
  eval(..., envir = envir, enclos = baseenv())
} # withoutGString()