# File src/library/base/R/files.R # Part of the R package, https://www.R-project.org # # Copyright (C) 1995-2020 The R Core Team # # This program is free software; you can redistribute it and/or modify # it under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2 of the License, or # (at your option) any later version. # # This program is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # A copy of the GNU General Public License is available at # https://www.R-project.org/Licenses/ R.home <- function(component="home") { rh <- .Internal(R.home()) switch(component, "home" = rh, "bin" = if(.Platform$OS.type == "windows" && nzchar(p <- .Platform$r_arch)) file.path(rh, component, p) else file.path(rh, component), "share" = if(nzchar(p <- Sys.getenv("R_SHARE_DIR"))) p else file.path(rh, component), "doc" = if(nzchar(p <- Sys.getenv("R_DOC_DIR"))) p else file.path(rh, component), "include" = if(nzchar(p <- Sys.getenv("R_INCLUDE_DIR"))) p else file.path(rh, component), "modules" = if(nzchar(p <- .Platform$r_arch)) file.path(rh, component, p) else file.path(rh, component), file.path(rh, component)) } file.show <- function (..., header = rep("", nfiles), title = "R Information", delete.file = FALSE, pager = getOption("pager"), encoding = "") { files <- path.expand(c(...)) nfiles <- length(files) if(nfiles == 0L) return(invisible(NULL)) ## avoid re-encoding files to the current encoding. if(l10n_info()[["UTF-8"]] && encoding == "UTF-8") encoding <- "" if(l10n_info()[["Latin-1"]] && encoding == "latin1") encoding <- "" if(!is.na(encoding) && nzchar(encoding)) { for(i in seq_along(files)) { f <- files[i] tf <- tempfile() tmp <- readLines(f, warn = FALSE) tmp2 <- try(iconv(tmp, encoding, "", "byte")) if(inherits(tmp2, "try-error")) file.copy(f, tf) else writeLines(tmp2, tf) files[i] <- tf if(delete.file) unlink(f) } delete.file <- TRUE } if(is.function(pager)) pager(files, header = header, title = title, delete.file = delete.file) else .Internal(file.show(files, header, title, delete.file, pager)) } file.append <- function(file1, file2) .Internal(file.append(file1, file2)) file.remove <- function(...) .Internal(file.remove(c(...))) file.rename <- function(from, to) .Internal(file.rename(from, to)) list.files <- function(path = ".", pattern = NULL, all.files = FALSE, full.names = FALSE, recursive = FALSE, ignore.case = FALSE, include.dirs = FALSE, no.. = FALSE) .Internal(list.files(path, pattern, all.files, full.names, recursive, ignore.case, include.dirs, no..)) dir <- list.files list.dirs <- function(path = ".", full.names = TRUE, recursive = TRUE) .Internal(list.dirs(path, full.names, recursive)) file.path <- function(..., fsep=.Platform$file.sep) .Internal(file.path(list(...), fsep)) file.exists <- function(...) .Internal(file.exists(c(...))) file.create <- function(..., showWarnings = TRUE) .Internal(file.create(c(...), showWarnings)) file.choose <- function(new=FALSE) .Internal(file.choose(new)) file.copy <- function(from, to, overwrite = recursive, recursive = FALSE, copy.mode = TRUE, copy.date = FALSE) { if (!(nf <- length(from))) return(logical()) if (!(nt <- length(to))) stop("no files to copy to") ## we don't use file_test as that is in utils. if (nt == 1 && dir.exists(to)) { if (recursive && to %in% from) stop("attempt to copy a directory to itself") ## on Windows we need \ for the compiled code (e.g. mkdir). if(.Platform$OS.type == "windows") { from <- gsub("/", "\\", from, fixed = TRUE) to <- gsub("/", "\\", to, fixed = TRUE) } return(.Internal(file.copy(from, to, overwrite, recursive, copy.mode, copy.date))) } else if (nf > nt) stop("more 'from' files than 'to' files") else if (recursive) warning("'recursive' will be ignored as 'to' is not a single existing directory") if(nt > nf) from <- rep_len(from, length.out = nt) okay <- file.exists(from) if (!overwrite) okay[file.exists(to)] <- FALSE else { dirtofile <- dir.exists(from[okay]) & file.exists(to[okay]) & !dir.exists(to[okay]) if (any(dirtofile)) { warning("cannot overwrite a non-directory with a directory") okay[okay] <- !dirtofile } # note: could also warn whenever "from" is a directory as it will # be copied into an empty file, or support creating of directories } if (any(from[okay] %in% to[okay])) stop("file can not be copied both 'from' and 'to'") if (any(okay)) { # care: file.create could fail but file.append work. okay[okay] <- file.create(to[okay]) if(any(okay)) { okay[okay] <- file.append(to[okay], from[okay]) if(copy.mode || copy.date) { # file.info call can be slow fi <- file.info(from[okay], extra_cols = FALSE) if(copy.mode) Sys.chmod(to[okay], fi$mode, TRUE) if(copy.date) Sys.setFileTime(to[okay], fi$mtime) } } } okay } file.symlink <- function(from, to) { if (!(length(from))) stop("no files to link from") if (!(nt <- length(to))) stop("no files/directory to link to") if (nt == 1 && file.exists(to) && file.info(to, extra_cols = FALSE)$isdir) to <- file.path(to, basename(from)) .Internal(file.symlink(from, to)) } file.link <- function(from, to) { if (!(length(from))) stop("no files to link from") if (!length(to)) stop("no files to link to") .Internal(file.link(from, to)) } file.info <- function(..., extra_cols = TRUE) { res <- .Internal(file.info(fn <- c(...), extra_cols)) res$mtime <- .POSIXct(res$mtime) res$ctime <- .POSIXct(res$ctime) res$atime <- .POSIXct(res$atime) class(res) <- "data.frame" attr(res, "row.names") <- fn # not row.names<- as that does a length check res } ## wrappers introduced in R 3.2.0 file.mode <- function(...) file.info(..., extra_cols = FALSE)$mode file.mtime <- function(...) file.info(..., extra_cols = FALSE)$mtime file.size <- function(...) file.info(..., extra_cols = FALSE)$size file.access <- function(names, mode = 0) { res <- .Internal(file.access(names, mode)) names(res) <- names res } dir.exists <- function(paths) .Internal(dir.exists(paths)) dir.create <- function(path, showWarnings = TRUE, recursive = FALSE, mode = "0777") .Internal(dir.create(path, showWarnings, recursive, as.octmode(mode))) system.file <- function(..., package = "base", lib.loc = NULL, mustWork = FALSE) { if(nargs() == 0L) return(file.path(.Library, "base")) if(length(package) != 1L) stop("'package' must be of length 1") packagePath <- find.package(package, lib.loc, quiet = TRUE) ans <- if(length(packagePath)) { FILES <- file.path(packagePath, ...) present <- file.exists(FILES) if(any(present)) FILES[present] else "" } else "" if (mustWork && identical(ans, "")) stop("no file found") ans } getwd <- function() .Internal(getwd()) setwd <- function(dir) .Internal(setwd(dir)) basename <- function(path) .Internal(basename(path)) dirname <- function(path) .Internal(dirname(path)) Sys.info <- function() .Internal(Sys.info()) Sys.sleep <- function(time) .Internal(Sys.sleep(time)) path.expand <- function(path) .Internal(path.expand(path)) Sys.glob <- function(paths, dirmark = FALSE) .Internal(Sys.glob(path.expand(paths), dirmark)) unlink <- function(x, recursive = FALSE, force = FALSE, expand = TRUE) .Internal(unlink(as.character(x), recursive, force, expand)) Sys.chmod <- function(paths, mode = "0777", use_umask = TRUE) .Internal(Sys.chmod(paths, as.octmode(mode), use_umask)) Sys.umask <- function(mode = NA) .Internal(Sys.umask(if(is.na(mode)) NA_integer_ else as.octmode(mode))) Sys.readlink <- function(paths) .Internal(Sys.readlink(paths)) readRenviron <- function(path) .Internal(readRenviron(path)) normalizePath <- function(path, winslash = "\\", mustWork = NA) .Internal(normalizePath(path.expand(path), winslash, mustWork)) Sys.setFileTime <- function(path, time) { if (!is.character(path)) stop("invalid 'path' argument") time <- as.POSIXct(time) if (anyNA(time)) stop("invalid 'time' argument") .Internal(setFileTime(path, time)) }