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