# 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) }