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

vignette_is_tex <- function(file, ...) {
    (regexpr("[.]tex$", file, ignore.case = TRUE) != -1L)
}

# Infers the vignette type (PDF or HTML) from the filename of the
# final vignette product.
vignette_type <- function(file) {
    ext <- tolower(file_ext(file))
    type <- c(pdf="PDF", html="HTML")[ext]
    if (is.na(type))
        stop(gettextf("Vignette product %s does not have a known filename extension (%s)",
                      sQuote(file), paste(sQuote(names(type)), collapse=", ")),
             domain = NA)
    unname(type)
}

# Locates the vignette weave, tangle and texi2pdf product(s) based on the
# vignette name.   All such products must have the same name as their filename
# prefix (i.e. "^<name>").
# For weave, final = TRUE will look for <name>.pdf and <name>.html, whereas
# with final = FALSE it also looks for <name>.tex (if <name>.pdf is also
# found, it will be returned).  For tangle, main = TRUE will look for <name>.R,
# whereas main = FALSE will look for <name><anything>*.R.
# For texi2pdf, <name>.pdf is located.
find_vignette_product <-
    function(name, by = c("weave", "tangle", "texi2pdf"),
             final = FALSE, main = TRUE, dir = ".", engine, ...)
{
    stopifnot(length(name) == 1L, dir.exists(dir))
    by <- match.arg(by)
    exts <- ## (lower case here):
	switch(by,
	       "weave" = if (final) c("pdf", "html") else c("pdf", "html", "tex"),
	       "tangle" = c("r", "s"),
	       "texi2pdf" = "pdf")

    exts <- c(exts, toupper(exts))
    pattern1 <- sprintf("^%s[.](%s)$", name, paste(exts, collapse = "|"))
    output0 <- list.files(path = dir, all.files = FALSE, full.names = FALSE,
                          no.. = TRUE)
    output0 <- output0[file_test("-f", file.path(dir, output0))]
    output <- grep(pattern1, output0, value = TRUE)
    # If main is FALSE, we want to find all other files with related
    # names.  We make sure that the main file is in position 1.
    # FIXME: we should check a timestamp or something to see that
    #	      these were produced by tangling for the "name" vignette,
    #	      they aren't just coincidentally similar names.
    if (!main) {
	pattern2 <- sprintf("^%s.*[.](%s)$", name, paste(exts, collapse = "|"))
	output2 <- grep(pattern2, output0, value = TRUE)
	output <- c(output, setdiff(output2, output))
    }

    if (by == "weave") {
        if (length(output) == 0L)
            stop(gettextf("Failed to locate the %s output file (by engine %s) for vignette with name %s. The following files exist in directory %s: %s",
                          sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), sQuote(dir),
                          paste(sQuote(output0), collapse=", ")),
                 domain = NA)
        if (length(output) > 2L || (final && length(output) > 1L))
            stop(gettextf("Located more than one %s output file (by engine %s) for vignette with name %s: %s", sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), paste(sQuote(output), collapse=", ")),
                 domain  = NA)
	# If weave produced a TeX and then a PDF without cleaning out
	# the TeX, consider the newer one (PDF wins a tie) as the weave product
	if (length(output) == 2L) {
	    idxs <- match(tolower(file_ext(output)), exts)
	    output <- output[order(idxs)]
	    if (file_test("-nt", output[2L], output[1L])) output <- output[2L]
	    else output <- output[1L]
        }
    } else if (by == "tangle") {
        if (main)
            stopifnot(length(output) <= 1L)
    } else if (by == "texi2pdf") {
        if (length(output) == 0L)
            stop(gettextf("Failed to locate the %s output file (by engine %s) for vignette with name %s. The following files exist in directory %s: %s",
                          sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), sQuote(dir),
                          paste(sQuote(output0), collapse=", ")),
                 domain = NA)
        if (length(output) > 1L)
            stop(gettextf("Located more than one %s output file (by engine %s) for vignette with name %s: %s",
                          sQuote(by),
                          sQuote(sprintf("%s::%s", engine$package, engine$name)),
                          sQuote(name), paste(sQuote(output), collapse=", ")),
                 domain = NA)
    }

    ## return :
    if (length(output) > 0L) {
        if (dir == ".")
            basename(output)
        else
            file.path(dir, output)
    } ## else NULL
}


### * checkVignettes
###
### Run a tangle+source and a weave on all vignettes of a package.

