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