#  File src/library/utils/R/indices.R
#  Part of the R package, http://www.R-project.org
#
#  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/

packageDescription <- function(pkg, lib.loc=NULL, fields=NULL, drop=TRUE,
			       encoding = "")
{
    retval <- list()
    if(!is.null(fields)){
        fields <- as.character(fields)
        retval[fields] <- NA
    }

    pkgpath <- ""
    ## If the NULL default for lib.loc is used, the loaded packages are
    ## searched before the libraries.
    if(is.null(lib.loc)) {
        if(pkg == "base")
            pkgpath <- file.path(.Library, "base")
        else if((envname <- paste("package:", pkg, sep = ""))
                %in% search()) {
            pkgpath <- attr(as.environment(envname), "path")
            ## could be NULL if a perverse user has been naming environmnents
            ## to look like packages.
            if(is.null(pkgpath)) pkgpath <- ""
        }
    }
    if(pkgpath == "") {
        libs <- if(is.null(lib.loc)) .libPaths() else lib.loc
        for(lib in libs)
            if(file.access(file.path(lib, pkg), 5) == 0L) {
                pkgpath <- file.path(lib, pkg)
                break
            }
    }
    if(pkgpath == "") {
        ## This is slow and does a lot of checking we do here,
        ## but is needed for versioned installs
        pkgpath <- system.file(package = pkg, lib.loc = lib.loc)
        if(pkgpath == "") {
            warning(gettextf("no package '%s' was found", pkg), domain = NA)
            return(NA)
        }
    }

    ## New in 2.7.0: look for installed metadata first.

    if(file.exists(file <- file.path(pkgpath, "Meta", "package.rds"))) {
        desc <- .readRDS(file)$DESCRIPTION
        if(length(desc) < 1)
            stop(gettextf("metadata of package '%s' is corrupt", pkg),
                 domain = NA)
        desc <- as.list(desc)
    } else if(file.exists(file <- file.path(pkgpath,"DESCRIPTION"))) {
        dcf <- read.dcf(file=file)
        if(NROW(dcf) < 1L)
            stop(gettextf("DESCRIPTION file of package '%s' is corrupt", pkg),
                 domain = NA)
        desc <- as.list(dcf[1,])
    } else file <- ""

    if(file != "") {
        ## read the Encoding field if any
        enc <- desc[["Encoding"]]
        if(!is.null(enc) && !is.na(encoding)) {
            ## Determine encoding and re-encode if necessary and possible.
            if((encoding != "" || Sys.getlocale("LC_CTYPE") != "C")
	       && capabilities("iconv")) {
                ## might have an invalid encoding ...
                newdesc <- try(lapply(desc, iconv, from=enc, to=encoding))
                if(!inherits(newdesc, "try-error")) desc <- newdesc
                else
                    warning("'DESCRIPTION' file has 'Encoding' field and re-encoding is not possible", call. = FALSE)
            } else
                warning("'DESCRIPTION' file has 'Encoding' field and re-encoding is not possible", call. = FALSE)
        }
        ## Peter Ruckdeschel: 31-03-09: set ok even if fields is NULL
        ok <- NULL
        if(length(names(desc))) 
            ok <- 1:length(names(desc))
        ## <- end of code by P.R.
        if(!is.null(fields)){
            ok <- names(desc) %in% fields
            retval[names(desc)[ok]] <- desc[ok]
        }
        else
            retval[names(desc)] <- desc
    }

    if((file == "") || (length(retval) == 0)){
        warning(gettextf("DESCRIPTION file of package '%s' is missing or broken", pkg), domain = NA)
        return(NA)
    }

    ## Peter Ruckdeschel: 31-03-09: digest svn-filled svn property tags:
    for (i in c("LastChangedDate","LastChangedRevision"))
        if (i %in% names(desc)[ok])
            retval[i] <- gsub(" \\$\\}$","",
                gsub(paste("\\{\\$",i,": ",sep=""),"",
                   retval[i]))
    ## <- end of code by P.R.

    if(drop & length(fields) == 1L)
        return(retval[[1L]])

    class(retval) <- "packageDescription"
    if(!is.null(fields)) attr(retval, "fields") <- fields
    attr(retval, "file") <- file
    retval
}


print.packageDescription <- function(x, ...)
{
    xx <- x
    xx[] <- lapply(xx, function(x) if(is.na(x)) "NA" else x)
    write.dcf(as.data.frame.list(xx, optional = TRUE))
    cat("\n-- File:", attr(x, "file"), "\n")
    if(!is.null(attr(x, "fields"))){
        cat("-- Fields read: ")
        cat(attr(x, "fields"), sep=", ")
        cat("\n")
    }
    invisible(x)
}

index.search <- function(topic, path, file = "AnIndex", type = "help")
    .Internal(index.search(topic, path, file, .Platform$file.sep, type))

print.packageIQR <-
function(x, ...)
{
    db <- x$results
    ## Split according to Package.
    out <- if(nrow(db) == 0L)
         NULL
    else
        lapply(split(1 : nrow(db), db[, "Package"]),
               function(ind) db[ind, c("Item", "Title"),
                                drop = FALSE])
    outFile <- tempfile("RpackageIQR")
    outConn <- file(outFile, open = "w")
    first <- TRUE
    for(pkg in names(out)) {
        writeLines(paste(ifelse(first, "", "\n"), x$title,
                         " in package ", sQuote(pkg), ":\n",
                         sep = ""),
                   outConn)
        writeLines(formatDL(out[[pkg]][, "Item"],
                            out[[pkg]][, "Title"]),
                   outConn)
        first <- FALSE
    }
    if(first) {
        close(outConn)
        unlink(outFile)
        writeLines(paste("no", tolower(x$title), "found"))
        if(!is.null(x$footer))
            writeLines(c("", x$footer))
    }
    else {
        if(!is.null(x$footer))
            writeLines(c("\n", x$footer), outConn)
        close(outConn)
        file.show(outFile, delete.file = TRUE,
                  title = paste("R", tolower(x$title)))
    }
    invisible(x)
}
