1## Copyright (C) 2021  Brodie Gaslam
2##
3## This file is part of "fansi - ANSI Control Sequence Aware String Functions"
4##
5## This program is free software: you can redistribute it and/or modify
6## it under the terms of the GNU General Public License as published by
7## the Free Software Foundation, either version 2 of the License, or
8## (at your option) any later version.
9##
10## This program is distributed in the hope that it will be useful,
11## but WITHOUT ANY WARRANTY; without even the implied warranty of
12## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13## GNU General Public License for more details.
14##
15## Go to <https://www.r-project.org/Licenses/GPL-2> for a copy of the license.
16
17#' ANSI Control Sequence Aware Version of nchar
18#'
19#' `nchar_ctl` counts all non _Control Sequence_ characters.
20#' `nzchar_ctl` returns TRUE for each input vector element that has non _Control
21#' Sequence_ sequence characters.  By default newlines and other C0 control
22#' characters are not counted.
23#'
24#' `nchar_ctl` is just a wrapper around `nchar(strip_ctl(...))`.  `nzchar_ctl`
25#' is implemented in native code and is much faster than the otherwise
26#' equivalent `nzchar(strip_ctl(...))`.
27#'
28#' These functions will warn if either malformed or non-CSI escape sequences are
29#' encountered, as these may be incorrectly interpreted.
30#'
31#' @inheritParams substr_ctl
32#' @inheritParams base::nchar
33#' @inheritParams strip_ctl
34#' @inheritSection substr_ctl _ctl vs. _sgr
35#' @note the `keepNA` parameter is ignored for R < 3.2.2.
36#' @export
37#' @seealso [fansi] for details on how _Control Sequences_ are
38#'   interpreted, particularly if you are getting unexpected results,
39#'   [`strip_ctl`] for removing _Control Sequences_.
40#' @examples
41#' nchar_ctl("\033[31m123\a\r")
42#' ## with some wide characters
43#' cn.string <-  sprintf("\033[31m%s\a\r", "\u4E00\u4E01\u4E03")
44#' nchar_ctl(cn.string)
45#' nchar_ctl(cn.string, type='width')
46#'
47#' ## Remember newlines are not counted by default
48#' nchar_ctl("\t\n\r")
49#'
50#' ## The 'c0' value for the `ctl` argument does not include
51#' ## newlines.
52#' nchar_ctl("\t\n\r", ctl="c0")
53#' nchar_ctl("\t\n\r", ctl=c("c0", "nl"))
54#'
55#' ## The _sgr flavor only treats SGR sequences as zero width
56#' nchar_sgr("\033[31m123")
57#' nchar_sgr("\t\n\n123")
58#'
59#' ## All of the following are Control Sequences or C0 controls
60#' nzchar_ctl("\n\033[42;31m\033[123P\a")
61
62nchar_ctl <- function(
63  x, type='chars', allowNA=FALSE, keepNA=NA, ctl='all',
64  warn=getOption('fansi.warn'), strip
65) {
66  if(!is.character(x)) x <- as.character(x)
67  if(!is.logical(warn)) warn <- as.logical(warn)
68  if(length(warn) != 1L || is.na(warn))
69    stop("Argument `warn` must be TRUE or FALSE.")
70
71  if(!is.logical(allowNA)) allowNA <- as.logical(allowNA)
72  if(length(allowNA) != 1L)
73    stop("Argument `allowNA` must be a scalar logical.")
74
75  if(!is.logical(keepNA)) keepNA <- as.logical(keepNA)
76  if(length(keepNA) != 1L)
77    stop("Argument `keepNA` must be a scalar logical.")
78
79  if(!missing(strip)) {
80    message("Parameter `strip` has been deprecated; use `ctl` instead.")
81    ctl <- strip
82  }
83  if(!is.character(ctl))
84    stop("Argument `ctl` must be character.")
85  if(!all(ctl %in% VALID.CTL))
86    stop(
87      "Argument `ctl` may contain only values in `", deparse(VALID.CTL), "`"
88    )
89  if(!is.character(type) || length(type) != 1 || is.na(type))
90    stop("Argument `type` must be scalar character and not NA.")
91  valid.types <- c('chars', 'width', 'bytes')
92  if(is.na(type.int <- pmatch(type, valid.types)))
93    stop(
94      "Argument `type` must partial match one of 'chars', 'width', or 'bytes'."
95    )
96  type <- valid.types[type.int]
97  stripped <- strip_ctl(x, ctl=ctl, warn=warn)
98
99  R.ver.gte.3.2.2 <- R.ver.gte.3.2.2 # "import" symbol from namespace
100  if(R.ver.gte.3.2.2) nchar(stripped, type=type, allowNA=allowNA, keepNA=keepNA)
101  else nchar(stripped, type=type, allowNA=allowNA) # nocov
102}
103#' @export
104#' @rdname nchar_ctl
105
106nchar_sgr <- function(
107  x, type='chars', allowNA=FALSE, keepNA=NA, warn=getOption('fansi.warn')
108)
109  nchar_ctl(
110    x=x, type=type, allowNA=allowNA, keepNA=keepNA, warn=warn, ctl='sgr'
111  )
112
113#' @export
114#' @rdname nchar_ctl
115
116nzchar_ctl <- function(x, keepNA=NA, ctl='all', warn=getOption('fansi.warn')) {
117  if(!is.character(x)) x <- as.character(x)
118
119  if(length(warn) != 1L || is.na(warn))
120    stop("Argument `warn` must be TRUE or FALSE.")
121
122  if(!is.logical(keepNA)) keepNA <- as.logical(keepNA)
123  if(length(keepNA) != 1L)
124    stop("Argument `keepNA` must be a scalar logical.")
125
126  if(!is.character(ctl))
127    stop("Argument `ctl` must be character.")
128  ctl.int <- integer()
129  if(length(ctl)) {
130    # duplicate values in `ctl` are okay, so save a call to `unique` here
131    if(anyNA(ctl.int <- match(ctl, VALID.CTL)))
132      stop(
133        "Argument `ctl` may contain only values in `",
134        deparse(VALID.CTL), "`"
135      )
136  }
137  term.cap.int <- seq_along(VALID.TERM.CAP)
138  .Call(FANSI_nzchar_esc, enc2utf8(x), keepNA, warn, term.cap.int, ctl.int)
139}
140#' @export
141#' @rdname nchar_ctl
142
143nzchar_sgr <- function(x, keepNA=NA, warn=getOption('fansi.warn'))
144 nzchar_ctl(x=x, keepNA=keepNA, warn=warn, ctl='sgr')
145
146