#  File src/library/tools/R/Rd.R
#  Part of the R package, https://www.R-project.org
#
#  Copyright (C) 1995-2015 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
#  https://www.R-project.org/Licenses/

### * Rd_info

Rd_info <-
function(file, encoding = "unknown")
{
    ## <FIXME>
    ## This used to work only for a given Rd file.
    ## now only for a parsed Rd object.

    if(inherits(file, "Rd")) {
        Rd <- file
        description <- attr(attr(Rd, "srcref"), "srcfile")$filename
    } else
        stop("Rd object required")

    aliases <- .Rd_get_metadata(Rd, "alias")
    concepts <- .Rd_get_metadata(Rd, "concept")
    keywords <- .Rd_get_metadata(Rd, "keyword") %w/o% .Rd_keywords_auto

    ## Could be none or more than one ... argh.
    Rd_type <- .Rd_get_doc_type(Rd)
    encoding <- c(.Rd_get_metadata(Rd, "encoding"), "")[1L]

    Rd_name <- .Rd_get_name(Rd)
    if(!length(Rd_name)) {
        msg <-
            c(gettextf("missing/empty %s field in '%s'",
                       "\\name",
                       description),
              gettextf("Rd files must have a non-empty %s.",
                       "\\name"),
              gettext("See chapter 'Writing R documentation' in manual 'Writing R Extensions'."))
        stop(paste(msg, collapse = "\n"), domain = NA)
    }

    Rd_title <- .Rd_get_title(Rd)
    if(!nchar(Rd_title)) {
        msg <-
            c(gettextf("missing/empty \\title field in '%s'",
                       description),
              gettext("Rd files must have a non-empty \\title."),
              gettext("See chapter 'Writing R documentation' in manual 'Writing R Extensions'."))
        stop(paste(msg, collapse = "\n"), domain = NA)
    }

    list(name = Rd_name, type = Rd_type, title = Rd_title,
         aliases = aliases, concepts = concepts, keywords = keywords,
         encoding = encoding)
}

### * Rd_contents

Rd_contents <-
function(db)
{
    ## Compute contents db from Rd db.
    ## NB: Encoding is the encoding declared in the file, not
    ## that after parsing.
    if(!length(db)) {
        out <- data.frame(File = character(),
                          Name = character(),
                          Type = character(),
                          Title = character(),
                          Encoding = character(),
                          stringsAsFactors = FALSE)
        out$Aliases <- list()
        out$Concepts <- list()
        out$Keywords <- list()
        return(out)
    }

    entries <- c("Name", "Type", "Title", "Aliases", "Concepts",
                 "Keywords", "Encoding")
    contents <- vector("list", length(db) * length(entries))
    dim(contents) <- c(length(db), length(entries))
    for(i in seq_along(db)) {
        contents[i, ] <- Rd_info(db[[i]])
    }
    colnames(contents) <- entries

    title <- .Rd_format_title(unlist(contents[ , "Title"]))
    out <- data.frame(File = basename(names(db)),
                      Name = unlist(contents[ , "Name"]),
                      Type = unlist(contents[ , "Type"]),
                      Title = title,
                      Encoding = unlist(contents[ , "Encoding"]),
                      row.names = NULL, # avoid trying to compute row
                                        # names
                      stringsAsFactors = FALSE)
    out$Aliases <- contents[ , "Aliases"]
    out$Concepts <- contents[ , "Concepts"]
    out$Keywords <- contents[ , "Keywords"]
    out
}

### * .write_Rd_contents_as_RDS

.write_Rd_contents_as_RDS <-
function(contents, outFile)
{
    ## Save Rd contents db to @file{outFile}.

    ## <NOTE>
    ## To deal with possible changes in the format of the contents db
    ## in the future, use a version attribute and/or a formal class.
    saveRDS(contents, file = outFile, compress = TRUE)
    ## </NOTE>
}

### * .write_Rd_contents_as_DCF

