1##  File src/library/utils/R/strcapture.R
2##  Part of the R package, https://www.R-project.org
3##
4##  Copyright (C) 1995-2019 The R Core Team
5##
6##  This program is free software; you can redistribute it and/or modify
7##  it under the terms of the GNU General Public License as published by
8##  the Free Software Foundation; either version 2 of the License, or
9##  (at your option) any later version.
10##
11##  This program is distributed in the hope that it will be useful,
12##  but WITHOUT ANY WARRANTY; without even the implied warranty of
13##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14##  GNU General Public License for more details.
15##
16##  A copy of the GNU General Public License is available at
17##  https://www.R-project.org/Licenses/
18
19strcapture <- function(pattern, x, proto, perl = FALSE, useBytes = FALSE) {
20    m <- regexec(pattern, x, perl=perl, useBytes=useBytes)
21    str <- regmatches(x, m)
22    ntokens <- length(proto) + 1L
23    nomatch <- lengths(str) == 0L
24    str[nomatch] <- list(rep.int(NA_character_, ntokens))
25    if (length(str) > 0L && length(str[[1L]]) != ntokens) {
26### FIXME: this will not always detect an error when there are no matches
27        stop("The number of captures in 'pattern' != 'length(proto)'")
28    }
29    mat <- matrix(as.character(unlist(str)), ncol=ntokens,
30                  byrow=TRUE)[,-1L,drop=FALSE]
31    conformToProto(mat, proto)
32}
33
34## Not yet exported
35strextract <- function(pattern, x, perl = FALSE, useBytes = FALSE) {
36    m <- regexec(pattern, x, perl=perl, useBytes=useBytes)
37    unlist(regmatches(x, m))
38}
39
40conformToProto <- function(mat, proto) {
41    ans <- lapply(seq_along(proto), function(i) {
42        if (isS4(proto[[i]])) {
43            methods::as(mat[,i], class(proto[[i]]))
44        } else {
45            fun <- match.fun(paste0("as.", class(proto[[i]])))
46            fun(mat[,i])
47        }
48    })
49    names(ans) <- names(proto)
50    if (isS4(proto)) {
51        methods::as(ans, class(proto))
52    } else {
53        as.data.frame(ans, optional=TRUE, stringsAsFactors=FALSE)
54    }
55}
56
57## Not yet exported
58strslice <- function(x, split, proto, fixed = FALSE, perl = FALSE,
59                     useBytes = FALSE)
60{
61    str <- strsplit(x, split, fixed=fixed, perl=perl, useBytes=useBytes)
62    ntokens <- length(proto)
63    if (length(str) > 0L) {
64        if (length(str[[1L]]) != ntokens) {
65            stop("The number of tokens != 'length(proto)'")
66        } else if (length(unique(lengths(str))) > 1L) {
67            stop("The number of tokens is not consistent across 'x'")
68        }
69    }
70    mat <- matrix(as.character(unlist(str)), ncol=ntokens, byrow=TRUE)
71    conformToProto(mat, proto)
72}
73
74## not yet exported; called from tools:::config_val_to_logical()
75str2logical <- function(x) {
76    if(!is.character(x)) x <- as.character(x)
77    if(!is.na(v <- as.logical(x))) # via fast C code, e.g. for "True"
78        return(v)
79    v <- tolower(x)
80    if      (v %in% c("1", "yes")) TRUE
81    else if (v %in% c("0", "no")) FALSE
82    else {
83        warning(gettextf("cannot coerce %s to logical", sQuote(x)),
84                domain = NA)
85        NA
86    }
87}
88