checkVignettes <-
function(package, dir, lib.loc = NULL,
         tangle = TRUE, weave = TRUE, latex = FALSE,
         workdir = c("tmp", "src", "cur"),
         keepfiles = FALSE)
{
    vigns <- pkgVignettes(package = package, dir = dir, lib.loc = lib.loc)
    if(is.null(vigns)) return(NULL)

    workdir <- match.arg(workdir)
    wd <- getwd()
    if (is.null(wd))
        stop("current working directory cannot be ascertained")
    if(workdir == "tmp") {
        tmpd <- tempfile("Sweave")   ## <= Rename?
        if(!dir.create(tmpd))
            stop(gettextf("unable to create temp directory %s ", sQuote(tmpd)),
                 domain = NA)
        setwd(tmpd)
    }
    else {
        keepfiles <- TRUE
        if(workdir == "src") setwd(vigns$dir)
    }

    on.exit({
        setwd(wd)
        if(!keepfiles) unlink(tmpd, recursive = TRUE)
    })

    file.create(".check.timestamp")
    result <- list(tangle = list(), weave = list(),
                   source = list(), latex = list())

    ## pkgVignettes has already done this
    loadVignetteBuilder(vigns$pkgdir)

    startdir <- getwd()
    for(i in seq_along(vigns$docs)) {
        file <- vigns$docs[i]
        file <- basename(file)
        name <- vigns$names[i]
    	engine <- vignetteEngine(vigns$engines[i])
	enc <- vigns$encodings[i]
        if (enc == "non-ASCII")
            stop(gettextf("Vignette '%s' is non-ASCII but has no declared encoding", name),
                 domain = NA)
        if(tangle) {
            message("  Running ", sQuote(file))
            .eval_with_capture({
                result$tangle[[file]] <- tryCatch({
                    engine$tangle(file, quiet = TRUE, encoding = enc)
                    setwd(startdir) # in case a vignette changes the working dir
                    find_vignette_product(name, by = "tangle", main = FALSE, engine = engine)
                }, error = function(e) e)
            })
        }
        if(weave) {
            setwd(startdir) # in case a vignette changes the working dir then errored out
            .eval_with_capture({
                result$weave[[file]] <- tryCatch({
                    engine$weave(file, quiet = TRUE, encoding = enc)
                    setwd(startdir)
                    find_vignette_product(name, by = "weave", engine = engine)
                }, error = function(e) e)
            })
        }
        setwd(startdir) # in case a vignette changes the working dir then errored out
    }

    # Assert that output files were not overwritten
    for (name in c("weave", "tangle")) {
        resultsT <- result[[name]]
        if (length(resultsT) <= 1L)
            next

        for (i in 1L:(length(resultsT)-1L)) {
            outputsI <- resultsT[[i]]
            if (inherits(outputsI, "error"))
                next;
            outputsI <- normalizePath(outputsI)

            for (j in (i+1L):length(resultsT)) {
                 outputsJ <- resultsT[[j]]
                 if (inherits(outputsJ, "error"))
                     next;
                 outputsJ <- normalizePath(outputsJ)
                 bad <- intersect(outputsJ, outputsI)
                 if (length(bad) > 0L) {
                     stop(gettextf("Vignette %s overwrites the following %s output by vignette %s: %s",
                                   sQuote(basename(names(resultsT)[j])),
                                   sQuote(name),
                                   sQuote(basename(names(resultsT)[i])),
                                   paste(basename(bad), collapse=", ")),
                          domain = NA)
                 }
            }
        }
    }

    if(tangle) {
        ## Tangling can create several source files if splitting is on,
        ## and these can be .R or .S (at least).  However, there is
        ## no guarantee that running them in alphabetical order in a
        ## session will work -- with named chunks it normally will not.
        cwd <- getwd()
        if (is.null(cwd))
            stop("current working directory cannot be ascertained")
        for(i in seq_along(result$tangle)) {
            sources <- result$tangle[[i]]
            if (inherits(sources, "error"))
                next
            sources <- sources[file_test("-nt", sources, ".check.timestamp")]
            for(file in sources) {
                .eval_with_capture({
                    result$source[[file]] <- tryCatch({
                        source(file)
                    }, error = function(e) e)
                })
                setwd(startdir)
            }
        }
    }

    if(weave && latex) {
        if("Makefile" %notin% list.files(vigns$dir)) {
            ## <NOTE>
            ## This used to run texi2pdf on *all* vignettes, including
            ## the ones already known from the above to give trouble.
            ## In addition, texi2pdf errors were not caught, so that in
            ## particular the results of the previous QC analysis were
            ## *not* returned in case of such errors ...
            ## Hence, let us
            ## * Only run texi2pdf() on previously unproblematic vignettes
            ## * Catch texi2pdf() errors similar to the above.
            ## * Do *not* immediately show texi2pdf() output as part of
            ##   running checkVignettes().
            ## (For the future, maybe keep this output and provide it as
            ## additional diagnostics ...)
            ## </NOTE>
            for (i in seq_along(result$weave)) {
                file <- names(result$weave)[i]
                output <- result$weave[i]
                if (inherits(output, "error"))
                    next
                if (!vignette_is_tex(output))
                    next
                .eval_with_capture({
                    result$latex[[file]] <- tryCatch({
                       texi2pdf(file = output, clean = FALSE, quiet = TRUE)
                       find_vignette_product(name, by = "texi2pdf", engine = engine)
                    }, error = function(e) e)
                })
            }
        }
    }

    # Cleanup results
    for (name in c("tangle", "weave", "source", "latex")) {
        resultsT <- result[[name]]
        resultsT <- lapply(resultsT, FUN = function(res) {
          if (inherits(res, "error"))
              conditionMessage(res)
          else
              NULL
        })
        resultsT <- resultsT[!vapply(resultsT, is.null, NA)]
        result[[name]] <- resultsT
    }

    file.remove(".check.timestamp")
    class(result) <- "checkVignettes"
    result
}

print.checkVignettes <-
function(x, ...)
{
    mycat <- function(y, title) {
        if(length(y)){
            cat("\n", title, "\n\n", sep = "")
            for(k in seq_along(y)) {
                cat("File", names(y)[k], ":\n")
                cat(as.character(y[[k]]), "\n")
            }
        }
    }

    mycat(x$tangle, "*** Tangle Errors ***")
    mycat(x$source, "*** Source Errors ***")
    mycat(x$weave,  "*** Weave Errors ***")
    mycat(x$latex,  "*** PDFLaTeX Errors ***")

    invisible(x)
}

### get the engine from a file

getVignetteEngine <- function(filename, lines = readLines(filename, warn=FALSE)) {
    c(.get_vignette_metadata(lines, "Engine"), "utils::Sweave")[1L]
}

### * engineMatches
###
### does the engine from a vignette match one of the registered ones?
###
engineMatches <- function(regengine, vigengine) {
    if (!grepl("::", vigengine))
	regengine <- sub("^.*::", "", regengine)
    regengine == vigengine
}

### * pkgVignettes
###
### Get an object of class pkgVignettes which contains a list of
### vignette source files, the registered vignette engine for
### each of them, and the name of the directory which contains them.

### A vector of 'subdirs' is allowed for historical reasons but the
### first which exists is used.

