available.packages.R

available.packages<-function (contriburl = contrib.url(getOption("repos"), type),
    method, fields = NULL, type = getOption("pkgType"), filters = NULL)
{
    requiredFields <- c(tools:::.get_standard_repository_db_fields(),
        "File")
    if (is.null(fields))
        fields <- requiredFields
    else {
        stopifnot(is.character(fields))
        fields <- unique(c(requiredFields, fields))
    }
    res <- matrix(NA_character_, 0L, length(fields) + 1L, dimnames = list(NULL,
        c(fields, "Repository")))
    for (repos in contriburl) {
        localcran <- length(grep("^file:", repos)) > 0L
        if (localcran) {
            if (substring(repos, 1L, 8L) == "file:///") {
                tmpf <- paste(substring(repos, 8L), "PACKAGES",
                  sep = "/")
                if (.Platform$OS.type == "windows") {
                  if (length(grep("^/[A-Za-z]:", tmpf)))
                    tmpf <- substring(tmpf, 2L)
                }
            }
            else {
                tmpf <- paste(substring(repos, 6L), "PACKAGES",
                  sep = "/")
            }
            res0 <- read.dcf(file = tmpf)
            if (length(res0))
                rownames(res0) <- res0[, "Package"]
        }
        else {
            dest <- file.path(tempdir(), paste0("repos_", URLencode(repos,
                TRUE), ".rds"))
            if (file.exists(dest)) {
                res0 <- readRDS(dest)
            }
            else {
                tmpf <- tempfile()
                on.exit(unlink(tmpf))
                op <- options("warn")
                options(warn = -1)
                z <- tryCatch(download.file(url = paste(repos,
                  "PACKAGES.gz", sep = "/"), destfile = tmpf,
                  method = method, cacheOK = FALSE, quiet = TRUE,
                  mode = "wb"), error = identity)
                if (!inherits(z, "error"))
                  z <- res0 <- tryCatch(read.dcf(file = tmpf),
                    error = identity)
                if (inherits(z, "error")) {
                  z <- tryCatch(download.file(url = paste(repos,
                    "PACKAGES", sep = "/"), destfile = tmpf,
                    method = method, cacheOK = FALSE, quiet = TRUE,
                    mode = "wb"), error = identity)
                  options(op)
                  if (inherits(z, "error")) {
                    warning(gettextf("unable to access index for repository %s",
                      repos), call. = FALSE, immediate. = TRUE,
                      domain = NA)
                    next
                  }
                  res0 <- read.dcf(file = tmpf)
                }
                else options(op)
                if (length(res0))
                  rownames(res0) <- res0[, "Package"]
                saveRDS(res0, dest, compress = TRUE)
                unlink(tmpf)
                on.exit()
            }
        }
        if (length(res0)) {
            missingFields <- fields[!(fields %in% colnames(res0))]
            if (length(missingFields)) {
                toadd <- matrix(NA_character_, nrow = nrow(res0),
                  ncol = length(missingFields), dimnames = list(NULL,
                    missingFields))
                res0 <- cbind(res0, toadd)
            }
            if ("Path" %in% colnames(res0)) {
                rp <- rep.int(repos, nrow(res0))
                path <- res0[, "Path"]
                rp[!is.na(path)] <- paste(repos, path[!is.na(path)],
                  sep = "/")
            }
            else rp <- repos
            res0 <- cbind(res0[, fields, drop = FALSE], Repository = rp)
            res <- rbind(res, res0)
        }
    }
    if (!length(res))
        return(res)
    if (is.null(filters)) {
        filters <- getOption("available_packages_filters")
        if (is.null(filters))
            filters <- available_packages_filters_default
    }
    if (is.list(filters)) {
        if (identical(filters$add, TRUE)) {
            filters$add <- NULL
            filters <- c(available_packages_filters_default,
                filters)
        }
    }
    for (f in filters) {
        if (!length(res))
            break
        if (is.character(f)) {
            f <- available_packages_filters_db[[f[1L]]]
        }
        if (!is.function(f))
            stop("invalid 'filters' argument.")
        res <- f(res)
    }
    res
}