if(FALSE) {
.write_Rd_contents_as_DCF <-
function(contents, packageName, outFile)
{
    ## Write a @file{CONTENTS} DCF file from an Rd contents db.
    ## Note that these files currently have @samp{URL:} entries which
    ## contain the package name, whereas @code{Rd_contents()} works on
    ## collections of Rd files which do not necessarily all come from
    ## the same package ...

    ## If the contents is 'empty', return immediately.  (Otherwise,
    ## e.g. URLs would not be right ...)
    if(!NROW(contents)) return()

    ## <NOTE>
    ## This has 'html' hard-wired.
    ## Note that slashes etc. should be fine for URLs.
    URLs <- paste0("../../../library/", packageName, "/html/",
                   file_path_sans_ext(contents[ , "File"]),
                   ".html")
    ## </NOTE>

    if(is.data.frame(contents))
        contents <-
            cbind(contents$Name,
                  vapply(contents$Aliases, paste, "", collapse = " "),
                  vapply(contents$Keywords, paste, "", collapse = " "),
                  contents$Title)
    else
        contents <-
            contents[, c("Name", "Aliases", "Keywords", "Title"),
                     drop = FALSE]

    cat(paste(c("Entry:", "Aliases:", "Keywords:", "Description:",
                "URL:"),
              t(cbind(contents, URLs))),
        sep = c("\n", "\n", "\n", "\n", "\n\n"),
        file = outFile)
}
}

### * .build_Rd_index

.build_Rd_index <-
function(contents, type = NULL)
{
    ## Build an Rd 'index' containing Rd "names" (see below) and titles,
    ## maybe subscripted according to the Rd type (\docType).

    keywords <- contents[ , "Keywords"]

    if(!is.null(type)) {
        idx <- contents[ , "Type"] %in% type
        ## Argh.  Ideally we only want to subscript according to
        ## \docType.  Maybe for 2.0 ...
        if(type == "data")
            idx <- idx | keywords == "datasets"
        ## (Note: we really only want the Rd objects which have
        ## 'datasets' as their *only* keyword.)
        contents <- contents[idx, , drop = FALSE]
        keywords <- keywords[idx]
    }

    ## Drop all Rd objects marked as 'internal' from the index.
    idx <- (vapply(keywords,
                   function(x) match("internal", x, 0L),
                   0L) == 0L)
    index <- contents[idx, c("Name", "Title"), drop = FALSE]
    if(nrow(index)) {
        ## If a \name is not a valid \alias, replace it by the first
        ## alias.
        aliases <- contents[idx, "Aliases"]
        bad <- which(!mapply("%in%", index[, 1L], aliases))
        if(any(bad)) {
            ## was [[, but that applies to lists not char vectors
            tmp <- sapply(aliases[bad], "[", 1L)
            tmp[is.na(tmp)] <- ""
            index[bad, 1L] <- tmp
        }
        ## and sort it by name
        index <- index[sort.list(index[, 1L]), ]
    }
    index
}

### * Rdindex

Rdindex <-
function(RdFiles, outFile = "", type = NULL,
         width = 0.9 * getOption("width"), indent = NULL)
{
    ## Create @file{INDEX} or @file{data/00Index} style files from Rd
    ## files.
    ##
    ## R version of defunct @code{R CMD Rdindex} (now removed).
    ##
    ## called from R CMD build

    if((length(RdFiles) == 1L) && dir.exists(RdFiles)) {
        ## Compatibility code for the former @code{R CMD Rdindex}
        ## interface.
        docsDir <- RdFiles
        if(dir.exists(file.path(docsDir, "man")))
            docsDir <- file.path(docsDir, "man")
        RdFiles <- list_files_with_type(docsDir, "docs")
    }

    if(outFile == "")
        outFile <- stdout()
    else if(is.character(outFile)) {
        outFile <- file(outFile, "w")
        on.exit(close(outFile))
    }
    if(!inherits(outFile, "connection"))
        stop("argument 'outFile' must be a character string or connection")

    db <- .build_Rd_db(files = RdFiles, stages="build")
    index <- .build_Rd_index(Rd_contents(db), type = type)
    writeLines(formatDL(index, width = width, indent = indent), outFile)
}

### * Rd_db