pkgVignettes <-
function(package, dir, subdirs = NULL, lib.loc = NULL, output = FALSE,
         source = FALSE, check = FALSE)
{
    ## Argument handling.
    if(!missing(package)) {
        if(length(package) != 1L)
            stop("argument 'package' must be of length 1")
        dir <- find.package(package, lib.loc)
    }
    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)
	if (is.null(subdirs))
	    subdirs <- if (missing(package)) "vignettes" else "doc"
	for (subdir in subdirs) {
	    docdir <- file.path(dir, subdir)
	    if(dir.exists(docdir))
		break
	}
    }

    if(!dir.exists(docdir)) return(NULL)

    # Locate all vignette files
    buildPkgs <- loadVignetteBuilder(dir, mustwork = FALSE)
    engineList <- vignetteEngine(package = buildPkgs)

    docs <- names <- engines <- patterns <- character()
    allFiles <- list.files(docdir, all.files = FALSE, full.names = TRUE)
    exclude <- inRbuildignore(sub(paste0(dir, "/"), "", allFiles, fixed = TRUE), dir)
    allFiles <- allFiles[!exclude]

    matchedPattern <- rep.int(FALSE, length(allFiles))
    msg <- character()
    if (length(allFiles) > 0L) {
        for (name in names(engineList)) {
            engine <- engineList[[name]]
            for (pattern in engine$pattern) {
                idxs <- grep(pattern, allFiles)
		matchedPattern[idxs] <- TRUE
		keep <- vapply(allFiles[idxs], function(.d.)
			       engineMatches(name, getVignetteEngine(.d.)), NA)
		if (any(keep)) {
		    idxs <- idxs[keep]
                    if (is.function(engine$weave)) {
                        docsT <- allFiles[idxs]
                        docs <- c(docs, docsT)
                        names <- c(names, gsub(pattern, "", basename(docsT)))
			engines	 <- c(engines,	rep.int(name,	 length(idxs)))
			patterns <- c(patterns, rep.int(pattern, length(idxs)))
                    }
		    matchedPattern <- matchedPattern[-idxs]
                    allFiles <- allFiles[-idxs]
                    if (length(allFiles) == 0L)
                        break
                }
            }
        }
	if (check && any(matchedPattern)) {
            files <- substring(allFiles[matchedPattern], nchar(dir) + 2)
            msg <- c("Files named as vignettes but with no recognized vignette engine:",
                     paste("  ", sQuote(files)),
                     "(Is a VignetteBuilder field missing?)")
        }
    }

    # Assert
    stopifnot(length(names)    == length(docs),
	      length(engines)  == length(docs),
	      length(patterns) == length(docs), !anyDuplicated(docs))

    defaultEncoding <- .get_package_metadata(dir)["Encoding"]
    encodings <- vapply(docs, getVignetteEncoding, "", default = defaultEncoding)

    z <- list(docs = docs, names = names, engines = engines,
              patterns = patterns, encodings = encodings,
              dir = docdir, pkgdir = dir, msg = msg)

    if (output) {
        outputs <- character(length(docs))
        for (i in seq_along(docs)) {
            file <- docs[i]
            name <- names[i]
            outputI <- find_vignette_product(name, by = "weave", dir = docdir, engine = engine)
            outputs[i] <- outputI
        }
        z$outputs <- outputs
    }

    if (source) {
        sources <- list()
        for (i in seq_along(docs)) {
            file <- docs[i]
            name <- names[i]
            sourcesI <- find_vignette_product(name, by = "tangle", main = FALSE, dir = docdir, engine = engine)
            sources[[file]] <- sourcesI
        }
        z$sources <- sources
    }

    class(z) <- "pkgVignettes"
    z
}


