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