Rd_db <-
function(package, dir, lib.loc = NULL, stages = "build")
{
    ## Build an Rd 'data base' from an installed package or the unpacked
    ## package sources as a list containing the parsed Rd objects.

    ## <NOTE>
    ## We actually also process platform conditionals.
    ## If this was to be changed, we could also need to arrange that Rd
    ## objects in *all* platform specific subdirectories are included.
    ## </NOTE>

    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
        ## Using package installed in @code{dir} ...
        docs_dir <- file.path(dir, "man")
        ## For an installed package, we might have
        ##
        ## 1) pre-2.10.0-style  man/package.Rd.gz
        ## file with suitable concatenated Rd sources,
        ##
        ## 2) help/package.rd[bx]
        ## with a DB of the parsed (and platform processed, see
        ## above) Rd objects.
        db_file <- file.path(dir, "help", package)
        if(file_test("-f", paste0(db_file, ".rdx"))) {
            db <- fetchRdDB(db_file)
            pathfile <- file.path(dir, "help", "paths.rds")
            if(file.exists(pathfile)) {
                paths <- readRDS(pathfile)
                if(!is.null(first <- attr(paths, "first")))
                    paths <- substring(paths, first)
                names(db) <- paths
            }
            return(db)
        }
        db_file <- file.path(docs_dir, sprintf("%s.Rd.gz", package))
        if(file_test("-f", db_file)) {
            lines <- .read_Rd_lines_quietly(db_file)
            eof_pos <-
                grep("^\\\\eof$", lines, perl = TRUE, useBytes = TRUE)
            db <- split(lines[-eof_pos],
                        rep.int(seq_along(eof_pos),
                                diff(c(0, eof_pos)))[-eof_pos])
        } else return(structure(list(), names = character()))

        ## NB: we only get here for pre-2.10.0 installs

        ## If this was installed using a recent enough version of R CMD
        ## INSTALL, information on source file names is available, and
        ## we use it for the names of the Rd db.  Otherwise, remove the
        ## artificial names attribute.
        paths <- as.character(sapply(db, "[", 1L))
        names(db) <-
            if(length(paths)
               && all(grepl("^% --- Source file: (.+) ---$", paths)))
                sub("^% --- Source file: (.+) ---$", "\\1", paths)
            else
                NULL
        ## Determine package encoding.
        encoding <- .get_package_metadata(dir, TRUE)["Encoding"]
        if(is.na(encoding)) encoding <- "unknown"
        db <- suppressWarnings(lapply(db,
                                      prepare_Rd_from_Rd_lines,
                                      encoding = encoding,
                                      defines = .Platform$OS.type,
                                      stages = "install"))
    }
    else {
        if(missing(dir))
            stop("you must specify 'package' or 'dir'")
        ## Using sources from directory @code{dir} ...
        if(!dir.exists(dir))
            stop(gettextf("directory '%s' does not exist", dir),
                 domain = NA)
        else
            dir <- file_path_as_absolute(dir)
        built_file <- file.path(dir, "build", "partial.rdb")
        db <- .build_Rd_db(dir,
                           stages = stages,
                           built_file = built_file)
        if(length(db)) {
            first <- nchar(file.path(dir, "man")) + 2L
            names(db) <- substring(names(db), first)
        }
    }

    db

}

prepare_Rd_from_Rd_lines <-
function(x, ...)
{
    con <- textConnection(x, "rt")
    on.exit(close(con))
    prepare_Rd(con, ...)
}