### * buildVignettes
###
### Run a weave and pdflatex on all vignettes of a package and try to
### remove all temporary files that were created.
### Exported version, used in R CMD build/check
buildVignettes <-
    function(package, dir, lib.loc = NULL, quiet = TRUE, clean = TRUE,
             tangle = FALSE, ser_elibs = NULL)
{
    separate <- !is.null(ser_elibs)
    if (separate) elibs <- readRDS(ser_elibs)
    ## This has side effects, including loading vignette-buider pkgs
    vigns <- pkgVignettes(package = package, dir = dir, lib.loc = lib.loc,
                          check = TRUE)
    if (is.null(vigns)) return(invisible())
    if (length(vigns$docs) <= 1L) separate <- FALSE
    if (length(vigns$msg))
        warning(paste(vigns$msg, collapse = "\n"), domain = NA)

    ## Check that duplicated vignette names do not exist, e.g.
    ## 'vig' and 'vig' from 'vig.Rnw' and 'vig.Snw'.
    dups <- duplicated(vigns$names)
    if (any(dups)) {
        names <- unique(vigns$names[dups])
        docs <- sort(basename(vigns$docs[vigns$names %in% names]))
        stop(gettextf("Detected vignette source files (%s) with shared names (%s) and therefore risking overwriting each other's output files",
                      paste(sQuote(docs), collapse = ", "),
                      paste(sQuote(names), collapse = ", ")),
             domain = NA)
    }

    ## Check for duplicated titles (which look silly on CRAN pages)
    titles <- character()
    for (d in vigns$docs) {
        this <- c(.get_vignette_metadata(readLines(d, warn = FALSE),
                                         "IndexEntry"), "")[1L]
        titles <- c(titles, this)
    }
    have_dup_titles <-
        if (any(dup <- duplicated(titles))) {
            dups <- unique(titles[dup])
            message(ngettext(length(dups),
                             "duplicated vignette title:",
                             "duplicated vignette titles:"))
            message(paste(.pretty_format(dups), collapse = "\n"))
            message()
            TRUE
        } else FALSE

    ## unset SWEAVE_STYLEPATH_DEFAULT here to avoid problems
    Sys.unsetenv("SWEAVE_STYLEPATH_DEFAULT")

    op <- options(warn = 1) # we run may run vignettes in this process
    wd <- getwd()
    if (is.null(wd))
        stop("current working directory cannot be ascertained")
    on.exit({
        setwd(wd)
        options(op)
    })

    setwd(vigns$dir)

    ## FIXME: should this recurse into subdirs?
    origfiles <- list.files(all.files = TRUE)

    ## Note, as from 2.13.0, only this case
    have.makefile <- "Makefile" %in% origfiles

    file.create(".build.timestamp")

    ## pkgVignettes has already done this
    ## loadVignetteBuilder(vigns$pkgdir)
    outputs <- character()
    sourceList <- list()
    startdir <- getwd()
    fails <- character()
    for(i in seq_along(vigns$docs)) {
        thisOK <- TRUE
        file <- basename(vigns$docs[i])
        enc <- vigns$encodings[i]
        if (enc == "non-ASCII") {
            message(gettextf("Error: Vignette '%s' is non-ASCII but has no declared encoding",
                             file))
            fails <- c(fails, file)
            next
        }
        name <- vigns$names[i]
        engine <- vignetteEngine(vigns$engines[i])

        if (separate) {  # --- run in separate process
            tf2 <- gsub("\\", "/", tempfile(fileext = ".rds"), fixed = TRUE)
            saveRDS(engine, tf2)
            Rcmd <- sprintf('tools:::.buildOneVignette("%s", "%s", %s, %s, "%s", "%s", "%s")',
                            file, vigns$pkgdir, quiet, have.makefile,
                            name, enc, tf2)
            tlim <- get_timeout(Sys.getenv("_R_CHECK_ONE_VIGNETTE_ELAPSED_TIMEOUT_",
                                           Sys.getenv("_R_CHECK_ELAPSED_TIMEOUT_")))
            tf <- tempfile()
            status <- R_runR(Rcmd, "--vanilla --slave", elibs,
                             stdout = tf, stderr = tf, timeout = tlim)
            unlink(tf2)
            ##print(status)
            if (!status) {
                this <- readLines(tf)
                patt <- "^[+]-[+]"
                l <- grepl(patt, this)
                output <- gsub(patt, "", this[l])
                outputs <- c(outputs, output)
                cat(this[!l], sep = "\n")
            } else {
                fails <- c(fails, file)
                cat(readLines(tf), sep = "\n")
            }
            unlink(tf)
        } else {  # --- run in this process
            message(gettextf("--- re-building %s using %s",
                             sQuote(file), engine$name))
            tryCatch({
                engine$weave(file, quiet = quiet, encoding = enc)
                setwd(startdir) # In case weave/vignette changed it
                output <- find_vignette_product(name, by = "weave", engine = engine)
                if (!have.makefile && vignette_is_tex(output)) {
                    ## This can fail if run in a directory whose path contains spaces.
                    texi2pdf(file = output, clean = FALSE, quiet = quiet)
                    output <- find_vignette_product(name, by = "texi2pdf",
                                                    engine = engine)
                }
                outputs <- c(outputs, output)
            }, error = function(e) {
                thisOK <<- FALSE
                fails <<- c(fails, file)
                message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
                                 file, conditionMessage(e)))
            })
        }         # end if (separate)

        if (tangle && !separate) {  # This is set for all engines as of 3.0.2
            ## It is unlikely that weave succeeds but tangle fails,
            ## so we don't bother to report tangle failures specifically.
            output <- tryCatch({
                engine$tangle(file, quiet = quiet, encoding = enc)
                setwd(startdir) # In case tangle/vignette changed it
                find_vignette_product(name, by = "tangle", main = FALSE, engine = engine)
            }, error = function(e) {
                thisOK <<- FALSE
                fails <<- c(fails, file)
                message(gettextf("Error: tangling vignette '%s' failed with diagnostics:\n%s",
                     file, conditionMessage(e)))
            })
            sourceList[[file]] <- output
        }
        if (!separate) {
            if (thisOK)
                message(gettextf("--- finished re-building %s\n", sQuote(file)))
            else
                message(gettextf("--- failed re-building %s\n", sQuote(file)))
        }
    } # end loop over vignettes

    if (have.makefile) {
        WINDOWS <- .Platform$OS.type == "windows"
        if (WINDOWS) {
            ## Some people have *assumed* that R_HOME uses / in Makefiles
            ## Spaces in paths might still cause trouble.
            rhome <- chartr("\\", "/", R.home())
            Sys.setenv(R_HOME = rhome)
        }
    	make <- Sys.getenv("MAKE", "make")
        if (!nzchar(make)) make <- "make"
        yy <- system(make)
        if (yy > 0) stop("running 'make' failed")
        ## See if Makefile has a clean: target, and if so run it.
        if (clean &&
	   any(startsWith(readLines("Makefile", warn = FALSE), "clean:")))
            system(paste(make, "clean"))
    } else {
        ## Badly-written vignettes open a pdf() device on Rplots.pdf and
        ## fail to close it.
        grDevices::graphics.off()

        keep <- c(outputs, unlist(sourceList))
        if (clean) {
            f <- setdiff(list.files(all.files = TRUE, no.. = TRUE), keep)
            newer <- file_test("-nt", f, ".build.timestamp")
            ## some packages, e.g. SOAR, create directories
            unlink(f[newer], recursive = TRUE)
            f <- setdiff(list.files(all.files = TRUE, no.. = TRUE),
                         c(keep, origfiles))
            f <- f[file_test("-f", f)]
            file.remove(f)
        }
    }

    if (file.exists(".build.timestamp")) file.remove(".build.timestamp")
    ## Might have been in origfiles ...

    if (length(fails)) {
        message(ngettext(length(fails),
                         "SUMMARY: processing the following file failed:",
                         "SUMMARY: processing the following files failed:"))
        message(paste(.pretty_format(fails), collapse = "\n"))
        message()
    }


    msg2 <- paste("Duplicate vignette titles.",
                  "  Ensure that the %\\VignetteIndexEntry lines in the vignette sources",
                  "  correspond to the vignette titles.",
                  sep = "\n")

    ## Assert
    if (length(fails) || (length(outputs) != length(vigns$docs))) {
        msg <- "Vignette re-building failed."
        if (have_dup_titles) msg <- paste0(msg, "\nError: ", msg2)
        stop(msg, domain = NA, call. = FALSE)
    }

    if (have_dup_titles)
        stop(msg2, domain = NA, call. = FALSE)

    vigns$outputs <- outputs
    vigns$sources <- sourceList

    invisible(vigns) ## not documented on the help page.
}

