1#  File src/library/base/R/connections.R
2#  Part of the R package, https://www.R-project.org
3#
4#  Copyright (C) 1995-2020 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
19stdin <- function() .Internal(stdin())
20stdout <- function() .Internal(stdout())
21stderr <- function() .Internal(stderr())
22
23nullfile <- function()
24    if (.Platform$OS.type == "windows") "nul:" else "/dev/null"
25
26isatty <- function(con) {
27    if (!inherits(con, "terminal")) FALSE
28    else .Internal(isatty(con))
29}
30
31readLines <- function(con = stdin(), n = -1L, ok = TRUE, warn = TRUE,
32                      encoding = "unknown", skipNul = FALSE)
33{
34    if(is.character(con)) {
35        con <- file(con, "r")
36        on.exit(close(con))
37    }
38    .Internal(readLines(con, n, ok, warn, encoding, skipNul))
39}
40
41
42writeLines <- function(text, con = stdout(), sep = "\n", useBytes = FALSE)
43{
44    if(!is.character(text))
45        stop("can only write character objects")
46    if(is.character(con)) {
47        con <- file(con, "w")
48        on.exit(close(con))
49    }
50    .Internal(writeLines(text, con, sep, useBytes))
51}
52
53open <- function(con, ...)
54    UseMethod("open")
55
56open.connection <- function(con, open = "r", blocking = TRUE, ...)
57    .Internal(open(con, open, blocking))
58
59isOpen <- function(con, rw = "")
60{
61    rw <- pmatch(rw, c("read", "write"), 0L)
62    .Internal(isOpen(con, rw))
63}
64
65isIncomplete <- function(con)
66    .Internal(isIncomplete(con))
67
68isSeekable <- function(con)
69    .Internal(isSeekable(con))
70
71close <- function(con, ...)
72    UseMethod("close")
73
74close.connection <- function (con, type = "rw", ...)
75    .Internal(close(con, type))
76
77flush <- function(con) UseMethod("flush")
78
79flush.connection <- function (con)
80    .Internal(flush(con))
81
82file <- function(description = "", open = "", blocking = TRUE,
83                 encoding = getOption("encoding"), raw = FALSE,
84                 method = getOption("url.method", "default")) {
85    .Internal(file(description, open, blocking, encoding, method, raw))
86}
87pipe <- function(description, open = "", encoding = getOption("encoding"))
88    .Internal(pipe(description, open, encoding))
89
90fifo <- function(description, open = "", blocking = FALSE,
91                 encoding = getOption("encoding"))
92    .Internal(fifo(description, open, blocking, encoding))
93
94url <- function(description, open = "", blocking = TRUE,
95                encoding = getOption("encoding"),
96                method = getOption("url.method", "default"), headers = NULL)
97{
98    method <- match.arg(method, c("default", "internal", "libcurl", "wininet"))
99    if(!is.null(headers)) {
100        nh <- names(headers)
101        if(length(nh) != length(headers) || any(nh == "") || anyNA(headers) || anyNA(nh))
102            stop("'headers' must have names and must not be NA")
103        headers <- paste0(nh, ": ", headers)
104        headers <- list(headers, paste0(headers, "\r\n", collapse = ""))
105    }
106    .Internal(url(description, open, blocking, encoding, method, headers))
107}
108
109gzfile <- function(description, open = "",
110                   encoding = getOption("encoding"), compression = 6)
111    .Internal(gzfile(description, open, encoding, compression))
112
113unz <- function(description, filename, open = "",
114                encoding = getOption("encoding"))
115    .Internal(unz(paste(description, filename, sep=":"), open, encoding))
116
117bzfile <- function(description, open = "", encoding = getOption("encoding"),
118                   compression = 9)
119    .Internal(bzfile(description, open, encoding, compression))
120
121xzfile <- function(description, open = "", encoding = getOption("encoding"),
122                   compression = 6)
123    .Internal(xzfile(description, open, encoding, compression))
124
125socketConnection <- function(host = "localhost", port, server = FALSE,
126                             blocking = FALSE, open = "a+",
127                             encoding = getOption("encoding"),
128                             timeout = getOption("timeout"),
129                             options = getOption("socketOptions"))
130    .Internal(socketConnection(host, port, server, blocking, open, encoding,
131                               timeout, options))
132
133socketAccept <- function(socket, blocking = FALSE, open = "a+",
134                         encoding = getOption("encoding"),
135                         timeout = getOption("timeout"),
136                         options = getOption("socketOptions"))
137    .Internal(socketAccept(socket, blocking, open, encoding, timeout, options))
138
139serverSocket <- function(port)
140    .Internal(serverSocket(port))
141
142socketTimeout <- function(socket, timeout = -1)
143    .Internal(socketTimeout(socket, timeout))
144
145rawConnection <- function(object, open = "r") {
146    .Internal(rawConnection(deparse(substitute(object)), object, open))
147}
148
149rawConnectionValue <- function(con) .Internal(rawConnectionValue(con))
150
151textConnection <- function(object, open = "r", local = FALSE,
152                           name = deparse(substitute(object)),
153                           encoding = c("", "bytes", "UTF-8"))
154{
155    env <- if (local) parent.frame() else .GlobalEnv
156    type <- match(match.arg(encoding), c("", "bytes", "UTF-8"))
157    if(!(is.character(name) && length(name) == 1))
158        stop(if(missing(name))
159                 "argument 'object' must deparse to a single character string"
160             else "'name' must be a single character string")
161    .Internal(textConnection(name, object, open, env, type))
162}
163
164textConnectionValue <- function(con) .Internal(textConnectionValue(con))
165
166seek <- function(con, ...)
167    UseMethod("seek")
168
169seek.connection <- function(con, where = NA, origin = "start", rw = "", ...)
170{
171    origin <- pmatch(origin, c("start", "current", "end"))
172    rw <- pmatch(rw, c("read", "write"), 0L)
173    if(is.na(origin))
174        stop("'origin' must be one of 'start', 'current' or 'end'")
175    .Internal(seek(con, as.double(where), origin, rw))
176}
177
178truncate <- function(con, ...)
179    UseMethod("truncate")
180
181truncate.connection <- function(con, ...)
182{
183    if(!isOpen(con)) stop("can only truncate an open connection")
184    .Internal(truncate(con))
185}
186
187pushBack <- function(data, connection, newLine = TRUE,
188                     encoding = c("", "bytes", "UTF-8"))
189{
190    # match.arg doesn't work on "" default
191    if (length(encoding) > 1L) encoding <- encoding[1]
192    if (nzchar(encoding)) encoding <- match.arg(encoding)
193    type <- match(encoding, c("", "bytes", "UTF-8"))
194    .Internal(pushBack(data, connection, newLine, type))
195}
196
197pushBackLength <- function(connection)
198    .Internal(pushBackLength(connection))
199
200clearPushBack <- function(connection)
201    .Internal(clearPushBack(connection))
202
203print.connection <- function(x, ...)
204{
205    usumm <- tryCatch(unlist(summary(x)), error = function(e) {})
206    ## could also show  as.numeric(x) {as str() currently does}
207    if(is.null(usumm)) {
208	cl <- oldClass(x); cl <- cl[cl != "connection"]
209	cat("A connection, ",
210	    if(length(cl)) paste0("specifically, ",
211				  paste(sQuote(cl), collapse=", "), ", "),
212	    "but invalid.\n", sep = "")
213    } else {
214	cat("A connection with") # {newline from print() below}
215	print(cbind(` ` = usumm), ...)
216    }
217    invisible(x)
218}
219
220summary.connection <- function(object, ...)
221    .Internal(summary.connection(object))
222
223showConnections <- function(all = FALSE)
224{
225    gc() # to run finalizers
226    set <- getAllConnections()
227    if(!all) set <- set[set > 2L]
228    ans <- matrix("", length(set), 7L)
229    for(i in seq_along(set)) ans[i, ] <- unlist(summary.connection(set[i]))
230    rownames(ans) <- set
231    colnames(ans) <- c("description", "class", "mode", "text", "isopen",
232                       "can read", "can write")
233    if(!all) ans[ans[, 5L] == "opened", , drop = FALSE]
234    else ans[, , drop = FALSE]
235}
236
237## undocumented
238getAllConnections <- function() .Internal(getAllConnections())
239
240getConnection <- function(what) .Internal(getConnection(what))
241
242closeAllConnections <- function()
243{
244    ## first re-divert any diversion of stderr.
245    i <- sink.number(type = "message")
246    if(i > 0L) sink(stderr(), type = "message")
247    ## now unwind the sink diversion stack.
248    n <- sink.number()
249    if(n > 0L) for(i in seq_len(n)) sink()
250    gc() # to run finalizers
251    ## get all the open connections.
252    set <- getAllConnections()
253    set <- set[set > 2L]
254    ## and close all user connections.
255    for(i in seq_along(set)) close(getConnection(set[i]))
256    invisible()
257}
258
259readBin <- function(con, what, n = 1L, size = NA_integer_, signed = TRUE,
260                    endian = .Platform$endian)
261{
262    if (!endian %in% c("big", "little", "swap"))
263        stop("invalid 'endian' argument")
264    if(is.character(con)) {
265        con <- file(con, "rb")
266        on.exit(close(con))
267    }
268    swap <- endian != .Platform$endian
269    if(!is.character(what) || is.na(what) ||
270       length(what) != 1L || ## hence length(what) == 1:
271       !any(what == c("numeric", "double", "integer", "int", "logical",
272	    "complex", "character", "raw")))
273	what <- typeof(what)
274    .Internal(readBin(con, what, n, size, signed, swap))
275}
276
277writeBin <-
278    function(object, con, size = NA_integer_, endian = .Platform$endian,
279             useBytes = FALSE)
280{
281    if (!endian %in% c("big", "little", "swap"))
282        stop("invalid 'endian' argument")
283    swap <- endian != .Platform$endian
284    if(!is.vector(object) || mode(object) == "list")
285        stop("can only write vector objects")
286    if(is.character(con)) {
287        con <- file(con, "wb")
288        on.exit(close(con))
289    }
290    .Internal(writeBin(object, con, size, swap, useBytes))
291}
292
293readChar <- function(con, nchars, useBytes = FALSE)
294{
295    if(is.character(con)) {
296        con <- file(con, "rb")
297        on.exit(close(con))
298    }
299    .Internal(readChar(con, as.integer(nchars), useBytes))
300}
301
302writeChar <- function(object, con, nchars = nchar(object, type="chars"),
303                      eos = "", useBytes = FALSE)
304{
305    if(!is.character(object))
306        stop("can only write character objects")
307    if(is.character(con)) {
308        con <- file(con, "wb")
309        on.exit(close(con))
310    }
311    .Internal(writeChar(object, con, as.integer(nchars), eos, useBytes))
312}
313
314gzcon <- function(con, level = 6, allowNonCompressed = TRUE, text = FALSE)
315    .Internal(gzcon(con, level, allowNonCompressed, text))
316
317socketSelect <- function(socklist, write = FALSE, timeout = NULL) {
318    if (is.null(timeout))
319        timeout <- -1
320    else if (timeout < 0)
321        stop("'timeout' must be NULL or a non-negative number")
322    if (length(write) < length(socklist))
323        write <- rep_len(write, length(socklist))
324    .Internal(sockSelect(socklist, write, timeout))
325}
326
327memCompress <-
328    function(from, type = c("gzip", "bzip2", "xz", "none"))
329{
330    if(is.character(from))
331        from <- charToRaw(paste(from, collapse = "\n"))
332    else if(!is.raw(from)) stop("'from' must be raw or character")
333    type <- match(match.arg(type), c("none", "gzip", "bzip2", "xz"))
334    .Internal(memCompress(from, type))
335}
336
337memDecompress <-
338    function(from,
339             type = c("unknown", "gzip", "bzip2", "xz", "none"),
340             asChar = FALSE)
341{
342    type <- match(match.arg(type),
343                  c("none", "gzip", "bzip2", "xz", "unknown"))
344    ans <- .Internal(memDecompress(from, type))
345    if(asChar) rawToChar(ans) else ans
346}
347