mirror of
https://github.com/rstudio/shiny.git
synced 2026-01-13 08:57:57 -05:00
192 lines
7.9 KiB
R
192 lines
7.9 KiB
R
# This file was pulled from the R code base as of
|
|
# Thursday, November 22, 2012 at 6:24:55 AM UTC
|
|
# and edited to remove everything but the copyright
|
|
# header and untar2, and to make untar2 more tolerant
|
|
# of the 'x' and 'g' extended block indicators, the
|
|
# latter of which is used in tar files generated by
|
|
# GitHub.
|
|
|
|
|
|
# File src/library/utils/R/tar.R
|
|
# Part of the R package, http://www.R-project.org
|
|
#
|
|
# Copyright (C) 1995-2012 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
|
|
# http://www.r-project.org/Licenses/
|
|
|
|
untar2 <- function(tarfile, files = NULL, list = FALSE, exdir = ".")
|
|
{
|
|
getOct <- function(x, offset, len)
|
|
{
|
|
x <- 0L
|
|
for(i in offset + seq_len(len)) {
|
|
z <- block[i]
|
|
if(!as.integer(z)) break; # terminate on nul
|
|
switch(rawToChar(z),
|
|
" " = {},
|
|
"0"=,"1"=,"2"=,"3"=,"4"=,"5"=,"6"=,"7"=
|
|
{x <- 8*x + (as.integer(z)-48)},
|
|
stop("invalid octal digit")
|
|
)
|
|
}
|
|
x
|
|
}
|
|
|
|
mydir.create <- function(path, ...) {
|
|
## for Windows' sake
|
|
path <- sub("[\\/]$", "", path)
|
|
if(utils::file_test("-d", path)) return()
|
|
if(!dir.create(path, showWarnings = TRUE, recursive = TRUE, ...))
|
|
stop(gettextf("failed to create directory %s", sQuote(path)),
|
|
domain = NA)
|
|
}
|
|
|
|
warn1 <- character()
|
|
|
|
## A tar file is a set of 512 byte records,
|
|
## a header record followed by file contents (zero-padded).
|
|
## See http://en.wikipedia.org/wiki/Tar_%28file_format%29
|
|
if(is.character(tarfile) && length(tarfile) == 1L) {
|
|
con <- gzfile(path.expand(tarfile), "rb") # reads compressed formats
|
|
on.exit(close(con))
|
|
} else if(inherits(tarfile, "connection")) con <- tarfile
|
|
else stop("'tarfile' must be a character string or a connection")
|
|
if (!missing(exdir)) {
|
|
mydir.create(exdir)
|
|
od <- setwd(exdir)
|
|
on.exit(setwd(od), add = TRUE)
|
|
}
|
|
contents <- character()
|
|
llink <- lname <- NULL
|
|
repeat{
|
|
block <- readBin(con, "raw", n = 512L)
|
|
if(!length(block)) break
|
|
if(length(block) < 512L) stop("incomplete block on file")
|
|
if(all(block == 0)) break
|
|
ns <- max(which(block[1:100] > 0))
|
|
name <- rawToChar(block[seq_len(ns)])
|
|
magic <- rawToChar(block[258:262])
|
|
if ((magic == "ustar") && block[346] > 0) {
|
|
ns <- max(which(block[346:500] > 0))
|
|
prefix <- rawToChar(block[345+seq_len(ns)])
|
|
name <- file.path(prefix, name)
|
|
}
|
|
## mode zero-padded 8 bytes (including nul) at 101
|
|
## Aargh: bsdtar has this one incorrectly with 6 bytes+space
|
|
mode <- as.octmode(getOct(block, 100, 8))
|
|
size <- getOct(block, 124, 12)
|
|
ts <- getOct(block, 136, 12)
|
|
ft <- as.POSIXct(as.numeric(ts), origin="1970-01-01", tz="UTC")
|
|
csum <- getOct(block, 148, 8)
|
|
block[149:156] <- charToRaw(" ")
|
|
xx <- as.integer(block)
|
|
checksum <- sum(xx) %% 2^24 # 6 bytes
|
|
if(csum != checksum) {
|
|
## try it with signed bytes.
|
|
checksum <- sum(ifelse(xx > 127, xx - 128, xx)) %% 2^24 # 6 bytes
|
|
if(csum != checksum)
|
|
warning(gettextf("checksum error for entry '%s'", name),
|
|
domain = NA)
|
|
}
|
|
type <- block[157L]
|
|
ctype <- rawToChar(type)
|
|
if(type == 0L || ctype == "0") {
|
|
if(!is.null(lname)) {name <- lname; lname <- NULL}
|
|
contents <- c(contents, name)
|
|
remain <- size
|
|
dothis <- !list
|
|
if(dothis && length(files)) dothis <- name %in% files
|
|
if(dothis) {
|
|
mydir.create(dirname(name))
|
|
out <- file(name, "wb")
|
|
}
|
|
for(i in seq_len(ceiling(size/512L))) {
|
|
block <- readBin(con, "raw", n = 512L)
|
|
if(length(block) < 512L)
|
|
stop("incomplete block on file")
|
|
if (dothis) {
|
|
writeBin(block[seq_len(min(512L, remain))], out)
|
|
remain <- remain - 512L
|
|
}
|
|
}
|
|
if(dothis) {
|
|
close(out)
|
|
Sys.chmod(name, mode, FALSE) # override umask
|
|
Sys.setFileTime(name, ft)
|
|
}
|
|
} else if(ctype %in% c("1", "2")) { # hard and symbolic links
|
|
contents <- c(contents, name)
|
|
ns <- max(which(block[158:257] > 0))
|
|
name2 <- rawToChar(block[157L + seq_len(ns)])
|
|
if(!is.null(lname)) {name <- lname; lname <- NULL}
|
|
if(!is.null(llink)) {name2 <- llink; llink <- NULL}
|
|
if(!list) {
|
|
if(ctype == "1") {
|
|
if (!file.link(name2, name)) { # will give a warning
|
|
## link failed, so try a file copy
|
|
if(file.copy(name2, name))
|
|
warn1 <- c(warn1, "restoring hard link as a file copy")
|
|
else
|
|
warning(gettextf("failed to copy %s to %s", sQuote(name2), sQuote(name)), domain = NA)
|
|
}
|
|
} else {
|
|
if(isWindows()) {
|
|
## this will not work for links to dirs
|
|
from <- file.path(dirname(name), name2)
|
|
if (!file.copy(from, name))
|
|
warning(gettextf("failed to copy %s to %s", sQuote(from), sQuote(name)), domain = NA)
|
|
else
|
|
warn1 <- c(warn1, "restoring symbolic link as a file copy")
|
|
} else {
|
|
if(!file.symlink(name2, name)) { # will give a warning
|
|
## so try a file copy: will not work for links to dirs
|
|
from <- file.path(dirname(name), name2)
|
|
if (file.copy(from, name))
|
|
warn1 <- c(warn1, "restoring symbolic link as a file copy")
|
|
else
|
|
warning(gettextf("failed to copy %s to %s", sQuote(from), sQuote(name)), domain = NA)
|
|
}
|
|
}
|
|
}
|
|
}
|
|
} else if(ctype == "5") {
|
|
contents <- c(contents, name)
|
|
if(!list) {
|
|
mydir.create(name)
|
|
Sys.chmod(name, mode, TRUE) # FIXME: check result
|
|
## no point is setting time, as dir will be populated later.
|
|
}
|
|
} else if(ctype %in% c("L", "K")) {
|
|
## This is a GNU extension that should no longer be
|
|
## in use, but it is.
|
|
name_size <- 512L * ceiling(size/512L)
|
|
block <- readBin(con, "raw", n = name_size)
|
|
if(length(block) < name_size)
|
|
stop("incomplete block on file")
|
|
ns <- max(which(block > 0)) # size on file may or may not include final nul
|
|
if(ctype == "L")
|
|
lname <- rawToChar(block[seq_len(ns)])
|
|
else
|
|
llink <- rawToChar(block[seq_len(ns)])
|
|
} else if(ctype %in% c("x", "g")) {
|
|
readBin(con, "raw", n = 512L*ceiling(size/512L))
|
|
} else stop("unsupported entry type ", sQuote(ctype))
|
|
}
|
|
if(length(warn1)) {
|
|
warn1 <- unique(warn1)
|
|
for (w in warn1) warning(w, domain = NA)
|
|
}
|
|
if(list) contents else invisible(0L)
|
|
}
|