### * buildVignette
###
### Run a weave and/or tangle on one vignette and try to
### remove all temporary files that were created.
### Also called from 'R CMD Sweave' via .Sweave() in ../../utils/R/Sweave.R
buildVignette <-
    function(file, dir = ".", weave = TRUE, latex = TRUE, tangle = TRUE,
             quiet = TRUE, clean = TRUE, keep = character(),
             engine = NULL, buildPkg = NULL,
	     encoding = getVignetteEncoding(file), ...)
{
    if (!file_test("-f", file))
	stop(gettextf("file '%s' not found", file), domain = NA)
    if (!dir.exists(dir))
	stop(gettextf("directory '%s' does not exist", dir), domain = NA)

    if (!is.null(buildPkg))
	for (pkg in buildPkg)
	    suppressPackageStartupMessages(loadNamespace(pkg))

    if (is.null(engine))
    # Infer vignette engine from vignette content
	engine <- getVignetteEngine(file)

    # Get the vignette engine
    if (is.character(engine))
	engine <- vignetteEngine(engine, package = buildPkg)

    # Infer the vignette name
    names <- sapply(engine$pattern, FUN = sub, "", file)
    name <- basename(names[(names != file)][1L])

    # A non-matching filename?
    if (is.na(name))
	stop(gettextf("vignette filename '%s' does not match any of the '%s' filename patterns",
		file, paste(engine$package, engine$name, sep="::")),
		domain = NA)

    if (encoding == "non-ASCII")
    	stop(gettextf("Vignette '%s' is non-ASCII but has no declared encoding", name))

    # Set output directory temporarily
    file <- file_path_as_absolute(file)
    olddir <- setwd(dir)
    if (!is.null(olddir)) on.exit(setwd(olddir))

    ## # Record existing files
    ## origfiles <- list.files(all.files = TRUE)
    if (is.na(clean) || clean) {
	file.create(".build.timestamp")
    }

    tdir <- getwd()# if 'dir' was relative, resetting to tdir will work
    output <- NULL

    # Weave
    final <- if (weave) {
	engine$weave(file, quiet = quiet, encoding = encoding, ...)
	setwd(tdir)  # In case weave/vignette changed it
	output <- find_vignette_product(name, by = "weave", engine = engine)

	# Compile TeX to PDF?
	if(latex && vignette_is_tex(output)) {
	    texi2pdf(file = output, clean = FALSE, quiet = quiet)
	    find_vignette_product(name, by = "texi2pdf", engine = engine)
	} else
	    output
    } # else NULL

    # Tangle
    sources <- if (tangle) {
	engine$tangle(file, quiet = quiet, encoding = encoding, ...)
	setwd(tdir)  # In case tangle changed it
	find_vignette_product(name, by = "tangle", main = FALSE, engine = engine)
    } # else NULL

    ## Cleanup newly created files unless those in 'keep'
    keep <- c(sources, final, keep)
    if (is.na(clean)) {  # Use NA to signal we want .tex (or .md) files kept.
	keep <- c(keep, output)
	clean <- TRUE
    }
    if (clean) {
	f <- setdiff(list.files(all.files = TRUE, no.. = TRUE), keep)
	newer <- file_test("-nt", f, ".build.timestamp")
	## some packages create directories
	unlink(f[newer], recursive = TRUE)
    }
    ### huh?  2nd round of cleaning even if  clean is FALSE ??
    ##     f <- setdiff(list.files(all.files = TRUE, no.. = TRUE), c(keep, origfiles))
    ##     f <- f[file_test("-f", f)]
    ##     file.remove(f)
    ## #}

    if((is.na(clean) || clean) && file.exists(".build.timestamp")) {
        file.remove(".build.timestamp")
    }

    unique(keep)
}

### * .buildOneVignette

## helper to be run in a separate process
.buildOneVignette <-
    function(file, pkgdir, quiet = TRUE, have.makefile = FALSE,
             name, enc, ser_engine)
{
    op <- options(warn = 1)      # we run vignettes in this process
    engine <- readRDS(ser_engine)
    ## This is more than we need, but we cannot be sure that 'engine'
    ## has references to all the namespaces required.  But packages
    ## typically only have one engine, at most two.
    loadVignetteBuilder(pkgdir)
    OK <- TRUE
    startdir <- getwd()
    output <- character()

    message(gettextf("--- re-building %s using %s",
                     sQuote(file), engine$name))
    tryCatch({
        engine$weave(file, quiet = quiet, encoding = enc)
        setwd(startdir)  # In case weave/vignette changed it
        output <- find_vignette_product(name, by = "weave", engine = engine)
        if(!have.makefile && vignette_is_tex(output)) {
            texi2pdf(file = output, clean = FALSE, quiet = quiet)
            output <- find_vignette_product(name, by = "texi2pdf",
                                            engine = engine)
        }
    }, error = function(e) {
        OK <<- FALSE
        message(gettextf("Error: processing vignette '%s' failed with diagnostics:\n%s",
                         file, conditionMessage(e)))
    })

    if (OK)
        message(gettextf("--- finished re-building %s\n", sQuote(file)))
    else {
        message(gettextf("--- failed re-building %s\n", sQuote(file)))
        q("no", status = 9L)
    }

    message("+-+", output)
    invisible(output)
}


### * getVignetteEncoding

getVignetteEncoding <-  function(file, ...)
{
    lines <- readLines(file, warn = FALSE)
    .getVignetteEncoding(lines, ...)
}

