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 strtrim
18#'
19#' One difference with [base::strtrim] is that all C0 control characters such as
20#' newlines, carriage returns, etc., are treated as zero width.
21#'
22#' `strtrim2_ctl` adds the option of converting tabs to spaces before trimming.
23#' This is the only difference between `strtrim_ctl` and `strtrim2_ctl`.
24#'
25#' @note Non-ASCII strings are converted to and returned in UTF-8 encoding.
26#'   Width calculations will not work correctly with R < 3.2.2.
27#' @export
28#' @inheritSection substr_ctl _ctl vs. _sgr
29#' @seealso [fansi] for details on how _Control Sequences_ are
30#'   interpreted, particularly if you are getting unexpected results.
31#'   [strwrap_ctl] is used internally by this function.
32#' @inheritParams base::strtrim
33#' @inheritParams strwrap_ctl
34#' @examples
35#' strtrim_ctl("\033[42mHello world\033[m", 6)
36
37strtrim_ctl <- function(x, width, warn=getOption('fansi.warn'), ctl='all'){
38  if(!is.character(x)) x <- as.character(x)
39
40  if(!is.numeric(width) || length(width) != 1L || is.na(width) || width < 0)
41    stop("Argument `width` must be a positive scalar numeric.")
42
43  if(!is.logical(warn)) warn <- as.logical(warn)
44  if(length(warn) != 1L || is.na(warn))
45    stop("Argument `warn` must be TRUE or FALSE.")
46
47  if(!is.character(ctl))
48    stop("Argument `ctl` must be character.")
49  ctl.int <- integer()
50  if(length(ctl)) {
51    # duplicate values in `ctl` are okay, so save a call to `unique` here
52    if(anyNA(ctl.int <- match(ctl, VALID.CTL)))
53      stop(
54        "Argument `ctl` may contain only values in `",
55        deparse(VALID.CTL), "`"
56      )
57  }
58  # can assume all term cap available for these purposes
59
60  term.cap.int <- seq_along(VALID.TERM.CAP)
61  width <- as.integer(width)
62
63  # a bit inefficient to rely on strwrap, but oh well
64
65  res <- .Call(
66    FANSI_strwrap_csi,
67    enc2utf8(x), width,
68    0L, 0L,    # indent, exdent
69    "", "",    # prefix, initial
70    TRUE, "",  # wrap always
71    FALSE,     # strip spaces
72    FALSE, 8L,
73    warn, term.cap.int,
74    TRUE,      # first only
75    ctl.int
76  )
77  res
78}
79#' @export
80#' @rdname strtrim_ctl
81
82strtrim2_ctl <- function(
83  x, width, warn=getOption('fansi.warn'),
84  tabs.as.spaces=getOption('fansi.tabs.as.spaces'),
85  tab.stops=getOption('fansi.tab.stops'),
86  ctl='all'
87) {
88  if(!is.character(x)) x <- as.character(x)
89
90  if(!is.numeric(width) || length(width) != 1L || is.na(width) || width < 0)
91    stop("Argument `width` must be a positive scalar numeric.")
92
93  if(!is.logical(warn)) warn <- as.logical(warn)
94  if(length(warn) != 1L || is.na(warn))
95    stop("Argument `warn` must be TRUE or FALSE.")
96
97  if(!is.logical(tabs.as.spaces)) tabs.as.spaces <- as.logical(tabs.as.spaces)
98  if(length(tabs.as.spaces) != 1L || is.na(tabs.as.spaces))
99    stop("Argument `tabs.as.spaces` must be TRUE or FALSE.")
100
101  if(!is.numeric(tab.stops) || !length(tab.stops) || any(tab.stops < 1))
102    stop("Argument `tab.stops` must be numeric and strictly positive")
103
104  if(!is.character(ctl))
105    stop("Argument `ctl` must be character.")
106  ctl.int <- integer()
107  if(length(ctl)) {
108    # duplicate values in `ctl` are okay, so save a call to `unique` here
109    if(anyNA(ctl.int <- match(ctl, VALID.CTL)))
110      stop(
111        "Argument `ctl` may contain only values in `",
112        deparse(VALID.CTL), "`"
113      )
114  }
115  # can assume all term cap available for these purposes
116
117  term.cap.int <- seq_along(VALID.TERM.CAP)
118  width <- as.integer(width)
119  tab.stops <- as.integer(tab.stops)
120
121  # a bit inefficient to rely on strwrap, but oh well
122
123  res <- .Call(
124    FANSI_strwrap_csi,
125    enc2utf8(x), width,
126    0L, 0L,    # indent, exdent
127    "", "",    # prefix, initial
128    TRUE, "",  # wrap always
129    FALSE,     # strip spaces
130    tabs.as.spaces, tab.stops,
131    warn, term.cap.int,
132    TRUE,      # first only
133    ctl.int
134  )
135  res
136}
137#' @export
138#' @rdname strtrim_ctl
139
140strtrim_sgr <- function(x, width, warn=getOption('fansi.warn'))
141  strtrim_ctl(x=x, width=width, warn=warn, ctl='sgr')
142
143#' @export
144#' @rdname strtrim_ctl
145
146strtrim2_sgr <- function(x, width, warn=getOption('fansi.warn'),
147  tabs.as.spaces=getOption('fansi.tabs.as.spaces'),
148  tab.stops=getOption('fansi.tab.stops')
149)
150  strtrim2_ctl(
151    x=x, width=width, warn=warn, tabs.as.spaces=tabs.as.spaces,
152    tab.stops=tab.stops, ctl='sgr'
153  )
154