1 2is_package_archive <- function(file) { 3 (is_zip_file(file) || is_tar_gz_file(file)) && 4 is_valid_package_file_name(file) 5} 6 7is_zip_file <- function(file) { 8 buf <- readBin(file, what = "raw", n = 4) 9 length(buf) == 4 && 10 buf[1] == 0x50 && 11 buf[2] == 0x4b && 12 (buf[3] == 0x03 || buf[3] == 0x05 || buf[5] == 0x07) && 13 (buf[4] == 0x04 || buf[4] == 0x06 || buf[4] == 0x08) 14} 15 16is_gz_file <- function(file) { 17 buf <- readBin(file, what = "raw", n = 3) 18 length(buf) == 3 && 19 buf[1] == 0x1f && 20 buf[2] == 0x8b && 21 buf[3] == 0x08 22} 23 24is_tar_gz_file <- function(file) { 25 if (!is_gz_file(file)) return(FALSE) 26 con <- gzfile(file, open = "rb") 27 on.exit(close(con)) 28 buf <- readBin(con, what = "raw", n = 262) 29 length(buf) == 262 && 30 buf[258] == 0x75 && 31 buf[259] == 0x73 && 32 buf[260] == 0x74 && 33 buf[261] == 0x61 && 34 buf[262] == 0x72 35} 36 37is_valid_package_file_name <- function(filename) { 38 grepl(valid_package_archive_name, basename(filename)) 39} 40 41#' @importFrom utils untar unzip 42 43con_unzip <- function(archive, pkgname) { 44 filename <- paste0(pkgname, "/", "DESCRIPTION") 45 con <- unz(archive, filename) 46 on.exit(close(con), add = TRUE) 47 tmp <- tempfile() 48 writeLines(readLines(con), tmp) 49 tmp 50} 51 52con_untar <- function(archive, pkgname) { 53 filename <- paste0(pkgname, "/", "DESCRIPTION") 54 tmp <- tempfile() 55 suppressWarnings( 56 untar(con <- gzfile(archive, open = "rb"), files = filename, exdir = tmp) 57 ) 58 on.exit(close(con), add = TRUE) 59 file.path(tmp, pkgname, "DESCRIPTION") 60} 61 62get_description_from_package <- function(file) { 63 package_name <- sub("_.*$", "", basename(file)) 64 65 uncompress <- if (is_zip_file(file)) con_unzip else con_untar 66 desc <- uncompress(file, package_name) 67 68 if (!file.exists(desc)) { 69 stop("Cannot extract DESCRIPTION from ", sQuote(file)) 70 } 71 72 desc 73} 74