.build_Rd_db <-
function(dir = NULL, files = NULL,
         encoding = "unknown", db_file = NULL,
         stages = c("build", "install"), os = .OStype(), step = 3L,
         built_file = NULL, macros = character())
{
    if(!is.null(dir)) {
        dir <- file_path_as_absolute(dir)
        macros0 <- loadPkgRdMacros(dir)
        man_dir <- file.path(dir, "man")
        if(!dir.exists(man_dir))
            return(structure(list(), names = character()))
        if(is.null(files))
            files <- list_files_with_type(man_dir, "docs", OS_subdirs=os)
        encoding <- .get_package_metadata(dir, FALSE)["Encoding"]
        if(is.na(encoding)) encoding <- "unknown"
    } else if(!is.null(files))
        macros0 <- initialRdMacros()
    else
        stop("you must specify 'dir' or 'files'")

    if(length(macros)) {
        con <- textConnection(macros)
        macros <- loadRdMacros(con, macros0)
        close(con)
    } else {
        macros <- macros0
    }

    .fetch_Rd_object <- function(f) {
        ## This calls parse_Rd if f is a filename
        Rd <- prepare_Rd(f, encoding = encoding,
                         defines = os,
                         stages = stages, warningCalls = FALSE,
                         stage2 = step > 1L, stage3 = step > 2L,
                         macros = macros)
        structure(Rd, prepared = step)
    }

    if(!is.null(db_file) && file_test("-f", db_file)) {
        ## message("updating database of parsed Rd files")
        db <- fetchRdDB(sub("\\.rdx$", "", db_file))
        db_names <- names(db) <-
            readRDS(file.path(dirname(db_file), "paths.rds"))
        ## Files in the db in need of updating:
        indf <- (files %in% db_names) & file_test("-nt", files, db_file)
        ## Also files not in the db:
        indf <- indf | (files %notin% db_names)

        ## Db elements missing from files:
        ind <- (db_names %notin% files) | (db_names %in% files[indf])
	if(any(ind))
            db <- db[!ind]
	files <- files[indf]
    } else
    	db <- list()

    # The built_file is a file of partially processed Rd objects, where build time
    # \Sexprs have been evaluated.  We'll put the object in place of its
    # filename to continue processing.

    names(files) <- files
    if(!is.null(built_file) && file_test("-f", built_file)) {
        basenames <- basename(files)
 	built <- readRDS(built_file)
 	names_built <- names(built)
 	if ("install" %in% stages) {
 	    this_os <- grepl(paste0("^", os, "/"), names_built)
 	    name_only <- basename(names_built[this_os])
 	    built[name_only] <- built[this_os]
 	    some_os <- grepl("/", names(built))
 	    built <- built[!some_os]
 	    names_built <- names(built)
 	}
 	built[names_built %notin% basenames] <- NULL
 	if (length(built)) {
 	    which <- match(names(built), basenames)
 	    if (all(file_test("-nt", built_file, files[which]))) {
 	    	files <- as.list(files)
	    	files[which] <- built
	    }
	}
    }

    if(length(files)) {
        ## message("building database of parsed Rd files")
        db1 <- lapply(files, .fetch_Rd_object)
        names(db1) <- names(files)
        db <- c(db, db1)
    }

    db
}

### * Rd_aliases

## Called from undoc and .check_Rd_xrefs
Rd_aliases <-
function(package, dir, lib.loc = NULL)
{
    ## Get the Rd aliases (topics) from an installed package or the
    ## unpacked package sources.

    if(!missing(package)) {
        dir <- find.package(package, lib.loc)
        rds <- file.path(dir, "Meta", "Rd.rds")
        if(file_test("-f", rds)) {
            aliases <- readRDS(rds)$Aliases
            if(length(aliases)) sort(unlist(aliases)) else character()
        } else
            character()
        ## <NOTE>
        ## Alternatively, we could get the aliases from the help index
        ## (and in fact, earlier versions of this code, then part of
        ## undoc(), did so), along the lines of
        ## <CODE>
        ##   help_index <- file.path(dir, "help", "AnIndex")
        ##   all_doc_topics <- if(!file_test("-f", help_index))
        ##       character()
        ##   else
        ##       sort(scan(file = helpIndex, what = list("", ""),
        ##                 sep = "\t", quote = "", quiet = TRUE,
        ##                 na.strings = character())[[1L]])
        ## </CODE>
        ## This gets all topics the same way as index.search() would
        ## find individual ones.
        ## </NOTE>
    }
    else {
        if(dir.exists(file.path(dir, "man"))) {
            db <- Rd_db(dir = dir)
            aliases <- lapply(db, .Rd_get_metadata, "alias")
            if(length(aliases))
                sort(unique(unlist(aliases, use.names = FALSE)))
            else character()
        }
        else
            character()
    }
}

### .build_Rd_xref_db

.build_Rd_xref_db <-
function(package, dir, lib.loc = NULL)
{
    db <- if(!missing(package))
        Rd_db(package, lib.loc = lib.loc)
    else
        Rd_db(dir = dir)
    lapply(db, .Rd_get_xrefs)
}

### * .Rd_get_metadata

.Rd_get_metadata <-
function(x, kind)
{
    x <- x[RdTags(x) == sprintf("\\%s", kind)]
    if(!length(x))
        character()
    else
        unique(trimws(sapply(x, as.character)))
}

### * .Rd_keywords_auto

.Rd_keywords_auto <-
    c("~kwd1", "~kwd2", "~~ other possible keyword(s) ~~")

### * .Rd_get_section