.getVignetteEncoding <- function(lines, default = NA)
{
    res <- .get_vignette_metadata(lines, "Encoding")[1L]

    if(is.na(res)) {
        poss <- grep("^[[:space:]]*%+[[:space:]]*\\\\SweaveUTF8[[:space:]]*$", lines, useBytes = TRUE)
        if (length(poss))
	    "UTF-8"
        else {
            ## Look for input enc lines using inputenc or inputenx
            ## Note, multiple encodings are excluded.
            poss <-
                grep("^[[:space:]]*\\\\usepackage\\[([[:alnum:]]+)\\]\\{inputen[cx]\\}",
                     lines, useBytes = TRUE)
            ## Check it is in the preamble
            start <- grep("^[[:space:]]*\\\\begin\\{document\\}",
                          lines, useBytes = TRUE)
            if(length(start))
                poss <- poss[poss < start[1L]]
            if(length(poss)) {
        	poss <- lines[poss[1L]]
        	res <- gsub("^[[:space:]]*\\\\usepackage\\[([[:alnum:]]+)\\].*", "\\1",
                            poss)               # This line should be ASCII.
		## see Rd2latex.R.
		## Currently utf8, utf8x, latin1, latin9 and ansinew are in use.
		switch(res,
		       "utf8" =, "utf8x" = "UTF-8",
		       "latin1" =, "iso-8859-1" = "latin1",
		       "latin2" =, "iso-8859-2" = "latin2",
		       "latin9" =, "iso-8859-15" = "latin-9", # only form known to GNU libiconv
		       "latin10" =, "iso-8859-16" = "latin10",
		       "cyrillic" =, "iso-8859-5" =  "ISO-8859-5", # inputenx
		       "koi8-r" =  "KOI8-R", # inputenx
		       "arabic" = "ISO-8859-6", # Not clear next 3 are known to latex
		       "greek" =, "iso-8859-7" = "ISO-8859-7",
		       "hebrew" =, "iso-8859-8" = "ISO-8859-8",
		       "ansinew" = "CP1252",
		       "applemac" = "macroman",
		       ## assume these only get used on Windows
		       "cp1250" = "CP1250",
		       "cp1252" = "CP1252",
		       "cp1257" = "CP1257",
		       "unknown")
	    } else if (!is.na(default)) {
		default
            } else { # Nothing else has indicated an encoding, maybe it's just ASCII
                asc <- iconv(lines, "latin1", "ASCII")
		if(anyNA(asc) || any(asc != lines)) "non-ASCII" else "" # or "ASCII"
            }
        }
    } else
	res
}

### * .build_vignette_index

.get_vignette_metadata <-
function(lines, tag)
{
    ## <FIXME>
    ## Why don't we anchor this to the beginning of a line?
    meta_RE <- paste0("[[:space:]]*%+[[:space:]]*\\\\Vignette",
                      tag, "\\{([^}]*(\\{[^}]*\\})*[^}]*)\\}.*")
    ## </FIXME>
    meta <- grep(meta_RE, lines, value = TRUE, useBytes = TRUE)
    trimws(gsub(meta_RE, "\\1", meta))
}

vignetteInfo <- function(file)
{
    lines <- readLines(file, warn = FALSE)

    ## <FIXME>
    ## Can only proceed with lines which are valid in the current locale.
    ## Unfortunately, vignette encodings are a mess: package encodings
    ## might apply, but be overridden by \inputencoding commands.
    ## For now, assume that vignette metadata occur in all ASCII lines.
    ## (Could also iconv() using sub = "byte".)
    lines[is.na(nchar(lines, "c", TRUE))] <- ""
    ## </FIXME>

    ## \VignetteIndexEntry
    title <- c(.get_vignette_metadata(lines, "IndexEntry"), "")[1L]
    ## \VignetteDepends
    depends <- .get_vignette_metadata(lines, "Depends")
    if(length(depends))
        depends <- unlist(strsplit(depends[1L], ", *"))
    ## \VignetteKeyword and old-style \VignetteKeywords
    keywords <- .get_vignette_metadata(lines, "Keywords")
    keywords <- if(!length(keywords)) {
        ## No old-style \VignetteKeywords entries found.
        .get_vignette_metadata(lines, "Keyword")
    } else unlist(strsplit(keywords[1L], ", *"))
    ## no point in recording the file path since this is called on
    ## package installation.
    engine <- getVignetteEngine(lines=lines)
    list(file = basename(file), title = title, depends = depends,
         keywords = keywords, engine = engine)
}

