| # File src/library/base/R/srcfile.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2017 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/ |
| |
| # a srcfile is a file with a timestamp |
| |
| srcfile <- function(filename, encoding = getOption("encoding"), Enc = "unknown") |
| { |
| stopifnot(is.character(filename), length(filename) == 1L) |
| |
| ## This is small, no need to hash. |
| e <- new.env(hash = FALSE, parent = emptyenv()) |
| |
| e$wd <- getwd() |
| e$filename <- filename |
| |
| # If filename is a URL, this will return NA |
| e$timestamp <- file.mtime(filename) |
| |
| if (identical(encoding, "unknown")) encoding <- "native.enc" |
| e$encoding <- encoding |
| e$Enc <- Enc |
| |
| class(e) <- "srcfile" |
| return(e) |
| } |
| |
| print.srcfile <- function(x, ...) { |
| cat(x$filename, "\n") |
| invisible(x) |
| } |
| |
| summary.srcfile <- function(object, ...) { |
| cat(utils:::.normalizePath(object$filename, object$wd), "\n") |
| |
| if (inherits(object$timestamp, "POSIXt")) |
| cat("Timestamp: ", format(object$timestamp, usetz=TRUE), "\n", sep="") |
| |
| cat('Encoding: "', object$encoding, '"', sep="") |
| if (!is.null(object$Enc) && object$Enc != object$encoding && object$Enc != "unknown") |
| cat(', re-encoded to "', object$Enc, '"', sep="") |
| cat("\n") |
| |
| invisible(object) |
| } |
| |
| open.srcfile <- function(con, line, ...) { |
| |
| srcfile <- con |
| |
| oldline <- srcfile$line |
| if (!is.null(oldline) && oldline > line) close(srcfile) |
| |
| conn <- srcfile$conn |
| if (is.null(conn)) { |
| if (!is.null(srcfile$wd)) { |
| olddir <- setwd(srcfile$wd) |
| on.exit(setwd(olddir)) |
| } |
| timestamp <- file.mtime(srcfile$filename) |
| if (!is.null(srcfile$timestamp) |
| && !is.na(srcfile$timestamp) |
| && ( is.na(timestamp) || timestamp != srcfile$timestamp) ) |
| warning(gettextf("Timestamp of %s has changed", |
| sQuote(srcfile$filename)), |
| call. = FALSE, domain = NA) |
| if (is.null(srcfile$encoding)) encoding <- getOption("encoding") |
| else encoding <- srcfile$encoding |
| # Specifying encoding below means that reads will convert to the native encoding |
| srcfile$conn <- conn <- file(srcfile$filename, open="rt", encoding=encoding) |
| srcfile$line <- 1L |
| oldline <- 1L |
| } else if (!isOpen(conn)) { |
| open(conn, open="rt") |
| srcfile$line <- 1 |
| oldline <- 1L |
| } |
| if (oldline < line) { |
| readLines(conn, line - oldline, warn = FALSE) |
| srcfile$line <- line |
| } |
| invisible(conn) |
| } |
| |
| close.srcfile <- function(con, ...) { |
| srcfile <- con |
| conn <- srcfile$conn |
| if (is.null(conn)) return() |
| else { |
| close(conn) |
| rm(list=c("conn", "line"), envir=srcfile) |
| } |
| } |
| |
| # srcfilecopy saves a copy of lines from a file |
| |
| srcfilecopy <- function(filename, lines, timestamp = Sys.time(), isFile = FALSE) { |
| stopifnot(is.character(filename), length(filename) == 1L) |
| |
| e <- new.env(parent=emptyenv()) |
| |
| # Remove embedded newlines |
| if (any(grepl("\n", lines, fixed = TRUE, useBytes = TRUE))) |
| lines <- unlist(strsplit(sub("$", "\n", as.character(lines)), "\n")) |
| |
| e$filename <- filename |
| e$wd <- getwd() |
| e$isFile <- isFile |
| e$lines <- as.character(lines) |
| e$fixedNewlines <- TRUE # we have removed the newlines already |
| e$timestamp <- timestamp |
| e$Enc <- "unknown" |
| |
| class(e) <- c("srcfilecopy", "srcfile") |
| return(e) |
| } |
| |
| open.srcfilecopy <- function(con, line, ...) { |
| |
| srcfile <- con |
| |
| oldline <- srcfile$line |
| if (!is.null(oldline) && oldline > line) close(srcfile) |
| |
| conn <- srcfile$conn |
| if (is.null(conn)) { |
| srcfile$conn <- conn <- textConnection(srcfile$lines, open="r") |
| srcfile$line <- 1L |
| oldline <- 1L |
| } else if (!isOpen(conn)) { |
| open(conn, open="r") |
| srcfile$line <- 1L |
| oldline <- 1L |
| } |
| if (oldline < line) { |
| readLines(conn, line - oldline, warn = FALSE) |
| srcfile$line <- line |
| } |
| invisible(conn) |
| } |
| |
| srcfilealias <- function(filename, srcfile) { |
| stopifnot(is.character(filename), length(filename) == 1L) |
| |
| e <- new.env(parent=emptyenv()) |
| |
| e$filename <- filename |
| e$original <- srcfile |
| |
| class(e) <- c("srcfilealias", "srcfile") |
| return(e) |
| } |
| |
| open.srcfilealias <- function(con, line, ...) |
| open(con$original, line, ...) |
| |
| close.srcfilealias <- function(con, ...) |
| close(con$original, ...) |
| |
| .isOpen <- function(srcfile) { |
| conn <- srcfile$conn |
| return( !is.null(conn) && isOpen(conn) ) |
| } |
| |
| getSrcLines <- function(srcfile, first, last) { |
| if (first > last) return(character()) |
| if (inherits(srcfile, "srcfilealias")) |
| srcfile <- srcfile$original |
| if (inherits(srcfile, "srcfilecopy")) { |
| # Remove embedded newlines if we haven't done this already |
| if (is.null(srcfile$fixedNewlines)) { |
| lines <- srcfile$lines |
| if (any(grepl("\n", lines, fixed = TRUE, useBytes = TRUE))) |
| srcfile$lines <- unlist(strsplit(sub("$", "\n", as.character(lines)), "\n")) |
| srcfile$fixedNewlines <- TRUE |
| } |
| last <- min(last, length(srcfile$lines)) |
| if (first > last) return(character()) |
| else return(srcfile$lines[first:last]) |
| } |
| if (!.isOpen(srcfile)) on.exit(close(srcfile)) |
| conn <- open(srcfile, first) |
| lines <- readLines(conn, n = last - first + 1L, warn = FALSE) |
| # Re-encode from native encoding to specified one |
| if (!is.null(Enc <- srcfile$Enc) && !(Enc %in% c("unknown", "native.enc"))) |
| lines <- iconv(lines, "", Enc) |
| srcfile$line <- first + length(lines) |
| return(lines) |
| } |
| |
| # a srcref gives start and stop positions of text |
| # lloc entries are first_line, first_byte, last_line, last_byte, |
| # first_column, last_column, first_parse, last_parse |
| # all are inclusive |
| |
| srcref <- function(srcfile, lloc) { |
| stopifnot(inherits(srcfile, "srcfile"), length(lloc) %in% c(4L,6L,8L)) |
| if (length(lloc) == 4) lloc <- c(lloc, lloc[c(2,4)]) |
| if (length(lloc) == 6) lloc <- c(lloc, lloc[c(1,3)]) |
| structure(as.integer(lloc), srcfile=srcfile, class="srcref") |
| } |
| |
| as.character.srcref <- function(x, useSource = TRUE, to = x, ...) |
| { |
| srcfile <- attr(x, "srcfile") |
| if (!missing(to)) { |
| if (!identical(srcfile, attr(to, "srcfile"))) |
| stop("'x' and 'to' must refer to same file") |
| x[c(3L, 4L, 6L, 8L)] <- to[c(3L, 4L, 6L, 8L)] |
| } |
| if (!is.null(srcfile) && !inherits(srcfile, "srcfile")) { |
| cat("forcing class on") ## debug |
| print(utils::str(srcfile)) |
| class(srcfile) <- c("srcfilealias", "srcfile") |
| } |
| |
| if (useSource) { |
| if (inherits(srcfile, "srcfilecopy") || inherits(srcfile, "srcfilealias")) |
| lines <- try(getSrcLines(srcfile, x[7L], x[8L]), TRUE) |
| else |
| lines <- try(getSrcLines(srcfile, x[1L], x[3L]), TRUE) |
| } |
| if (!useSource || inherits(lines, "try-error")) |
| lines <- paste0("<srcref: file \"", srcfile$filename, "\" chars ", |
| x[1L], ":", x[5L], " to ", |
| x[3L], ":", x[6L], ">") |
| else if (length(lines)) { |
| enc <- Encoding(lines) |
| Encoding(lines) <- "latin1" # so byte counting works |
| if (length(lines) < x[3L] - x[1L] + 1L) |
| x[4L] <- .Machine$integer.max |
| lines[length(lines)] <- substring(lines[length(lines)], 1L, x[4L]) |
| lines[1L] <- substring(lines[1L], x[2L]) |
| Encoding(lines) <- enc |
| } |
| lines |
| } |
| |
| print.srcref <- function(x, useSource = TRUE, ...) { |
| cat(as.character(x, useSource = useSource), sep="\n") |
| invisible(x) |
| } |
| |
| summary.srcref <- function(object, useSource = FALSE, ...) { |
| cat(as.character(object, useSource = useSource), sep="\n") |
| invisible(object) |
| } |