.Rd_get_section <-
function(x, which, predefined = TRUE)
{
    if(predefined)
        x <- x[RdTags(x) == paste0("\\", which)]
    else {
        ## User-defined sections are parsed into lists of length 2, with
        ## the elements the title and the body, respectively.
        x <- x[RdTags(x) == "\\section"]
        if(length(x)) {
            ind <- sapply(x, function(e) .Rd_get_text(e[[1L]])) == which
            x <- lapply(x[ind], `[[`, 2L)
        }
    }
    if(!length(x)) x else structure(x[[1L]], class = "Rd")
}

### * .Rd_deparse

.Rd_deparse <-
function(x, tag = TRUE)
{
    ## <NOTE>
    ## This should eventually get an option controlling whether to
    ## escape Rd special characters as needed (thus providing valid Rd)
    ## or not.
    ## It might also be useful to have an option for dropping comments.
    ## </NOTE>
    if(!tag)
        attr(x, "Rd_tag") <- "Rd"
    paste(as.character.Rd(x), collapse = "")
}

### * .Rd_drop_comments

.Rd_drop_comments <-
function(x)
    .Rd_drop_nodes_with_tags(x, "COMMENT")

### * .Rd_drop_nodes_with_tags

.Rd_drop_nodes_with_tags <-
function(x, tags)
{
    recurse <- function(e) {
        if(is.list(e))
            structure(lapply(e[is.na(match(RdTags(e), tags))], recurse),
                      Rd_tag = attr(e, "Rd_tag"))
        else
            e
    }
    recurse(x)
}

### * .Rd_get_argument_names

.Rd_get_argument_names <-
function(x)
{
    x <- .Rd_get_section(x, "arguments")
    if(!length(x)) return(character())
    txt <- .Rd_get_item_tags(x)
    txt <- unlist(strsplit(txt, ", *"))
    txt <- gsub("\\\\l?dots", "...", txt)
    txt <- gsub("\\\\_", "_", txt)
    trimws(txt)
}

### * .Rd_get_argument_table

.Rd_get_argument_table <-
function(x)
{
    x <- .Rd_get_section(x, "arguments")
    if(!length(x)) return(matrix(character(), 0L, 2L))
    ## Extract two-arg \item tags at top level ... non-recursive.
    x <- x[RdTags(x) == "\\item"]
    if(!length(x)) return(matrix(character(), 0L, 2L))
    x <- lapply(x[lengths(x) == 2L], sapply, .Rd_deparse)
    matrix(unlist(x), ncol = 2L, byrow = TRUE)
}

### * .Rd_get_item_tags

.Rd_get_item_tags <-
function(x)
{
    ## Extract two-arg \item tags at top level ... non-recursive.
    x <- x[RdTags(x) == "\\item"]
    out <- lapply(x[lengths(x) == 2L],
                  function(e) .Rd_deparse(e[[1L]]))
    as.character(unlist(out))
}

### * .Rd_get_example_code

.Rd_get_example_code <-
function(x)
{
    x <- .Rd_get_section(x, "examples")
    if(!length(x)) return(character())

    ## Need to remove everything inside \dontrun (and drop comments),
    ## and "undefine" \dontshow and \testonly (which is achieved by
    ## changing the Rd tag to "Rd").

    ## <FIXME>
    ## Remove eventually.
    x <- .Rd_drop_comments(x)
    ## </FIXME>

    recurse <- function(e) {
        if(!is.null(tag <- attr(e, "Rd_tag"))
           && tag %in% c("\\dontshow", "\\testonly"))
            attr(e, "Rd_tag") <- "Rd"
        if(is.list(e)) {
            structure(lapply(e[is.na(match(RdTags(e), "\\dontrun"))],
                             recurse),
                      Rd_tag = attr(e, "Rd_tag"))
        }
        else e
    }

    .Rd_deparse(recurse(x), tag = FALSE)
}

### * .Rd_get_methods_description_table

.Rd_get_methods_description_table <-
function(x)
{
    y <- matrix(character(), 0L, 2L)
    x <- .Rd_get_section(x, "Methods", FALSE)
    if(!length(x)) return(y)
    x <- .Rd_get_section(x, "describe")
    if(!length(x)) return(y)
    x <- x[RdTags(x) == "\\item"]
    if(!length(x)) return(y)
    x <- lapply(x[lengths(x) == 2L], sapply, .Rd_deparse)
    matrix(unlist(x), ncol = 2L, byrow = TRUE)
}

### * .Rd_get_doc_type

.Rd_get_doc_type <-
function(x)
{
    c(attr(x, "meta")$docType, .Rd_get_metadata(x, "docType"), "")[1L]
}