## builds vignette indices from 'vigns', a pkgVignettes() result
.build_vignette_index <- function(vigns)
{
    stopifnot(inherits(vigns, "pkgVignettes"))

    files <- vigns$docs
    names <- vigns$names
    dir <- vigns$dir
    sources <- vigns$sources

    if(!dir.exists(dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)

    nvigns <- length(files)
    if(nvigns == 0L) {
        out <- data.frame(File = character(),
                          Title = character(),
                          PDF = character(),
			  R = character(),
                          stringsAsFactors = FALSE)
        out$Depends <- list()
        out$Keywords <- list()
        return(out)
    }

    # Check for duplicated vignette names
    if (any(dups <- duplicated(names))) {
    	dupname <- names[dups][1L]
    	dup <- basename(files[dups][1L])
    	orig <- basename(files[ names == dupname ][1L])
    	stop(gettextf("In '%s' vignettes '%s' and '%s' have the same vignette name",
    		      basename(dirname(dir)), orig, dup),
             domain = NA)
    }

    # Read vignette annotation from vignette source files
    contents <- vector("list", length = nvigns * 5L)
    dim(contents) <- c(nvigns, 5L)
    for(i in seq_along(files))
        contents[i, ] <- vignetteInfo(files[i])
    colnames(contents) <- c("File", "Title", "Depends", "Keywords", "Engine")

    ## This is to cover a temporary package installation
    ## by 'R CMD build' (via 'R CMD INSTALL -l <lib>)
    ## which in case vignettes have not been built.
    outputs <- vigns$outputs
    outputs <- if(!is.null(outputs)) basename(outputs) else character(nvigns)

    out <- data.frame(File = unlist(contents[, "File"]),
                      Title = unlist(contents[, "Title"]),
                      PDF = outputs,	# Not necessarily PDF, but name it that for back compatibility
		      R = "",		# May or may not be present
                      row.names = NULL, # avoid trying to compute row
                                        # names
                      stringsAsFactors = FALSE)
    # Optional
    for (i in seq_along(sources))
	if (length(s <- sources[[i]]))
	    out$R[which(names(sources)[i] == files)] <- basename(s[1L])
    out$Depends <- contents[, "Depends"]
    out$Keywords <- contents[, "Keywords"]

    stopifnot(NROW(out) == nvigns)

    out
}

### * .check_vignette_index

.check_vignette_index <-
function(vignetteDir, pkgdir = ".")
{
    dir <- file.path(pkgdir, vignetteDir)
    if(!dir.exists(dir))
        stop(gettextf("directory '%s' does not exist", dir), domain = NA)

    subdir <- gsub(pkgdir, "", dir, fixed=TRUE)
    vigns <- pkgVignettes(dir = pkgdir, subdirs = subdir)

    vignetteIndex <- .build_vignette_index(vigns)
    badEntries <-
        vignetteIndex[grep("^[[:space:]]*$", vignetteIndex[, "Title"]), "File"]
    class(badEntries) <- "check_vignette_index"
    badEntries
}

print.check_vignette_index <-
function(x, ...)
{
    if(length(x)) {
        writeLines(c("Vignettes with missing or empty \\VignetteIndexEntry:",
                     paste0("  ", basename(unclass(x)))))
    }
    invisible(x)
}


### * .writeVignetteHtmlIndex

## NB SamplerCompare has a .Rnw file which produces no R code.
.writeVignetteHtmlIndex <-
function(pkg, con, vignetteIndex = NULL)
{
    ## FIXME: in principle we could need to set an encoding here
    html <- c(HTMLheader("Vignettes and other documentation"),
              paste0("<h2>Vignettes from package '", pkg,"'</h2>"),
              if(NROW(vignetteIndex) == 0L) ## NROW(NULL) = 0
                  "The package contains no vignette meta-information."
              else {
                  vignetteIndex <- cbind(Package = pkg,
                                         as.matrix(vignetteIndex[, c("File", "Title", "PDF", "R")]))
                  makeVignetteTable(vignetteIndex, depth = 3L)
              })
    otherfiles <- list.files(system.file("doc", package = pkg))
    if(NROW(vignetteIndex))
        otherfiles <- setdiff(otherfiles,
                              c(vignetteIndex[, c("PDF", "File", "R")], "index.html"))
    if (length(otherfiles)) {
    	otherfiles <- ifelse(dir.exists(system.file(file.path("doc", otherfiles), package = pkg)),
			     paste0(otherfiles, "/"),
			     otherfiles)
	urls <- paste0('<a href="', otherfiles, '">', otherfiles, '</a>')
        html <- c(html, '<h2>Other files in the <span class="samp">doc</span> directory</h2>',
                  '<table width="100%">',
		  '<col style="width: 24%;" />',
		  '<col style="width: 50%;" />',
		  '<col style="width: 24%;" />',
                  paste0('<tr><td></td><td><span class="samp">',
                         iconv(urls, "", "UTF-8"), "</span></td></tr>"),
                  "</table>")
    }
    html <- c(html, "</body></html>")
    writeLines(html, con=con)
}

getVigDepMtrx <-
function(vigDeps)
{
    ## Taken almost directly out of 'package.dependencies'
    if (length(vigDeps)) {
        z <- unlist(strsplit(vigDeps, ",", fixed=TRUE))
        z <- sub("^[[:space:]]*(.*)", "\\1", z)
        z <- sub("(.*)[[:space:]]*$", "\\1", z)
        pat <- "^([^\\([:space:]]+)[[:space:]]*\\(([^\\)]+)\\).*"
        depMtrx <- cbind(sub(pat, "\\1", z),
                         sub(pat, "\\2", z),
                         NA)
        noversion <- depMtrx[, 1L] == depMtrx[, 2L]
        depMtrx[noversion, 2L] <- NA
        pat <- "[[:space:]]*([[<>=]+)[[:space:]]+(.*)"
        depMtrx[!noversion, 2:3] <-
            c(sub(pat, "\\1", depMtrx[!noversion, 2L]),
              sub(pat, "\\2", depMtrx[!noversion, 2L]))
        depMtrx
    }
    else
        NA
}

### * .run_one_vignette
### helper for R CMD check

.run_one_vignette <-
function(vig_name, docDir, encoding = "", pkgdir)
{
    ## The idea about encodings here is that Stangle reads the
    ## file, converts on read and outputs in the current encoding.
    ## Then source() can assume the current encoding.
    td <- tempfile()
    dir.create(td)
    file.copy(docDir, td, recursive = TRUE)
    setwd(file.path(td, basename(docDir)))

    subdir <- gsub(pkgdir, "", docDir, fixed=TRUE)
    vigns <- pkgVignettes(dir=pkgdir, subdirs=subdir)
    if (is.null(vigns)) {
       cat("\n  When running vignette ", sQuote(vig_name), ":\n", sep="")
       stop("No vignettes available", call. = FALSE, domain = NA)
    }

    i <- which(basename(vigns$docs) == vig_name)
    if (length(i) == 0L) {
       cat("\n  When running vignette ", sQuote(vig_name), ":\n", sep="")
       stop("No such vignette ", sQuote(vig_name), call. = FALSE, domain = NA)
    }
    stopifnot(length(i) == 1L)

    loadVignetteBuilder(pkgdir)
    file <- basename(vigns$docs[i])
    name <- vigns$names[i]
    engine <- vignetteEngine(vigns$engines[i])

    output <- tryCatch({
        engine$tangle(file, quiet = TRUE, encoding = encoding)
        find_vignette_product(name, by = "tangle", engine = engine)
    }, error = function(e) {
        cat("\n  When tangling ", sQuote(file), ":\n", sep="")
        stop(conditionMessage(e), call. = FALSE, domain = NA)
    })

    if(length(output) == 1L) {
        tryCatch({
            source(output, echo = TRUE)
        }, error = function(e) {
            cat("\n  When sourcing ", sQuote(output), ":\n", sep="")
            stop(conditionMessage(e), call. = FALSE, domain = NA)
        })
    }

    cat("\n *** Run successfully completed ***\n")
}

vignetteEngine <- local({
    registry <- new.env(parent = emptyenv())

    engineKey <- function(name, package) {
        key <- strsplit(name, split = "::", fixed = TRUE)[[1L]]
        if (length(key) == 1L) {
	    if (missing(package))
		stop("Vignette engine package not specified", call.=FALSE)
            key[2L] <- key[1L]
            key[1L] <- package
        } else if (length(key) != 2L) {
            stop("Unsupported engine name ", sQuote(name))
        }
        key
    }

    getEngine <- function(name, package) {
        if (missing(name)) {
            result <- as.list(registry)
            if (length(result) > 0L && !is.null(package)) {
               package <- unique(package)
               pkgs <- sapply(result, function(engine) engine$package)
               keep <- is.element(pkgs, package)
               if (!any(keep)) {
                   stop(gettextf("None of packages %s have registered vignette engines",
                                 paste(sQuote(package), collapse = ", ")),
                        domain = NA)
               }
               result <- result[keep]
               pkgs <- pkgs[keep]
               if (length(package) > 1L) {
                 result <- result[order(match(pkgs, package))]
               }
            }
        } else {
            result <- NULL
            if (is.null(package)) {
                if (name == "Sweave") {
                    key <- engineKey(name, package = "utils")
                } else {
                    key <- engineKey(name)
                }
		suppressPackageStartupMessages(loadNamespace(key[1]))
                name <- paste(key, collapse = "::")
                result <- registry[[name]]
                if (is.null(result))
                    stop(gettextf("Vignette engine %s is not registered",
                                  sQuote(name)), domain = NA)
            } else {
                for (pkg in package) {
                    key <- engineKey(name, pkg)
		    try(suppressPackageStartupMessages(loadNamespace(key[1])),
                        silent = TRUE)
                    nameT <- paste(key, collapse = "::")
                    result <- registry[[nameT]]
                    if (!is.null(result))
                        break
                }
                if (is.null(result))
                    stop(gettextf("Vignette engine %s is not registered by any of the packages %s",
                                  sQuote(name),
                                  paste(sQuote(package), collapse = ", ")),
                         domain = NA)
            }

            if (!is.null(package) && !is.element(result$package, package))
                stop(gettextf("Vignette engine %s is not registered by any of the packages %s",
                              sQuote(name),
                              paste(sQuote(package), collapse = ", ")),
                     domain = NA)
        }
        result
    }

    setEngine <- function(name, package, pattern, weave, tangle,
                          aspell = list()) {
        key <- engineKey(name, package)
        if (!is.null(package) && key[1L] != package)
            stop(gettextf("Engine name %s and package %s do not match",
                          sQuote(name), sQuote(package)), domain = NA)


        rname <- paste(key, collapse = "::")
        if (is.null(weave)) {
            result <- NULL
            if (exists(rname, envir = registry))
                rm(list = rname, envir = registry)
        } else {
            if (!is.function(weave) && is.na(weave)) {
                if (missing(tangle))
                    tangle <- NA
            } else {
                if (!is.function(weave))
                    stop(gettextf("Argument %s must be a function and not %s",
                                  sQuote("weave"), sQuote(class(weave)[1L])),
                         domain = NA)
                if (!is.function(tangle))
                    stop(gettextf("Argument %s must be a function and not %s",
                                  sQuote("tangle"), sQuote(class(tangle)[1L])),
                         domain = NA)
            }
            if (is.null(pattern))
                pattern <- "[.][rRsS](nw|tex)$"
            else if (!is.character(pattern))
                stop(gettextf("Argument %s must be a character vector or NULL and not %s",
                              sQuote("pattern"), sQuote(class(pattern)[1L])),
                     domain = NA)

            result <-
                list(name = key[2L], package = key[1L], pattern = pattern,
                     weave = weave, tangle = tangle, aspell = aspell)
            assign(rname, result, registry)
        }

        result
    }

    setEngine(name = "Sweave", package = "utils", pattern = NULL,
              weave = function(...) utils::Sweave(...),
              tangle = function(...) utils::Stangle(...),
              aspell = list(filter = "Sweave", control = "-t"))

    function(name, weave, tangle, pattern = NULL, package = NULL,
             aspell = list()) {
        if (missing(weave)) { # we're getting the engine
            getEngine(name, package)
        } else { # we're setting a new engine
            if (is.element(name, c("Sweave", "utils::Sweave"))) {
                stop(gettextf("Cannot change the %s engine or use an engine of that name",
                              sQuote("Sweave")), domain = NA)
            }
            if (missing(package))
                package <- utils::packageName(parent.frame())
            result <-
                setEngine(name, package, pattern = pattern,
                          weave = weave, tangle = tangle, aspell = aspell)
            invisible(result)
        }
    }
})

loadVignetteBuilder <-
function(pkgdir, mustwork = TRUE)
{
    pkgs <- .get_package_metadata(pkgdir)["VignetteBuilder"]
    if (is.na(pkgs))
        pkgs <- NULL
    else if (length(pkgs)) {
        pkgs <- unlist(strsplit(pkgs, ","))
        pkgs <- gsub('[[:space:]]', '', pkgs)
    }
    pkgs <- unique(c(pkgs, "utils"))

    for (pkg in pkgs) {
	res <- tryCatch(suppressPackageStartupMessages(loadNamespace(pkg)),
                        error = identity)
	if (mustwork && inherits(res, "error"))
            stop(gettextf("vignette builder '%s' not found", pkg), domain = NA)
    }
    pkgs
}

# This gets the info for installed packages

getVignetteInfo <- function(package = NULL, lib.loc = NULL, all = TRUE)
{
    paths <-
        if (is.null(package)) {
            package <- .packages(all.available = all, lib.loc)
            ## allow for misnamed dirs
            find.package(package, lib.loc, quiet = TRUE)
        } else
            find.package(package, lib.loc)

    ## Find the directories with a 'doc' subdirectory *possibly*
    ## containing vignettes.

    paths <- paths[dir.exists(file.path(paths, "doc"))]

    empty <- cbind(Package = character(0),
                   Dir = character(0),
                   Topic = character(0),
                   File = character(0),
                   Title = character(0),
                   R = character(0),
                   PDF = character(0))

    getVinfo <- function(dir) {
        entries <- NULL
        if (file.exists(INDEX <- file.path(dir, "Meta", "vignette.rds")))
            entries <- readRDS(INDEX)
        if (NROW(entries) > 0) {
            # FIXME:  this test is unnecessary?
            R <- if (is.null(entries$R)) rep.int("", NROW(entries)) else entries$R
            file <- basename(entries$File)
            pdf <- entries$PDF
            topic <- file_path_sans_ext(ifelse(R == "", ifelse(pdf == "", file, pdf), R))
            cbind(Package = basename(dir),
                  Dir = dir,
                  Topic = topic,
                  File = file,
                  Title = entries$Title,
                  R = R,
                  PDF = pdf)[order(entries$Title), , drop=FALSE]
        }
        else empty
    }

    if (length(paths))
    	do.call(rbind, lapply(paths, getVinfo))
    else
    	empty
}

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