### * .Rd_get_name

.Rd_get_name <-
function(x)
{
    x <- .Rd_get_section(x, "name")
    ## The name should really be plain text, so as.character() should be
    ## fine as well ...
    if(length(x))
        trimws(.Rd_deparse(x, tag = FALSE))
    else
        character()
}

### * .Rd_get_title

.Rd_get_title <-
function(x)
{
    title <- .Rd_get_section(x, "title")

    result <- character()
    if(length(title)) {
        result <- .Rd_get_text(title)
        result <- result[nzchar(result)]
    }
    paste(result, collapse=" ")
}

### * .Rd_get_text

# Return display form of text, encoded in UTF-8.  Note that
# textConnection converts to the local encoding, and we convert back,
# so unrepresentable characters will be lost

## FIXME: use out = tempfile(), like .Rd_get_latex.

.Rd_get_text <-
function(x) {
    # Handle easy cases first
    if (is.character(x)) return(c(x))

    # We'd like to use capture.output here, but don't want to depend
    # on utils, so we duplicate some of it
    rval <- NULL
    file <- textConnection("rval", "w", local = TRUE)

    save <- options(useFancyQuotes = FALSE)
    Rdsave <- Rd2txt_options(underline_titles = FALSE)
    sink(file)
    tryCatch(Rd2txt(x, fragment=TRUE),
             finally = {sink()
                        options(save)
                        Rd2txt_options(Rdsave)
                        close(file)})

    if (is.null(rval)) rval <- character()
    else enc2utf8(rval)
}

### * .Rd_get_xrefs

.Rd_get_xrefs <-
function(x)
{
    out <- matrix(character(), nrow = 0L, ncol = 2L)
    recurse <- function(e) {
        tag <- attr(e, "Rd_tag")
        if(identical(tag, "\\link")) {
            val <- if(length(e)) { # mvbutils has empty links
                arg <- as.character(e[[1L]])
                opt <- attr(e, "Rd_option")
                c(arg, if(is.null(opt)) "" else as.character(opt))
            } else c("", "")
            out <<- rbind(out, val)
        } else if(identical(tag, "\\linkS4class")) {
            arg <- as.character(e[[1L]])
            val <- c(arg, sprintf("=%s-class", arg))
            out <<- rbind(out, val)
        }
        if(is.list(e)) lapply(e, recurse)
    }
    lapply(x, recurse)
    dimnames(out) <- list(NULL, c("Target", "Anchor"))
    out
}

### * .Rd_get_names_from_Rd_db

.Rd_get_names_from_Rd_db <-
function(db)
{
    Rd_names <- lapply(db, .Rd_get_name)
    ## If the Rd db was obtained from an installed package, we know that
    ## all Rd objects must have a \name entry---otherwise, Rd_info() and
    ## hence installing the package Rd contents db would have failed.
    ## For Rd dbs created from a package source directory, we now add
    ## the Rd file paths as the names attribute, so that we can point to
    ## the files with missing \name entries.
    idx <- as.integer(lengths(Rd_names)) == 0L
    if(any(idx)) {
        Rd_paths <- names(db)
        if(is.null(Rd_paths)) {
            ## This should not happen.
            ## We cannot refer to the bad Rd objects because we do not
            ## know their names, and have no idea which file they came
            ## from ...)
            stop("cannot deal with Rd objects with missing/empty names")
        }
        else {
            stop(sprintf(ngettext(sum(idx),
                                  "missing/empty \\name field in Rd file\n%s",
                                  "missing/empty \\name field in Rd files\n%s"),
                         paste0("  ", Rd_paths[idx], collapse = "\n")),
                 call. = FALSE, domain = NA)
        }
    }
    unlist(Rd_names)
}

### * .Rd_format_title

.Rd_format_title <-
function(x)
{
    ## Although R-exts says about the Rd title slot that
    ## <QUOTE>
    ##   This should be capitalized, not end in a period, and not use
    ##   any markup (which would cause problems for hypertext search).
    ## </QUOTE>
    ## some Rd files have LaTeX-style markup, including
    ## * LaTeX-style single and double quotation
    ## * Medium and punctuation dashes
    ## * Escaped ampersand.
    ## Hence we try getting rid of these ...
    x <- gsub("(``|'')", "\"", x)
    x <- gsub("`", "'", x)
    x <- gsub("([[:alnum:]])--([[:alnum:]])", "\\1-\\2", x)
    x <- gsub("\\\\&", "&", x)
    x <- gsub("---", "--", x)
    ## Also remove leading and trailing whitespace.
    trimws(x)
}


### * fetchRdDB

fetchRdDB <-
function(filebase, key = NULL)
{
    fun <- function(db) {
        vals <- db$vals
        vars <- db$vars
        datafile <- db$datafile
        compressed <- db$compressed
        envhook <- db$envhook

        fetch <- function(key)
            lazyLoadDBfetch(vals[key][[1L]], datafile, compressed, envhook)

        if(length(key)) {
            if(key %notin% vars)
                stop(gettextf("No help on %s found in RdDB %s",
                              sQuote(key), sQuote(filebase)),
                     domain = NA)
            fetch(key)
        } else {
            res <- lapply(vars, fetch)
            names(res) <- vars
            res
        }
    }
    res <- lazyLoadDBexec(filebase, fun)
    if (length(key))
        res
    else
        invisible(res)
}

# The macros argument can be TRUE, in which case a new environment is created with an empty parent,
# or the result of a previous call to this function, in which case it becomes the parent,
# or a filename, in which case that file is loaded first, then the new file into a child environment.

# It is not safe to save this environment, as changes to the parser may invalidate its contents.

loadRdMacros <- function(file, macros = TRUE) {
    # New macros are loaded into a clean environment
    if (is.logical(macros) && !macros)
    	stop("'macros' must be TRUE or must specify existing macros")
    Rd <- parse_Rd(file, fragment = TRUE, macros = macros, warningCalls = FALSE)
    for(entry in Rd) {
        bad <- TRUE
	if (is.list(entry)) break
	tag <- attr(entry, "Rd_tag")
	switch(tag,
	    TEXT = if (any(grepl("[^[:space:]]", entry, perl = TRUE, useBytes=TRUE)))
		      break
		   else
		      bad <- FALSE,
	    USERMACRO =,
	    "\\newcommand" =,
	    "\\renewcommand" =,
	    COMMENT = bad <- FALSE,
	    break
	)
    }
    if (bad)
	warning(gettextf("Macro file %s should only contain Rd macro definitions and comments",
	                 file))
    attr(Rd, "macros")
}

initialRdMacros <- function(pkglist = NULL,
                            macros = file.path(R.home("share"), "Rd", "macros", "system.Rd")
                            ) {
    if (length(pkglist)) {
    	others <- trimws(unlist(strsplit(pkglist, ",")))

    	for (p in others) {
            if((fp <- system.file(package = p)) == "")
                warning(gettextf("Rd macro package '%s' is not installed.",
                                 p),
                        call. = FALSE)
            else if(dir.exists(file.path(fp, "help", "macros")))
    	    	macros <- loadPkgRdMacros(system.file(package = p), macros)
    	    else
    	    	warning(gettextf("No Rd macros in package '%s'.", p),
                        call. = FALSE)
        }
    } else if (is.character(macros))
    	macros <- loadRdMacros(file = macros)
    macros
}

loadPkgRdMacros <- function(pkgdir, macros = NULL) {
    ## this does get called on any directory,
    ## e.g. a man directory in package 'diveMove'.
    pkglist <- try(.read_description(file.path(pkgdir, "DESCRIPTION")),
                   silent = TRUE)
    if (inherits(pkglist, "try-error"))
    	pkglist <-  try(.read_description(file.path(pkgdir, "DESCRIPTION.in")),
                        silent = TRUE)
    ## may check for 'macros' subdirectory?
    if (inherits(pkglist, "try-error")) return(macros)

    pkglist <- pkglist["RdMacros"]

    if (is.na(pkglist))
        pkglist <- NULL

    if (is.null(macros))
        macros <- initialRdMacros(pkglist)
    else
        macros <- initialRdMacros(pkglist, macros)

    files <- c(list.files(file.path(pkgdir, "man", "macros"), pattern = "\\.Rd$", full.names = TRUE),
               list.files(file.path(pkgdir, "help", "macros"), pattern = "\\.Rd$", full.names = TRUE))

    for (f in files)
    	macros <- loadRdMacros(f, macros)

    macros
}

### Local variables: ***
### mode: outline-minor ***
### outline-regexp: "### [*]+" ***
### End: ***